Shows the targets available in <dir>
- make html
- make pdf
- make ps
-
- Make documentation
-
make install
Installs GHC, libraries and tools under $(prefix)
include mk/custom-settings.mk
# No need to update makefiles for these targets:
-REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help install-docs test fulltest,$(MAKECMDGOALS))
+REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help test fulltest,$(MAKECMDGOALS))
# configure touches certain files even if they haven't changed. This
# can mean a lot of unnecessary recompilation after a re-configure, so
$(MAKE) -C distrib/MacOS $@
endif
-# install-docs is a historical target that isn't supported in GHC 6.12. See #3662.
-install-docs:
- @echo "The install-docs target is not supported in GHC 6.12.1 and later."
- @echo "'make install' now installs everything, including documentation."
- @exit 1
-
# If the user says 'make A B', then we don't want to invoke two
# instances of the rule above in parallel:
.NOTPARALLEL:
$4="$$4 -arch x86_64"
$5="$$5 -m64"
;;
+ alpha-*)
+ # For now, to suppress the gcc warning "call-clobbered
+ # register used for global register variable", we simply
+ # disable all warnings altogether using the -w flag. Oh well.
+ $2="$$2 -w -mieee -D_REENTRANT"
+ $3="$$3 -w -mieee -D_REENTRANT"
+ $5="$$5 -w -mieee -D_REENTRANT"
+ ;;
+ hppa*)
+ # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
+ # (very nice, but too bad the HP /usr/include files don't agree.)
+ $2="$$2 -D_HPUX_SOURCE"
+ $3="$$3 -D_HPUX_SOURCE"
+ $5="$$5 -D_HPUX_SOURCE"
+ ;;
esac
# If gcc knows about the stack protector, turn it off.
# FP_PROG_AR_NEEDS_RANLIB
# -----------------------
# Sets the output variable RANLIB to "ranlib" if it is needed and found,
-# to ":" otherwise.
+# to "true" otherwise.
AC_DEFUN([FP_PROG_AR_NEEDS_RANLIB],
[AC_REQUIRE([FP_PROG_AR_IS_GNU])
AC_REQUIRE([FP_PROG_AR_ARGS])
if test $fp_cv_prog_ar_needs_ranlib = yes; then
AC_PROG_RANLIB
else
- RANLIB=":"
+ RANLIB="true"
AC_SUBST([RANLIB])
fi
])# FP_PROG_AR_NEEDS_RANLIB
])# FP_PROG_FOP
-# FP_PROG_HSTAGS
-# ----------------
-# Sets the output variable HstagsCmd to the full Haskell tags program path.
-# HstagsCmd is empty if no such program could be found.
-AC_DEFUN([FP_PROG_HSTAGS],
-[AC_PATH_PROG([HstagsCmd], [hasktags])
-if test -z "$HstagsCmd"; then
- AC_MSG_WARN([cannot find hasktags in your PATH, you will not be able to build the tags])
-fi
-])# FP_PROG_HSTAGS
-
-
# FP_PROG_GHC_PKG
# ----------------
# Try to find a ghc-pkg matching the ghc mentioned in the environment variable
use strict;
use Cwd;
+use File::Path 'rmtree';
+use File::Basename;
my %required_tag;
my $validate;
+my $curdir;
$required_tag{"-"} = 1;
$validate = 0;
+$curdir = &cwd()
+ or die "Can't find current directory: $!";
+
while ($#ARGV ne -1) {
my $arg = shift @ARGV;
}
}
-{
+sub sanity_check_line_endings {
local $/ = undef;
open FILE, "packages" or die "Couldn't open file: $!";
binmode FILE;
}
}
-# Create libraries/*/{ghc.mk,GNUmakefile}
-system("/usr/bin/perl", "-w", "boot-pkgs") == 0
- or die "Running boot-pkgs failed: $?";
+sub sanity_check_tree {
+ my $tag;
+ my $dir;
-my $tag;
-my $dir;
-my $curdir;
+ # Check that we have all boot packages.
+ open PACKAGES, "< packages";
+ while (<PACKAGES>) {
+ if (/^#/) {
+ # Comment; do nothing
+ }
+ elsif (/^([a-zA-Z0-9\/.-]+) +([^ ]+) +[^ ]+ +[^ ]+ +[^ ]+$/) {
+ $dir = $1;
+ $tag = $2;
+
+ # If $tag is not "-" then it is an optional repository, so its
+ # absence isn't an error.
+ if (defined($required_tag{$tag})) {
+ # We would like to just check for a .git directory here,
+ # but in an lndir tree we avoid making .git directories,
+ # so it doesn't exist. We therefore require that every repo
+ # has a LICENSE file instead.
+ if (! -f "$dir/LICENSE") {
+ print STDERR "Error: $dir/LICENSE doesn't exist.\n";
+ die "Maybe you haven't done './sync-all get'?";
+ }
+ }
+ }
+ else {
+ die "Bad line in packages file: $_";
+ }
+ }
+ close PACKAGES;
+}
-$curdir = &cwd()
- or die "Can't find current directory: $!";
+# Create libraries/*/{ghc.mk,GNUmakefile}
+sub boot_pkgs {
+ my @library_dirs = ();
+ my @tarballs = glob("libraries/tarballs/*");
+
+ my $tarball;
+ my $package;
+ my $stamp;
+
+ for $tarball (@tarballs) {
+ $package = $tarball;
+ $package =~ s#^libraries/tarballs/##;
+ $package =~ s/-[0-9.]*(-snapshot)?\.tar\.gz$//;
+
+ # Sanity check, so we don't rmtree the wrong thing below
+ if (($package eq "") || ($package =~ m#[/.\\]#)) {
+ die "Bad package name: $package";
+ }
-# Check that we have all boot packages.
-open PACKAGES, "< packages";
-while (<PACKAGES>) {
- if (/^#/) {
- # Comment; do nothing
+ if (-d "libraries/$package/_darcs") {
+ print "Ignoring libraries/$package as it looks like a darcs checkout\n"
+ }
+ elsif (-d "libraries/$package/.git") {
+ print "Ignoring libraries/$package as it looks like a git checkout\n"
+ }
+ else {
+ if (! -d "libraries/stamp") {
+ mkdir "libraries/stamp";
+ }
+ $stamp = "libraries/stamp/$package";
+ if ((! -d "libraries/$package") || (! -f "$stamp")
+ || ((-M "libraries/stamp/$package") > (-M $tarball))) {
+ print "Unpacking $package\n";
+ if (-d "libraries/$package") {
+ &rmtree("libraries/$package")
+ or die "Can't remove libraries/$package: $!";
+ }
+ mkdir "libraries/$package"
+ or die "Can't create libraries/$package: $!";
+ system ("sh", "-c", "cd 'libraries/$package' && { cat ../../$tarball | gzip -d | tar xf - ; } && mv */* .") == 0
+ or die "Failed to unpack $package";
+ open STAMP, "> $stamp"
+ or die "Failed to open stamp file: $!";
+ close STAMP
+ or die "Failed to close stamp file: $!";
+ }
+ }
}
- elsif (/^([a-zA-Z0-9\/.-]+) +([^ ]+) +[^ ]+ +[^ ]+ +[^ ]+$/) {
- $dir = $1;
- $tag = $2;
-
- # If $tag is not "-" then it is an optional repository, so its
- # absence isn't an error.
- if (defined($required_tag{$tag})) {
- # We would like to just check for a .git directory here,
- # but in an lndir tree we avoid making .git directories,
- # so it doesn't exist. We therefore require that every repo
- # has a LICENSE file instead.
- if (! -f "$dir/LICENSE") {
- print STDERR "Error: $dir/LICENSE doesn't exist.\n";
- die "Maybe you haven't done './sync-all get'?";
+
+ for $package (glob "libraries/*/") {
+ $package =~ s/\/$//;
+ my $pkgs = "$package/ghc-packages";
+ if (-f $pkgs) {
+ open PKGS, "< $pkgs"
+ or die "Failed to open $pkgs: $!";
+ while (<PKGS>) {
+ chomp;
+ s/\r//g;
+ if (/.+/) {
+ push @library_dirs, "$package/$_";
+ }
}
}
+ else {
+ push @library_dirs, $package;
+ }
}
- else {
- die "Bad line in packages file: $_";
+
+ for $package (@library_dirs) {
+ my $dir = &basename($package);
+ my @cabals = glob("$package/*.cabal");
+ if ($#cabals > 0) {
+ die "Too many .cabal file in $package\n";
+ }
+ if ($#cabals eq 0) {
+ my $cabal = $cabals[0];
+ my $pkg;
+ my $top;
+ if (-f $cabal) {
+ $pkg = $cabal;
+ $pkg =~ s#.*/##;
+ $pkg =~ s/\.cabal$//;
+ $top = $package;
+ $top =~ s#[^/]+#..#g;
+ $dir = $package;
+ $dir =~ s#^libraries/##g;
+
+ print "Creating $package/ghc.mk\n";
+ open GHCMK, "> $package/ghc.mk"
+ or die "Opening $package/ghc.mk failed: $!";
+ print GHCMK "${package}_PACKAGE = ${pkg}\n";
+ print GHCMK "${package}_dist-install_GROUP = libraries\n";
+ print GHCMK "\$(eval \$(call build-package,${package},dist-install,\$(if \$(filter ${dir},\$(STAGE2_PACKAGES)),2,1)))\n";
+ close GHCMK
+ or die "Closing $package/ghc.mk failed: $!";
+
+ print "Creating $package/GNUmakefile\n";
+ open GNUMAKEFILE, "> $package/GNUmakefile"
+ or die "Opening $package/GNUmakefile failed: $!";
+ print GNUMAKEFILE "dir = ${package}\n";
+ print GNUMAKEFILE "TOP = ${top}\n";
+ print GNUMAKEFILE "include \$(TOP)/mk/sub-makefile.mk\n";
+ print GNUMAKEFILE "FAST_MAKE_OPTS += stage=0\n";
+ close GNUMAKEFILE
+ or die "Closing $package/GNUmakefile failed: $!";
+ }
+ }
}
}
-close PACKAGES;
# autoreconf everything that needs it.
-foreach $dir (".", glob("libraries/*/")) {
- if (-f "$dir/configure.ac") {
- print "Booting $dir\n";
- chdir $dir or die "can't change to $dir: $!";
- system("autoreconf") == 0
- or die "Running autoreconf failed with exitcode $?";
- chdir $curdir or die "can't change to $curdir: $!";
+sub autoreconf {
+ my $dir;
+
+ foreach $dir (".", glob("libraries/*/")) {
+ if (-f "$dir/configure.ac") {
+ print "Booting $dir\n";
+ chdir $dir or die "can't change to $dir: $!";
+ system("autoreconf") == 0
+ or die "Running autoreconf failed with exitcode $?";
+ chdir $curdir or die "can't change to $curdir: $!";
+ }
}
}
-if ($validate eq 0 && ! -f "mk/build.mk") {
- print <<EOF;
+sub checkBuildMk {
+ if ($validate eq 0 && ! -f "mk/build.mk") {
+ print <<EOF;
WARNING: You don't have a mk/build.mk file.
http://hackage.haskell.org/trac/ghc/wiki/Building/Using#Buildconfiguration
EOF
+ }
}
+&sanity_check_line_endings();
+&sanity_check_tree();
+&boot_pkgs();
+&autoreconf();
+&checkBuildMk();
+
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-
-use File::Path 'rmtree';
-use File::Basename;
-
-my @library_dirs = ();
-my @tarballs = glob("libraries/tarballs/*");
-
-my $tarball;
-my $package;
-my $stamp;
-
-for $tarball (@tarballs) {
- $package = $tarball;
- $package =~ s#^libraries/tarballs/##;
- $package =~ s/-[0-9.]*(-snapshot)?\.tar\.gz$//;
-
- # Sanity check, so we don't rmtree the wrong thing below
- if (($package eq "") || ($package =~ m#[/.\\]#)) {
- die "Bad package name: $package";
- }
-
- if (-d "libraries/$package/_darcs") {
- print "Ignoring libraries/$package as it looks like a darcs checkout\n"
- }
- elsif (-d "libraries/$package/.git") {
- print "Ignoring libraries/$package as it looks like a git checkout\n"
- }
- else {
- if (! -d "libraries/stamp") {
- mkdir "libraries/stamp";
- }
- $stamp = "libraries/stamp/$package";
- if ((! -d "libraries/$package") || (! -f "$stamp")
- || ((-M "libraries/stamp/$package") > (-M $tarball))) {
- print "Unpacking $package\n";
- if (-d "libraries/$package") {
- &rmtree("libraries/$package")
- or die "Can't remove libraries/$package: $!";
- }
- mkdir "libraries/$package"
- or die "Can't create libraries/$package: $!";
- system ("sh", "-c", "cd 'libraries/$package' && { cat ../../$tarball | gzip -d | tar xf - ; } && mv */* .") == 0
- or die "Failed to unpack $package";
- open STAMP, "> $stamp"
- or die "Failed to open stamp file: $!";
- close STAMP
- or die "Failed to close stamp file: $!";
- }
- }
-}
-
-for $package (glob "libraries/*/") {
- $package =~ s/\/$//;
- my $pkgs = "$package/ghc-packages";
- if (-f $pkgs) {
- open PKGS, "< $pkgs"
- or die "Failed to open $pkgs: $!";
- while (<PKGS>) {
- chomp;
- s/\r//g;
- if (/.+/) {
- push @library_dirs, "$package/$_";
- }
- }
- }
- else {
- push @library_dirs, $package;
- }
-}
-
-for $package (@library_dirs) {
- my $dir = &basename($package);
- my @cabals = glob("$package/*.cabal");
- if ($#cabals > 0) {
- die "Too many .cabal file in $package\n";
- }
- if ($#cabals eq 0) {
- my $cabal = $cabals[0];
- my $pkg;
- my $top;
- if (-f $cabal) {
- $pkg = $cabal;
- $pkg =~ s#.*/##;
- $pkg =~ s/\.cabal$//;
- $top = $package;
- $top =~ s#[^/]+#..#g;
- $dir = $package;
- $dir =~ s#^libraries/##g;
-
- print "Creating $package/ghc.mk\n";
- open GHCMK, "> $package/ghc.mk"
- or die "Opening $package/ghc.mk failed: $!";
- print GHCMK "${package}_PACKAGE = ${pkg}\n";
- print GHCMK "${package}_dist-install_GROUP = libraries\n";
- print GHCMK "\$(eval \$(call build-package,${package},dist-install,\$(if \$(filter ${dir},\$(STAGE2_PACKAGES)),2,1)))\n";
- close GHCMK
- or die "Closing $package/ghc.mk failed: $!";
-
- print "Creating $package/GNUmakefile\n";
- open GNUMAKEFILE, "> $package/GNUmakefile"
- or die "Opening $package/GNUmakefile failed: $!";
- print GNUMAKEFILE "dir = ${package}\n";
- print GNUMAKEFILE "TOP = ${top}\n";
- print GNUMAKEFILE "include \$(TOP)/mk/sub-makefile.mk\n";
- print GNUMAKEFILE "FAST_MAKE_OPTS += stage=0\n";
- close GNUMAKEFILE
- or die "Closing $package/GNUmakefile failed: $!";
- }
- }
-}
-
inlinePragmaActivation, inlinePragmaRuleMatchInfo,
setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
- SuccessFlag(..), succeeded, failed, successIf
+ SuccessFlag(..), succeeded, failed, successIf,
+
+ FractionalLit(..), negateFractionalLit, integralFractionalLit
) where
import FastString
import Outputable
import Data.Data hiding (Fixity)
+import Data.Function (on)
\end{code}
%************************************************************************
isEarlyActive _ = False
\end{code}
+
+
+\begin{code}
+-- Used (instead of Rational) to represent exactly the floating point literal that we
+-- encountered in the user's source program. This allows us to pretty-print exactly what
+-- the user wrote, which is important e.g. for floating point numbers that can't represented
+-- as Doubles (we used to via Double for pretty-printing). See also #2245.
+data FractionalLit
+ = FL { fl_text :: String -- How the value was written in the source
+ , fl_value :: Rational -- Numeric value of the literal
+ }
+ deriving (Data, Typeable, Show)
+ -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on
+
+negateFractionalLit :: FractionalLit -> FractionalLit
+negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value }
+negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value }
+
+integralFractionalLit :: Integer -> FractionalLit
+integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i }
+
+-- Comparison operations are needed when grouping literals
+-- for compiling pattern-matching (module MatchLit)
+
+instance Eq FractionalLit where
+ (==) = (==) `on` fl_value
+
+instance Ord FractionalLit where
+ compare = compare `on` fl_value
+
+instance Outputable FractionalLit where
+ ppr = text . fl_text
+\end{code}
dataConName, dataConIdentity, dataConTag, dataConTyCon,
dataConOrigTyCon, dataConUserType,
dataConUnivTyVars, dataConExTyVars, dataConAllTyVars,
- dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta,
+ dataConEqSpec, eqSpecPreds, dataConTheta,
dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys,
-- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
- isVanillaDataCon, classDataCon,
+ isVanillaDataCon, classDataCon, dataConCannotMatch,
-- * Splitting product types
splitProductType_maybe, splitProductType, deepSplitProductType,
#include "HsVersions.h"
import Type
+import Unify
import Coercion
import TyCon
import Class
import qualified Data.Data as Data
import Data.Char
import Data.Word
-import Data.List ( partition )
\end{code}
-- dcUnivTyVars = [a]
-- dcExTyVars = [x,y]
-- dcEqSpec = [a~(x,y)]
- -- dcEqTheta = [x~y]
- -- dcDictTheta = [Ord x]
+ -- dcOtherTheta = [x~y, Ord x]
-- dcOrigArgTys = [a,List b]
-- dcRepTyCon = T
-- Its type is of form
-- forall a1..an . t1 -> ... tm -> T a1..an
-- No existentials, no coercions, nothing.
- -- That is: dcExTyVars = dcEqSpec = dcEqTheta = dcDictTheta = []
+ -- That is: dcExTyVars = dcEqSpec = dcOtherTheta = []
-- NB 1: newtypes always have a vanilla data con
-- NB 2: a vanilla constructor can still be declared in GADT-style
-- syntax, provided its type looks like the above.
-- In GADT form, this is *exactly* what the programmer writes, even if
-- the context constrains only universally quantified variables
-- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b
- dcEqTheta :: ThetaType, -- The *equational* constraints
- dcDictTheta :: ThetaType, -- The *type-class and implicit-param* constraints
+ dcOtherTheta :: ThetaType, -- The other constraints in the data con's type
+ -- other than those in the dcEqSpec
dcStupidTheta :: ThetaType, -- The context of the data type declaration
-- data Eq a => T a = ...
-- length = 0 (if not a record) or dataConSourceArity.
-- Constructor representation
- dcRepArgTys :: [Type], -- Final, representation argument types,
- -- after unboxing and flattening,
- -- and *including* existential dictionaries
+ dcRepArgTys :: [Type], -- Final, representation argument types,
+ -- after unboxing and flattening,
+ -- and *including* all existential evidence args
dcRepStrictness :: [StrictnessMark],
-- One for each *representation* *value* argument
dcVanilla = is_vanilla, dcInfix = declared_infix,
dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcEqSpec = eq_spec,
+ dcOtherTheta = theta,
dcStupidTheta = stupid_theta,
- dcEqTheta = eq_theta, dcDictTheta = dict_theta,
dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
dcRepTyCon = rep_tycon,
dcRepArgTys = rep_arg_tys,
-- The 'arg_stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
- (eq_theta,dict_theta) = partition isEqPred theta
- dict_tys = mkPredTys dict_theta
- real_arg_tys = dict_tys ++ orig_arg_tys
- real_stricts = map mk_dict_strict_mark dict_theta ++ arg_stricts
+ full_theta = eqSpecPreds eq_spec ++ theta
+ real_arg_tys = mkPredTys full_theta ++ orig_arg_tys
+ real_stricts = map mk_dict_strict_mark full_theta ++ arg_stricts
-- Representation arguments and demands
-- To do: eliminate duplication with MkId
tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $
- mkFunTys (mkPredTys (eqSpecPreds eq_spec)) $
- mkFunTys (mkPredTys eq_theta) $
- -- NB: the dict args are already in rep_arg_tys
- -- because they might be flattened..
- -- but the equality predicates are not
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
dataConEqSpec :: DataCon -> [(TyVar,Type)]
dataConEqSpec = dcEqSpec
--- | The equational constraints on the data constructor type
-dataConEqTheta :: DataCon -> ThetaType
-dataConEqTheta = dcEqTheta
-
--- | The type class and implicit parameter contsraints on the data constructor type
-dataConDictTheta :: DataCon -> ThetaType
-dataConDictTheta = dcDictTheta
+-- | The *full* constraints on the constructor type
+dataConTheta :: DataCon -> ThetaType
+dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
+ = eqSpecPreds eq_spec ++ theta
-- | Get the Id of the 'DataCon' worker: a function that is the "actual"
-- constructor and has no top level binding in the program. The type may
dataConStrictMarks :: DataCon -> [HsBang]
dataConStrictMarks = dcStrictMarks
--- | Strictness of /existential/ arguments only
+-- | Strictness of evidence arguments to the wrapper function
dataConExStricts :: DataCon -> [HsBang]
-- Usually empty, so we don't bother to cache this
-dataConExStricts dc = map mk_dict_strict_mark $ dcDictTheta dc
+dataConExStricts dc = map mk_dict_strict_mark $ (dataConTheta dc)
-- | Source-level arity of the data constructor
dataConSourceArity :: DataCon -> Arity
--
-- 4) The /original/ result type of the 'DataCon'
dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type)
-dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
- dcEqTheta = eq_theta, dcDictTheta = dict_theta,
+dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
+ dcEqSpec = eq_spec, dcOtherTheta = theta,
dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
- = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ eq_theta ++ dict_theta, arg_tys, res_ty)
+ = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty)
-- | The \"full signature\" of the 'DataCon' returns, in order:
--
--
-- 6) The original result type of the 'DataCon'
dataConFullSig :: DataCon
- -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, ThetaType, [Type], Type)
-dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
- dcEqTheta = eq_theta, dcDictTheta = dict_theta,
+ -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type)
+dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
+ dcEqSpec = eq_spec, dcOtherTheta = theta,
dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
- = (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, res_ty)
+ = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)
dataConOrigResTy :: DataCon -> Type
dataConOrigResTy dc = dcOrigResTy dc
-- mentions the family tycon, not the internal one.
dataConUserType (MkData { dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
- dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = arg_tys,
+ dcOtherTheta = theta, dcOrigArgTys = arg_tys,
dcOrigResTy = res_ty })
= mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
- mkFunTys (mkPredTys eq_theta) $
- mkFunTys (mkPredTys dict_theta) $
+ mkFunTys (mkPredTys theta) $
mkFunTys arg_tys $
res_ty
[] -> panic "classDataCon"
\end{code}
+\begin{code}
+dataConCannotMatch :: [Type] -> DataCon -> Bool
+-- Returns True iff the data con *definitely cannot* match a
+-- scrutinee of type (T tys)
+-- where T is the type constructor for the data con
+-- NB: look at *all* equality constraints, not only those
+-- in dataConEqSpec; see Trac #5168
+dataConCannotMatch tys con
+ | null theta = False -- Common
+ | all isTyVarTy tys = False -- Also common
+ | otherwise
+ = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2)
+ | EqPred ty1 ty2 <- theta ]
+ where
+ dc_tvs = dataConUnivTyVars con
+ theta = dataConTheta con
+ subst = zipTopTvSubst dc_tvs tys
+\end{code}
+
%************************************************************************
%* *
\subsection{Splitting products}
-- * 'Var.Var': see "Var#name_types"
module Id (
-- * The main types
- Id, DictId,
+ Var, Id, isId,
-- ** Simple construction
mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
-- ** Taking an Id apart
idName, idType, idUnique, idInfo, idDetails,
- isId, idPrimRep,
- recordSelectorFieldLabel,
+ idPrimRep, recordSelectorFieldLabel,
-- ** Modifying an Id
setIdName, setIdUnique, Id.setIdType,
-- ** Predicates on Ids
- isImplicitId, isDeadBinder, isDictId, isStrictId,
+ isImplicitId, isDeadBinder,
+ isStrictId,
isExportedId, isLocalId, isGlobalId,
isRecordSelector, isNaughtyRecordSelector,
isClassOpId_maybe, isDFunId, dfunNSilent,
isTickBoxOp, isTickBoxOp_maybe,
hasNoBinding,
+ -- ** Evidence variables
+ DictId, isDictId, isEvVar, evVarPred,
+
-- ** Inline pragma stuff
idInlinePragma, setInlinePragma, modifyInlinePragma,
idInlineActivation, setInlineActivation, idRuleMatchInfo,
import BasicTypes
-- Imported and re-exported
-import Var( Var, Id, DictId,
- idInfo, idDetails, globaliseId,
+import Var( Var, Id, DictId, EvVar,
+ idInfo, idDetails, globaliseId, varType,
isId, isLocalId, isGlobalId, isExportedId )
import qualified Var
-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker
idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id)
-
-isDictId :: Id -> Bool
-isDictId id = isDictTy (idType id)
-
hasNoBinding :: Id -> Bool
-- ^ Returns @True@ of an 'Id' which may not have a
-- binding, even though it is defined in this module.
%************************************************************************
%* *
+ Evidence variables
+%* *
+%************************************************************************
+
+\begin{code}
+isEvVar :: Var -> Bool
+isEvVar var = isPredTy (varType var)
+
+isDictId :: Id -> Bool
+isDictId id = isDictTy (idType id)
+
+evVarPred :: EvVar -> PredType
+evVarPred var
+ = case splitPredTy_maybe (varType var) of
+ Just pred -> pred
+ Nothing -> pprPanic "evVarPred" (ppr var <+> ppr (varType var))
+\end{code}
+
+%************************************************************************
+%* *
\subsection{IdInfo stuff}
%* *
%************************************************************************
\begin{code}
module IdInfo (
-- * The IdDetails type
- IdDetails(..), pprIdDetails,
+ IdDetails(..), pprIdDetails, coVarDetails,
-- * The IdInfo type
IdInfo, -- Abstract
-- implemented with a newtype, so it might be bad
-- to be strict on this dictionary
+coVarDetails :: IdDetails
+coVarDetails = VanillaId
+
instance Outputable IdDetails where
ppr = pprIdDetails
data IdInfo
data IdDetails
+vanillaIdInfo :: IdInfo
+coVarDetails :: IdDetails
pprIdDetails :: IdDetails -> SDoc
\end{code}
\ No newline at end of file
\begin{code}
module MkId (
- mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId,
+ mkDictFunId, mkDictFunTy, mkDictSelId,
mkDataConIds,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
unsafeCoerceName, unsafeCoerceId, realWorldPrimId,
- voidArgId, nullAddrId, seqId, lazyId, lazyIdKey
+ voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
+ coercionTokenId,
+
+ -- Re-export error Ids
+ module PrelRules
) where
#include "HsVersions.h"
import Rules
import TysPrim
+import TysWiredIn ( unitTy )
import PrelRules
import Type
import Coercion
import ForeignCall
import DataCon
import Id
-import Var ( Var, TyVar, mkCoVar, mkExportedLocalVar )
+import Var ( mkExportedLocalVar )
import IdInfo
import Demand
import CoreSyn
import PrelNames
import BasicTypes hiding ( SuccessFlag(..) )
import Util
+import Pair
import Outputable
import FastString
import ListSetOps
= DCIds Nothing wrk_id
where
(univ_tvs, ex_tvs, eq_spec,
- eq_theta, dict_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
+ other_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
tycon = dataConTyCon data_con -- The representation TyCon (not family)
----------- Worker (algebraic data types only) --------------
-- extra constraints where necessary.
wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
- eq_tys = mkPredTys eq_theta
- dict_tys = mkPredTys dict_theta
- wrap_ty = mkForAllTys wrap_tvs $ mkFunTys eq_tys $ mkFunTys dict_tys $
- mkFunTys orig_arg_tys $ res_ty
- -- NB: watch out here if you allow user-written equality
- -- constraints in data constructor signatures
+ ev_tys = mkPredTys other_theta
+ wrap_ty = mkForAllTys wrap_tvs $
+ mkFunTys ev_tys $
+ mkFunTys orig_arg_tys $ res_ty
----------- Wrappers for algebraic data types --------------
alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
`setStrictnessInfo` Just wrap_sig
all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
- wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info)
- arg_dmds = map mk_dmd all_strict_marks
+ wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info)
+ wrap_stricts = dropList eq_spec all_strict_marks
+ wrap_arg_dmds = map mk_dmd wrap_stricts
mk_dmd str | isBanged str = evalDmd
| otherwise = lazyDmd
-- The Cpr info can be important inside INLINE rhss, where the
-- ...(let w = C x in ...(w p q)...)...
-- we want to see that w is strict in its two arguments
- wrap_unf = mkInlineUnfolding (Just (length dict_args + length id_args)) wrap_rhs
+ wrap_unf = mkInlineUnfolding (Just (length ev_args + length id_args)) wrap_rhs
wrap_rhs = mkLams wrap_tvs $
- mkLams eq_args $
- mkLams dict_args $ mkLams id_args $
+ mkLams ev_args $
+ mkLams id_args $
foldr mk_case con_app
- (zip (dict_args ++ id_args) all_strict_marks)
+ (zip (ev_args ++ id_args) wrap_stricts)
i3 []
+ -- The ev_args is the evidence arguments *other than* the eq_spec
+ -- Because we are going to apply the eq_spec args manually in the
+ -- wrapper
con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $
Var wrk_id `mkTyApps` res_ty_args
`mkVarApps` ex_tvs
- -- Equality evidence:
- `mkTyApps` map snd eq_spec
- `mkVarApps` eq_args
+ `mkCoApps` map (mkReflCo . snd) eq_spec
`mkVarApps` reverse rep_ids
- (dict_args,i2) = mkLocals 1 dict_tys
- (id_args,i3) = mkLocals i2 orig_arg_tys
- wrap_arity = i3-1
- (eq_args,_) = mkCoVarLocals i3 eq_tys
-
- mkCoVarLocals i [] = ([],i)
- mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
- y = mkCoVar (mkSysTvName (mkBuiltinUnique i)
- (fsLit "dc_co")) x
- in (y:ys,j)
+ (ev_args,i2) = mkLocals 1 ev_tys
+ (id_args,i3) = mkLocals i2 orig_arg_tys
+ wrap_arity = i3-1
mk_case
:: (Id, HsBang) -- Arg, strictness
occNameFS (getOccName name)
, ru_fn = name
, ru_nargs = n_ty_args + 1
- , ru_try = dictSelRule val_index n_ty_args n_eq_args }
+ , ru_try = dictSelRule val_index n_ty_args }
-- The strictness signature is of the form U(AAAVAAAA) -> T
-- where the V depends on which item we are selecting
[data_con] = tyConDataCons tycon
tyvars = dataConUnivTyVars data_con
arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses
- eq_theta = dataConEqTheta data_con
- n_eq_args = length eq_theta
-- 'index' is a 0-index into the *value* arguments of the dictionary
val_index = assoc "MkId.mkDictSelId" sel_index_prs name
pred = mkClassPred clas (mkTyVarTys tyvars)
dict_id = mkTemplateLocal 1 $ mkPredTy pred
arg_ids = mkTemplateLocalsNum 2 arg_tys
- eq_ids = map mkWildEvBinder eq_theta
rhs = mkLams tyvars (Lam dict_id rhs_body)
rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
| otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
- [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
+ [(DataAlt data_con, arg_ids, Var the_arg_id)]
-dictSelRule :: Int -> Arity -> Arity
+dictSelRule :: Int -> Arity
-> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- Tries to persuade the argument to look like a constructor
-- application, using exprIsConApp_maybe, and then selects
-- from it
-- sel_i t1..tk (D t1..tk op1 ... opm) = opi
--
-dictSelRule val_index n_ty_args n_eq_args id_unf args
+dictSelRule val_index n_ty_args id_unf args
| (dict_arg : _) <- drop n_ty_args args
, Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
- , let val_args = drop n_eq_args con_args
- = Just (val_args !! val_index)
+ = Just (con_args !! val_index)
| otherwise
= Nothing
\end{code}
mkReboxingAlt
:: [Unique] -- Uniques for the new Ids
-> DataCon
- -> [Var] -- Source-level args, including existential dicts
+ -> [Var] -- Source-level args, *including* all evidence vars
-> CoreExpr -- RHS
-> CoreAlt
-- Type variable case
go (arg:args) stricts us
- | isTyCoVar arg
+ | isTyVar arg
= let (binds, args') = go args stricts us
in (binds, arg:args')
-- Term variable case
go (arg:args) (str:stricts) us
| isMarkedUnboxed str
- =
- let (binds, unpacked_args') = go args stricts us'
+ = let (binds, unpacked_args') = go args stricts us'
(us', bind_rhs, unpacked_args) = reboxProduct us (idType arg)
in
(NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args')
-- coercion constructor of the newtype or applied by itself).
wrapNewTypeBody tycon args result_expr
- = wrapFamInstBody tycon args inner
+ = ASSERT( isNewTyCon tycon )
+ wrapFamInstBody tycon args $
+ mkCoerce (mkSymCo co) result_expr
where
- inner
- | Just co_con <- newTyConCo_maybe tycon
- = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
- | otherwise
- = result_expr
+ co = mkAxInstCo (newTyConCo tycon) args
-- When unwrapping, we do *not* apply any family coercion, because this will
-- be done via a CoPat by the type checker. We have to do it this way as
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
- | Just co_con <- newTyConCo_maybe tycon
- = mkCoerce (mkTyConApp co_con args) result_expr
- | otherwise
- = result_expr
+ = ASSERT( isNewTyCon tycon )
+ mkCoerce (mkAxInstCo (newTyConCo tycon) args) result_expr
-- If the type constructor is a representation type of a data instance, wrap
-- the expression into a cast adjusting the expression type, which is an
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody tycon args body
| Just co_con <- tyConFamilyCoercion_maybe tycon
- = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) body
+ = mkCoerce (mkSymCo (mkAxInstCo co_con args)) body
| otherwise
= body
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut
| Just co_con <- tyConFamilyCoercion_maybe tycon
- = mkCoerce (mkTyConApp co_con args) scrut
+ = mkCoerce (mkAxInstCo co_con args) scrut
| otherwise
= scrut
\end{code}
that they aren't discarded by the occurrence analyser.
\begin{code}
-mkDefaultMethodId :: Id -- Selector Id
- -> Name -- Default method name
- -> Id -- Default method Id
-mkDefaultMethodId sel_id dm_name = mkExportedLocalId dm_name (idType sel_id)
-
mkDictFunId :: Name -- Name to use for the dict fun;
-> [TyVar]
-> ThetaType
(classSCTheta clas)
-- See Note [Silent Superclass Arguments]
discard pred = isEmptyVarSet (tyVarsOfPred pred)
- || any (`tcEqPred` pred) theta
+ || any (`eqPred` pred) theta
-- See the DFun Superclass Invariant in TcInstDcls
\end{code}
another gun with which to shoot yourself in the foot.
\begin{code}
-lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name
-unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
-nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId
-seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId
-realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId
-lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId
+lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName :: Name
+unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
+nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId
+seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId
+realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId
+lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId
+coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId
\end{code}
\begin{code}
(mkFunTy argAlphaTy openBetaTy)
[x] = mkTemplateLocals [argAlphaTy]
rhs = mkLams [argAlphaTyVar,openBetaTyVar,x] $
- Cast (Var x) (mkUnsafeCoercion argAlphaTy openBetaTy)
+ Cast (Var x) (mkUnsafeCo argAlphaTy openBetaTy)
------------------------------------------------
nullAddrId :: Id
match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- See Note [Built-in RULES for seq]
match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr]
- = Just (Var seqId `mkApps` [Type (fst (coercionKind co)), Type res_ty,
+ = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
scrut, expr])
match_seq_of_cast _ _ = Nothing
voidArgId :: Id
voidArgId -- :: State# RealWorld
= mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy
+
+coercionTokenId :: Id -- :: () ~ ()
+coercionTokenId -- Used to replace Coercion terms when we go to STG
+ = pcMiscPrelId coercionTokenName
+ (mkTyConApp eqPredPrimTyCon [unitTy, unitTy])
+ noCafIdInfo
\end{code}
import Config
import Outputable
-import qualified Pretty
import Unique
import UniqFM
import FastString
mkModule = Module
pprModule :: Module -> SDoc
-pprModule mod@(Module p n) = pprPackagePrefix p mod <> pprModuleName n
+pprModule mod@(Module p n) =
+ pprPackagePrefix p mod <> pprModuleName n
-pprPackagePrefix :: PackageId -> Module -> PprStyle -> Pretty.Doc
+pprPackagePrefix :: PackageId -> Module -> SDoc
pprPackagePrefix p mod = getPprStyle doc
where
doc sty
get (Just d1, _u1) d2 = d1 `unionNameSets` d2
allUses :: DefUses -> Uses
--- ^ Just like 'allUses', but 'Defs' are not eliminated from the 'Uses' returned
+-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned
allUses dus = foldr get emptyNameSet dus
where
get (_d1, u1) u2 = u1 `unionNameSets` u2
duUses :: DefUses -> Uses
-- ^ Collect all 'Uses', regardless of whether the group is itself used,
-- but remove 'Defs' on the way
-duUses dus
- = foldr get emptyNameSet dus
+duUses dus = foldr get emptyNameSet dus
where
get (Nothing, rhs_uses) uses = rhs_uses `unionNameSets` uses
get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSets` uses)
-- ** Derived 'OccName's
isDerivedOccName,
- mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc,
+ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+ mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
mkInstTyCoOcc, mkEqPredCoOcc,
\end{code}
\begin{code}
-mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
- mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
- mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
+ mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc,
+ mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+ mkGenD, mkGenR, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkDataConWrapperOcc = mk_simple_deriv varName "$W"
mkWorkerOcc = mk_simple_deriv varName "$w"
mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
+mkGenDefMethodOcc = mk_simple_deriv varName "$gdm"
mkClassOpAuxOcc = mk_simple_deriv varName "$c"
mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies
mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon
mkTag2ConOcc = mk_simple_deriv varName "$tag2con_"
mkMaxTagOcc = mk_simple_deriv varName "$maxtag_"
--- Generic derivable classes
+-- Generic derivable classes (old)
mkGenOcc1 = mk_simple_deriv varName "$gfrom"
mkGenOcc2 = mk_simple_deriv varName "$gto"
+-- Generic deriving mechanism (new)
+mkGenD = mk_simple_deriv tcName "D1"
+
+mkGenC :: OccName -> Int -> OccName
+mkGenC occ m = mk_deriv tcName ("C1_" ++ show m) (occNameString occ)
+
+mkGenS :: OccName -> Int -> Int -> OccName
+mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n)
+ (occNameString occ)
+
+mkGenR = mk_simple_deriv tcName "Rep_"
+mkGenRCo = mk_simple_deriv tcName "CoRep_"
+
-- data T = MkT ... deriving( Data ) needs defintions for
-- $tT :: Data.Generics.Basics.DataType
-- $cMkT :: Data.Generics.Basics.Constr
module Var (
-- * The main data type and synonyms
- Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
+ Var, TyVar, CoVar, TyCoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
-- ** Taking 'Var's apart
varName, varUnique, varType,
setVarName, setVarUnique, setVarType,
-- ** Constructing, taking apart, modifying 'Id's
- mkGlobalVar, mkLocalVar, mkExportedLocalVar,
+ mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar,
idInfo, idDetails,
lazySetIdInfo, setIdDetails, globaliseId,
setIdExported, setIdNotExported,
-- ** Predicates
- isCoVar, isId, isTyCoVar, isTyVar, isTcTyVar,
+ isId, isTyVar, isTcTyVar,
isLocalVar, isLocalId,
isGlobalId, isExportedId,
mustHaveLocalBinding,
-- ** Constructing 'TyVar's
- mkTyVar, mkTcTyVar, mkWildCoVar,
+ mkTyVar, mkTcTyVar,
-- ** Taking 'TyVar's apart
tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,
-- ** Modifying 'TyVar's
- setTyVarName, setTyVarUnique, setTyVarKind,
-
- -- ** Constructing 'CoVar's
- mkCoVar,
-
- -- ** Taking 'CoVar's apart
- coVarName,
-
- -- ** Modifying 'CoVar's
- setCoVarUnique, setCoVarName
+ setTyVarName, setTyVarUnique, setTyVarKind
) where
import {-# SOURCE #-} TypeRep( Type, Kind )
import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails )
-import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, pprIdDetails )
-import {-# SOURCE #-} TypeRep( isCoercionKind )
+import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo, pprIdDetails )
import Name hiding (varName)
import Unique
-- large number of SOURCE imports of Id.hs :-(
\begin{code}
-type EvVar = Var -- An evidence variable: dictionary or equality constraint
+type EvVar = Var -- An evidence variable: dictionary or equality constraint
-- Could be an DictId or a CoVar
type Id = Var -- A term-level identifier
type IpId = EvId -- A term-level implicit parameter
type TyVar = Var
-type CoVar = TyVar -- A coercion variable is simply a type
+type CoVar = Id -- A coercion variable is simply an Id
-- variable of kind @ty1 ~ ty2@. Hence its
-- 'varType' is always @PredTy (EqPred t1 t2)@
+type TyCoVar = TyVar -- Something that is a type OR coercion variable.
\end{code}
%************************************************************************
realUnique :: FastInt, -- Key for fast comparison
-- Identical to the Unique in the name,
-- cached here for speed
- varType :: Kind, -- ^ The type or kind of the 'Var' in question
- isCoercionVar :: Bool
+ varType :: Kind -- ^ The type or kind of the 'Var' in question
}
| TcTyVar { -- Used only during type inference
ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
ppr_debug :: Var -> SDoc
-ppr_debug (TyVar { isCoercionVar = False }) = ptext (sLit "tv")
-ppr_debug (TyVar { isCoercionVar = True }) = ptext (sLit "co")
-ppr_debug (TcTyVar {tc_tv_details = d}) = pprTcTyVarDetails d
+ppr_debug (TyVar {}) = ptext (sLit "tv")
+ppr_debug (TcTyVar {tc_tv_details = d}) = pprTcTyVarDetails d
ppr_debug (Id { idScope = s, id_details = d }) = ppr_id_scope s <> pprIdDetails d
ppr_id_scope :: IdScope -> SDoc
\begin{code}
mkTyVar :: Name -> Kind -> TyVar
-mkTyVar name kind = ASSERT( not (isCoercionKind kind ) )
- TyVar { varName = name
+mkTyVar name kind = TyVar { varName = name
, realUnique = getKeyFastInt (nameUnique name)
, varType = kind
- , isCoercionVar = False
}
mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar
%************************************************************************
%* *
-\subsection{Coercion variables}
-%* *
-%************************************************************************
-
-\begin{code}
-coVarName :: CoVar -> Name
-coVarName = varName
-
-setCoVarUnique :: CoVar -> Unique -> CoVar
-setCoVarUnique = setVarUnique
-
-setCoVarName :: CoVar -> Name -> CoVar
-setCoVarName = setVarName
-
-mkCoVar :: Name -> Kind -> CoVar
-mkCoVar name kind = ASSERT( isCoercionKind kind )
- TyVar { varName = name
- , realUnique = getKeyFastInt (nameUnique name)
- , varType = kind
- , isCoercionVar = True
- }
-
-mkWildCoVar :: Kind -> TyVar
--- ^ Create a type variable that is never referred to, so its unique doesn't
--- matter
-mkWildCoVar = mkCoVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "co_wild"))
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Ids}
%* *
%************************************************************************
mkLocalVar details name ty info
= mk_id name ty (LocalId NotExported) details info
+mkCoVar :: Name -> Type -> CoVar
+-- Coercion variables have no IdInfo
+mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo
+
-- | Exported 'Var's will not be removed as dead code
mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id
mkExportedLocalVar details name ty info
%************************************************************************
\begin{code}
-isTyCoVar :: Var -> Bool -- True of both type and coercion variables
-isTyCoVar (TyVar {}) = True
-isTyCoVar (TcTyVar {}) = True
-isTyCoVar _ = False
-
-isTyVar :: Var -> Bool -- True of both type variables only
-isTyVar v@(TyVar {}) = not (isCoercionVar v)
+isTyVar :: Var -> Bool -- True of both type variables only
+isTyVar (TyVar {}) = True
isTyVar (TcTyVar {}) = True
isTyVar _ = False
-isCoVar :: Var -> Bool -- Only works after type checking (sigh)
-isCoVar v@(TyVar {}) = isCoercionVar v
-isCoVar _ = False
-
isTcTyVar :: Var -> Bool
isTcTyVar (TcTyVar {}) = True
isTcTyVar _ = False
\begin{code}
module VarEnv (
-- * Var, Id and TyVar environments (maps)
- VarEnv, IdEnv, TyVarEnv,
+ VarEnv, IdEnv, TyVarEnv, CoVarEnv,
-- ** Manipulating these environments
emptyVarEnv, unitVarEnv, mkVarEnv,
emptyInScopeSet, mkInScopeSet, delInScopeSet,
extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,
getInScopeVars, lookupInScope, lookupInScope_Directly,
- unionInScope, elemInScopeSet, uniqAway,
+ unionInScope, elemInScopeSet, uniqAway,
-- * The RnEnv2 type
RnEnv2,
type VarEnv elt = UniqFM elt
type IdEnv elt = VarEnv elt
type TyVarEnv elt = VarEnv elt
+type CoVarEnv elt = VarEnv elt
emptyVarEnv :: VarEnv a
mkVarEnv :: [(Var, a)] -> VarEnv a
\begin{code}
module VarSet (
-- * Var, Id and TyVar set types
- VarSet, IdSet, TyVarSet,
+ VarSet, IdSet, TyVarSet, TyCoVarSet, CoVarSet,
-- ** Manipulating these sets
emptyVarSet, unitVarSet, mkVarSet,
#include "HsVersions.h"
-import Var ( Var, TyVar, Id )
+import Var ( Var, TyVar, CoVar, TyCoVar, Id )
import Unique
import UniqSet
\end{code}
type VarSet = UniqSet Var
type IdSet = UniqSet Id
type TyVarSet = UniqSet TyVar
+type TyCoVarSet = UniqSet TyCoVar
+type CoVarSet = UniqSet CoVar
emptyVarSet :: VarSet
intersectVarSet :: VarSet -> VarSet -> VarSet
hasCAF,
infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
- isMathFun, isCas,
+ isMathFun,
isCFunctionLabel, isGcPtrLabel, labelDynamic,
pprCLabel
maybeAsmTemp _ = Nothing
--- | Check whether a label corresponds to our cas function.
--- We #include the prototype for this, so we need to avoid
--- generating out own C prototypes.
-isCas :: CLabel -> Bool
-isCas (CmmLabel pkgId fn _) = pkgId == rtsPackageId && fn == fsLit "cas"
-isCas _ = False
-
-
-- | Check whether a label corresponds to a C function that has
-- a prototype in a system header somehere, or is built-in
-- to the C compiler. For these labels we avoid generating our
pprCLabel :: CLabel -> SDoc
-#if ! OMIT_NATIVE_CODEGEN
pprCLabel (AsmTempLabel u)
+ | cGhcWithNativeCodeGen == "YES"
= getPprStyle $ \ sty ->
if asmStyle sty then
ptext asmTempLabelPrefix <> pprUnique u
char '_' <> pprUnique u
pprCLabel (DynamicLinkerLabel info lbl)
+ | cGhcWithNativeCodeGen == "YES"
= pprDynamicLinkerAsmLabel info lbl
pprCLabel PicBaseLabel
+ | cGhcWithNativeCodeGen == "YES"
= ptext (sLit "1b")
pprCLabel (DeadStripPreventer lbl)
+ | cGhcWithNativeCodeGen == "YES"
= pprCLabel lbl <> ptext (sLit "_dsp")
-#endif
-pprCLabel lbl =
-#if ! OMIT_NATIVE_CODEGEN
- getPprStyle $ \ sty ->
- if asmStyle sty then
- maybe_underscore (pprAsmCLbl lbl)
- else
-#endif
- pprCLbl lbl
+pprCLabel lbl
+ = getPprStyle $ \ sty ->
+ if cGhcWithNativeCodeGen == "YES" && asmStyle sty
+ then maybe_underscore (pprAsmCLbl lbl)
+ else pprCLbl lbl
maybe_underscore doc
| underscorePrefix = pp_cSEP <> doc
module Cmm
( CmmGraph, GenCmmGraph(..), CmmBlock
, CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop
- , CmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
+ , CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
, modifyGraph
, lastNode, replaceLastNode, insertBetween
data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
type CmmBlock = Block CmmNode C C
-type CmmReplGraph e x = FuelUniqSM (Maybe (Graph CmmNode e x))
+type CmmReplGraph e x = GenCmmReplGraph CmmNode e x
+type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x))
type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f
type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
+
module CmmCPS (
-- | Converts C-- with full proceedures and parameters
-- to a CPS transformed C-- with the stack made manifest.
global to one compiler session.
-}
+-- EZY: It might be helpful to have an easy way of dumping the "pre"
+-- input for any given phase, besides just turning it all on with
+-- -ddump-cmmz
+
cpsTop :: HscEnv -> CmmTop -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTop)])
cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
do
- -- Why bother doing it this early?
- -- g <- dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
- -- (dualLivenessWithInsertion callPPs) g
- -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
- -- g <- dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
- -- (removeDeadAssignmentsAndReloads callPPs) g
- dump Opt_D_dump_cmmz "Pre common block elimination" g
- g <- return $ elimCommonBlocks g
- dump Opt_D_dump_cmmz "Post common block elimination" g
+ -- Why bother doing these early: dualLivenessWithInsertion,
+ -- insertLateReloads, rewriteAssignments?
+ ----------- Eliminate common blocks -------------------
+ g <- return $ elimCommonBlocks g
+ dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
-- Any work storing block Labels must be performed _after_ elimCommonBlocks
----------- Proc points -------------------
let callPPs = callProcPoints g
procPoints <- run $ minimalProcPointSet callPPs g
g <- run $ addProcPointProtocols callPPs procPoints g
- dump Opt_D_dump_cmmz "Post Proc Points Added" g
+ dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
----------- Spills and reloads -------------------
- g <-
- -- pprTrace "pre Spills" (ppr g) $
- dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
- (dualLivenessWithInsertion procPoints) g
- -- Insert spills at defns; reloads at return points
- g <-
- -- pprTrace "pre insertLateReloads" (ppr g) $
- runOptimization $ insertLateReloads g -- Duplicate reloads just before uses
- dump Opt_D_dump_cmmz "Post late reloads" g
- g <-
- -- pprTrace "post insertLateReloads" (ppr g) $
- dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
- (removeDeadAssignmentsAndReloads procPoints) g
- -- Remove redundant reloads (and any other redundant asst)
-
- ----------- Debug only: add code to put zero in dead stack slots----
- -- Debugging: stubbing slots on death can cause crashes early
- g <- -- trace "post dead-assign elim" $
- if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
+ g <- run $ dualLivenessWithInsertion procPoints g
+ dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
+ ----------- Sink and inline assignments -------------------
+ g <- runOptimization $ rewriteAssignments g
+ dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
+
+ ----------- Eliminate dead assignments -------------------
+ -- Remove redundant reloads (and any other redundant asst)
+ g <- runOptimization $ removeDeadAssignmentsAndReloads procPoints g
+ dump Opt_D_dump_cmmz_dead "Post Dead Assignment Elimination" g
+
+ ----------- Zero dead stack slots (Debug only) ---------------
+ -- Debugging: stubbing slots on death can cause crashes early
+ g <- if opt_StubDeadValues
+ then run $ stubSlotsOnDeath g
+ else return g
+ dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
--------------- Stack layout ----------------
slotEnv <- run $ liveSlotAnal g
+ let spEntryMap = getSpEntryMap entry_off g
mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
- let areaMap = layout procPoints slotEnv entry_off g
+ let areaMap = layout procPoints spEntryMap slotEnv entry_off g
mbpprTrace "areaMap" (ppr areaMap) $ return ()
------------ Manifest the stack pointer --------
- g <- run $ manifestSP areaMap entry_off g
- dump Opt_D_dump_cmmz "after manifestSP" g
+ g <- run $ manifestSP spEntryMap areaMap entry_off g
+ dump Opt_D_dump_cmmz_sp "Post manifestSP" g
-- UGH... manifestSP can require updates to the procPointMap.
-- We can probably do something quicker here for the update...
------------- Split into separate procedures ------------
procPointMap <- run $ procPointAnalysis procPoints g
- dump Opt_D_dump_cmmz "procpoint map" procPointMap
+ dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
(CmmProc h l g)
- mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
+ mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
------------- More CAFs and foreign calls ------------
cafEnv <- run $ cafAnal g
mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
- mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
+ mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
-- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
- let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
- mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
- let gs'' = map (bundleCAFs cafEnv) gs'
- mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
- return (localCAFs, gs'')
+ gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
+ mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
+ gs <- return $ map (bundleCAFs cafEnv) gs
+ mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
+ return (localCAFs, gs)
where dflags = hsc_dflags hsc_env
mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
- dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
+ dump f txt g = do
+ -- ToDo: No easy way of say "dump all the cmmz, *and* split
+ -- them into files." Also, -ddump-cmmz doesn't play nicely
+ -- with -ddump-to-file, since the headers get omitted.
+ dumpIfSet_dyn dflags f txt (ppr g)
+ when (not (dopt f dflags)) $
+ dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
-- Runs a required transformation/analysis
run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
-- Runs an optional transformation/analysis (and should
-- thus be subject to optimization fuel)
runOptimization = runFuelIO (hsc_OptFuel hsc_env)
- -- pass 'run' or 'runOptimization' for 'r'
- dual_rewrite r flag txt pass g =
- do dump flag ("Pre " ++ txt) g
- g <- r $ pass g
- dump flag ("Post " ++ txt) $ g
- return g
-
-- This probably belongs in CmmBuildInfoTables?
-- We're just finishing the job here: once we know what CAFs are defined
-- in non-static closures, we can build the SRTs.
, CmmReg(..), cmmRegType
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
- , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node
+ , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
, VGcPtr(..), vgcFlag -- Temporary!
, DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
, DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed
compare _ EagerBlackholeInfo = GT
-- convenient aliases
-spReg, hpReg, spLimReg, nodeReg :: CmmReg
+baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg
+baseReg = CmmGlobal BaseReg
spReg = CmmGlobal Sp
hpReg = CmmGlobal Hp
spLimReg = CmmGlobal SpLim
checkCond :: CmmExpr -> CmmLint ()
checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
+checkCond (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth = return () -- constant values
checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
(ppr expr))
module CmmNode
( CmmNode(..)
, UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..)
- , mapExp, mapExpDeep, foldExp, foldExpDeep
+ , mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf
)
where
data CmmNode e x where
CmmEntry :: Label -> CmmNode C O
+
CmmComment :: FastString -> CmmNode O O
+
CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O -- Assign to register
+
CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O -- Assign to memory location. Size is
-- given by cmmExprType of the rhs.
+
CmmUnsafeForeignCall :: -- An unsafe foreign call; see Note [Foreign calls]
+ -- Like a "fat machine instruction"; can occur
+ -- in the middle of a block
ForeignTarget -> -- call target
CmmFormals -> -- zero or more results
CmmActuals -> -- zero or more arguments
CmmNode O O
+ -- Semantics: kills only result regs; all other regs (both GlobalReg
+ -- and LocalReg) are preserved. But there is a current
+ -- bug for what can be put in arguments, see
+ -- Note [Register Parameter Passing]
+
CmmBranch :: Label -> CmmNode O C -- Goto another block in the same procedure
+
CmmCondBranch :: { -- conditional branch
cml_pred :: CmmExpr,
cml_true, cml_false :: Label
} -> CmmNode O C
+
CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch
-- The scrutinee is zero-based;
-- zero -> first block
-- one -> second block etc
-- Undefined outside range, and when there's a Nothing
- CmmCall :: { -- A call (native or safe foreign)
+
+ CmmCall :: { -- A native call or tail call
cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
cml_cont :: Maybe Label,
-- Label of continuation (Nothing for return or tail call)
+-- ToDO: add this:
+-- cml_args_regs :: [GlobalReg],
+-- It says which GlobalRegs are live for the parameters at the
+-- moment of the call. Later stages can use this to give liveness
+-- everywhere, which in turn guides register allocation.
+-- It is the companion of cml_args; cml_args says which stack words
+-- hold parameters, while cml_arg_regs says which global regs hold parameters.
+-- But do note [Register parameter passing]
+
cml_args :: ByteOff,
-- Byte offset, from the *old* end of the Area associated with
-- the Label (if cml_cont = Nothing, then Old area), of
-- cml_ret_off are treated as live, even if the sequel of
-- the call goes into a loop.
} -> CmmNode O C
+
CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls]
+ -- Always the last node of a block
tgt :: ForeignTarget, -- call target and convention
res :: CmmFormals, -- zero or more results
- args :: CmmActuals, -- zero or more arguments
+ args :: CmmActuals, -- zero or more arguments; see Note [Register parameter passing]
succ :: Label, -- Label of continuation
updfr :: UpdFrameOffset, -- where the update frame is (for building infotable)
intrbl:: Bool -- whether or not the call is interruptible
{- Note [Foreign calls]
~~~~~~~~~~~~~~~~~~~~~~~
-A MidForeign call is used for *unsafe* foreign calls;
-a LastForeign call is used for *safe* foreign calls.
-Unsafe ones are easy: think of them as a "fat machine instruction".
-In particular, they do *not* kill all live registers (there was a bit
-of code in GHC that conservatively assumed otherwise.)
+A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
+a CmmForeignCall call is used for *safe* foreign calls.
+
+Unsafe ones are mostly easy: think of them as a "fat machine
+instruction". In particular, they do *not* kill all live registers,
+just the registers they return to (there was a bit of code in GHC that
+conservatively assumed otherwise.) However, see [Register parameter passing].
Safe ones are trickier. A safe foreign call
r = f(x)
Note that a safe foreign call needs an info table.
-}
+{- Note [Register parameter passing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On certain architectures, some registers are utilized for parameter
+passing in the C calling convention. For example, in x86-64 Linux
+convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
+argument passing. These are registers R3-R6, which our generated
+code may also be using; as a result, it's necessary to save these
+values before doing a foreign call. This is done during initial
+code generation in callerSaveVolatileRegs in StgCmmUtils.hs. However,
+one result of doing this is that the contents of these registers
+may mysteriously change if referenced inside the arguments. This
+is dangerous, so you'll need to disable inlining much in the same
+way is done in cmm/CmmOpt.hs currently. We should fix this!
+-}
+
---------------------------------------------
-- Eq instance of CmmNode
-- It is a shame GHC cannot infer it by itself :(
-----------------------------------------------------------------------------
module CmmOpt (
+ cmmEliminateDeadBlocks,
cmmMiniInline,
cmmMachOpFold,
cmmLoopifyForC,
import Unique
import FastTypes
import Outputable
+import BlockId
import Data.Bits
import Data.Word
import Data.Int
+import Data.Maybe
+import Data.List
+
+import Compiler.Hoopl hiding (Unique)
+
+-- -----------------------------------------------------------------------------
+-- Eliminates dead blocks
+
+{-
+We repeatedly expand the set of reachable blocks until we hit a
+fixpoint, and then prune any blocks that were not in this set. This is
+actually a required optimization, as dead blocks can cause problems
+for invariants in the linear register allocator (and possibly other
+places.)
+-}
+
+-- Deep fold over statements could probably be abstracted out, but it
+-- might not be worth the effort since OldCmm is moribund
+cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock]
+cmmEliminateDeadBlocks [] = []
+cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) =
+ let -- Calculate what's reachable from what block
+ reachableMap = foldl' f emptyUFM blocks -- lazy in values
+ where f m (BasicBlock block_id stmts) = addToUFM m block_id (reachableFrom stmts)
+ reachableFrom stmts = foldl stmt [] stmts
+ where
+ stmt m CmmNop = m
+ stmt m (CmmComment _) = m
+ stmt m (CmmAssign _ e) = expr m e
+ stmt m (CmmStore e1 e2) = expr (expr m e1) e2
+ stmt m (CmmCall c _ as _ _) = f (actuals m as) c
+ where f m (CmmCallee e _) = expr m e
+ f m (CmmPrim _) = m
+ stmt m (CmmBranch b) = b:m
+ stmt m (CmmCondBranch e b) = b:(expr m e)
+ stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e
+ stmt m (CmmJump e as) = expr (actuals m as) e
+ stmt m (CmmReturn as) = actuals m as
+ actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as
+ -- We have to do a deep fold into CmmExpr because
+ -- there may be a BlockId in the CmmBlock literal.
+ expr m (CmmLit l) = lit m l
+ expr m (CmmLoad e _) = expr m e
+ expr m (CmmReg _) = m
+ expr m (CmmMachOp _ es) = foldl' expr m es
+ expr m (CmmStackSlot _ _) = m
+ expr m (CmmRegOff _ _) = m
+ lit m (CmmBlock b) = b:m
+ lit m _ = m
+ -- go todo done
+ reachable = go [base_id] (setEmpty :: BlockSet)
+ where go [] m = m
+ go (x:xs) m
+ | setMember x m = go xs m
+ | otherwise = go (add ++ xs) (setInsert x m)
+ where add = fromMaybe (panic "cmmEliminateDeadBlocks: unknown block")
+ (lookupUFM reachableMap x)
+ in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks
-- -----------------------------------------------------------------------------
-- The mini-inliner
| NAME '(' exprs0 ')' ';'
{% stmtMacro $1 $3 }
| 'switch' maybe_range expr '{' arms default '}'
- { doSwitch $2 $3 $5 $6 }
+ { do as <- sequence $5; doSwitch $2 $3 as $6 }
| 'goto' NAME ';'
{ do l <- lookupLabel $2; stmtEC (CmmBranch l) }
| 'jump' expr maybe_actuals ';'
{ do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
| 'return' maybe_actuals ';'
{ do e <- sequence $2; stmtEC (CmmReturn e) }
+ | 'if' bool_expr 'goto' NAME
+ { do l <- lookupLabel $4; cmmRawIf $2 l }
| 'if' bool_expr '{' body '}' else
{ cmmIfThenElse $2 $4 $6 }
: '[' INT '..' INT ']' { Just (fromIntegral $2, fromIntegral $4) }
| {- empty -} { Nothing }
-arms :: { [([Int],ExtCode)] }
+arms :: { [ExtFCode ([Int],Either BlockId ExtCode)] }
: {- empty -} { [] }
| arm arms { $1 : $2 }
-arm :: { ([Int],ExtCode) }
- : 'case' ints ':' '{' body '}' { ($2, $5) }
+arm :: { ExtFCode ([Int],Either BlockId ExtCode) }
+ : 'case' ints ':' arm_body { do b <- $4; return ($2, b) }
+
+arm_body :: { ExtFCode (Either BlockId ExtCode) }
+ : '{' body '}' { return (Right $2) }
+ | 'goto' NAME ';' { do l <- lookupLabel $2; return (Left l) }
ints :: { [Int] }
: INT { [ fromIntegral $1 ] }
-- 'default' branches
| {- empty -} { Nothing }
+-- Note: OldCmm doesn't support a first class 'else' statement, though
+-- CmmNode does.
else :: { ExtCode }
: {- empty -} { nopEC }
| 'else' '{' body '}' { $3 }
( "gtu", MO_U_Gt ),
( "ltu", MO_U_Lt ),
- ( "flt", MO_S_Lt ),
- ( "fle", MO_S_Le ),
- ( "feq", MO_Eq ),
- ( "fne", MO_Ne ),
- ( "fgt", MO_S_Gt ),
- ( "fge", MO_S_Ge ),
- ( "fneg", MO_S_Neg ),
-
- ( "and", MO_And ),
+ ( "and", MO_And ),
( "or", MO_Or ),
( "xor", MO_Xor ),
( "com", MO_Not ),
( "shrl", MO_U_Shr ),
( "shra", MO_S_Shr ),
- ( "lobits8", flip MO_UU_Conv W8 ),
+ ( "fadd", MO_F_Add ),
+ ( "fsub", MO_F_Sub ),
+ ( "fneg", MO_F_Neg ),
+ ( "fmul", MO_F_Mul ),
+ ( "fquot", MO_F_Quot ),
+
+ ( "feq", MO_F_Eq ),
+ ( "fne", MO_F_Ne ),
+ ( "fge", MO_F_Ge ),
+ ( "fle", MO_F_Le ),
+ ( "fgt", MO_F_Gt ),
+ ( "flt", MO_F_Lt ),
+
+ ( "lobits8", flip MO_UU_Conv W8 ),
( "lobits16", flip MO_UU_Conv W16 ),
( "lobits32", flip MO_UU_Conv W32 ),
( "lobits64", flip MO_UU_Conv W64 ),
-- fall through to join
code (labelC join_id)
+cmmRawIf cond then_id = do
+ c <- cond
+ emitCond c then_id
+
-- 'emitCond cond true_id' emits code to test whether the cond is true,
-- branching to true_id if so, and falling through otherwise.
emitCond (BoolTest e) then_id = do
-- optional range on the switch (eg. switch [0..7] {...}), or by
-- the minimum/maximum values from the branches.
-doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
+doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],Either BlockId ExtCode)]
-> Maybe ExtCode -> ExtCode
doSwitch mb_range scrut arms deflt
= do
-- ToDo: check for out of range and jump to default if necessary
stmtEC (CmmSwitch expr entries)
where
- emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
- emitArm (ints,code) = do
+ emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
+ emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
+ emitArm (ints,Right code) = do
blockid <- forkLabelledCodeEC code
return [ (i,blockid) | i <- ints ]
-
-- -----------------------------------------------------------------------------
-- Putting it all together
-- 4. build info tables for the procedures -- and update the info table for
-- the SRTs in the entry procedure as well.
-- Input invariant: A block should only be reachable from a single ProcPoint.
+-- ToDo: use the _ret naming convention that the old code generator
+-- used. -- EZY
splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
CmmTop -> FuelUniqSM [CmmTop]
splitAtProcPoints entry_label callPPs procPoints procMap
-{-# LANGUAGE GADTs,NoMonoLocalBinds #-}
+{-# LANGUAGE GADTs, NoMonoLocalBinds, FlexibleContexts, ViewPatterns #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
#if __GLASGOW_HASKELL__ >= 701
-- GHC 7.0.1 improved incomplete pattern warnings with GADTs
--, insertSpillsAndReloads --- XXX todo check live-in at entry against formals
, dualLivenessWithInsertion
- , availRegsLattice
- , cmmAvailableReloads
- , insertLateReloads
+ , rewriteAssignments
, removeDeadAssignmentsAndReloads
)
where
import CmmExpr
import CmmLive
import OptimizationFuel
+import StgCmmUtils
import Control.Monad
import Outputable hiding (empty)
import qualified Outputable as PP
import UniqSet
+import UniqFM
+import Unique
-import Compiler.Hoopl
+import Compiler.Hoopl hiding (Unique)
import Data.Maybe
import Prelude hiding (succ, zip)
text "after"{-, ppr m-}]) $
Just $ mkMiddles $ [m, spill reg]
else Nothing
- middle m@(CmmUnsafeForeignCall _ fs _) live = return $
- case map spill (filter (flip elemRegSet (on_stack live)) fs) ++
- map reload (uniqSetToList (kill fs (in_regs live))) of
- [] -> Nothing
- reloads -> Just $ mkMiddles (m : reloads)
middle _ _ = return Nothing
nothing _ _ = return Nothing
spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
-----------------------------------------------------------------
---- sinking reloads
-
--- The idea is to compute at each point the set of registers such that
--- on every path to the point, the register is defined by a Reload
--- instruction. Then, if a use appears at such a point, we can safely
--- insert a Reload right before the use. Finally, we can eliminate
--- the early reloads along with other dead assignments.
-
-data AvailRegs = UniverseMinus RegSet
- | AvailRegs RegSet
-
-
-availRegsLattice :: DataflowLattice AvailRegs
-availRegsLattice = DataflowLattice "register gotten from reloads" empty add
- where empty = UniverseMinus emptyRegSet
- -- | compute in the Tx monad to track whether anything has changed
- add _ (OldFact old) (NewFact new) =
- if join `smallerAvail` old then (SomeChange, join) else (NoChange, old)
- where join = interAvail new old
-
-
-interAvail :: AvailRegs -> AvailRegs -> AvailRegs
-interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet` s')
-interAvail (AvailRegs s) (AvailRegs s') = AvailRegs (s `timesRegSet` s')
-interAvail (AvailRegs s) (UniverseMinus s') = AvailRegs (s `minusRegSet` s')
-interAvail (UniverseMinus s) (AvailRegs s') = AvailRegs (s' `minusRegSet` s )
-
-smallerAvail :: AvailRegs -> AvailRegs -> Bool
-smallerAvail (AvailRegs _) (UniverseMinus _) = True
-smallerAvail (UniverseMinus _) (AvailRegs _) = False
-smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s'
-smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s'
-
-extendAvail :: AvailRegs -> LocalReg -> AvailRegs
-extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r)
-extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r)
-
-delFromAvail :: AvailRegs -> LocalReg -> AvailRegs
-delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r)
-delFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r)
-
-elemAvail :: AvailRegs -> LocalReg -> Bool
-elemAvail (UniverseMinus s) r = not $ elemRegSet r s
-elemAvail (AvailRegs s) r = elemRegSet r s
-
-cmmAvailableReloads :: CmmGraph -> FuelUniqSM (BlockEnv AvailRegs)
-cmmAvailableReloads g =
- liftM snd $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
- analFwd availRegsLattice availReloadsTransfer
-
-availReloadsTransfer :: FwdTransfer CmmNode AvailRegs
-availReloadsTransfer = mkFTransfer3 (flip const) middleAvail ((mkFactBase availRegsLattice .) . lastAvail)
-
-middleAvail :: CmmNode O O -> AvailRegs -> AvailRegs
-middleAvail (CmmAssign (CmmLocal r) (CmmLoad l _)) avail
- | l `isStackSlotOf` r = extendAvail avail r
-middleAvail (CmmAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs
-middleAvail (CmmStore l (CmmReg (CmmLocal r))) avail
- | l `isStackSlotOf` r = avail
-middleAvail (CmmStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
-middleAvail (CmmStore {}) avail = avail
-middleAvail (CmmUnsafeForeignCall {}) _ = AvailRegs emptyRegSet
-middleAvail (CmmComment {}) avail = avail
-
-lastAvail :: CmmNode O C -> AvailRegs -> [(Label, AvailRegs)]
-lastAvail (CmmCall _ (Just k) _ _ _) _ = [(k, AvailRegs emptyRegSet)]
-lastAvail (CmmForeignCall {succ=k}) _ = [(k, AvailRegs emptyRegSet)]
-lastAvail l avail = map (\id -> (id, avail)) $ successors l
-
-insertLateReloads :: CmmGraph -> FuelUniqSM CmmGraph
-insertLateReloads g =
- liftM fst $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
- analRewFwd availRegsLattice availReloadsTransfer rewrites
- where rewrites = mkFRewrite3 first middle last
- first _ _ = return Nothing
- middle m avail = return $ maybe_reload_before avail m (mkMiddle m)
- last l avail = return $ maybe_reload_before avail l (mkLast l)
- maybe_reload_before avail node tail =
- let used = filterRegsUsed (elemAvail avail) node
- in if isEmptyUniqSet used then Nothing
- else Just $ reloadTail used tail
- reloadTail regset t = foldl rel t $ uniqSetToList regset
- where rel t r = mkMiddle (reload r) <*> t
-
removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
removeDeadAssignmentsAndReloads procPoints g =
liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
-- but GHC panics while compiling, see bug #4045.
middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
+ -- XXX maybe this should be somewhere else...
+ middle (CmmAssign lhs (CmmReg rhs)) _ | lhs == rhs = return $ Just emptyGraph
+ middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph
middle _ _ = return Nothing
nothing _ _ = return Nothing
+----------------------------------------------------------------
+--- Usage information
+
+-- We decorate all register assignments with usage information,
+-- that is, the maximum number of times the register is referenced
+-- while it is live along all outgoing control paths. There are a few
+-- subtleties here:
+--
+-- - If a register goes dead, and then becomes live again, the usages
+-- of the disjoint live range don't count towards the original range.
+--
+-- a = 1; // used once
+-- b = a;
+-- a = 2; // used once
+-- c = a;
+--
+-- - A register may be used multiple times, but these all reside in
+-- different control paths, such that any given execution only uses
+-- it once. In that case, the usage count may still be 1.
+--
+-- a = 1; // used once
+-- if (b) {
+-- c = a + 3;
+-- } else {
+-- c = a + 1;
+-- }
+--
+-- This policy corresponds to an inlining strategy that does not
+-- duplicate computation but may increase binary size.
+--
+-- - If we naively implement a usage count, we have a counting to
+-- infinity problem across joins. Furthermore, knowing that
+-- something is used 2 or more times in one runtime execution isn't
+-- particularly useful for optimizations (inlining may be beneficial,
+-- but there's no way of knowing that without register pressure
+-- information.)
+--
+-- while (...) {
+-- // first iteration, b used once
+-- // second iteration, b used twice
+-- // third iteration ...
+-- a = b;
+-- }
+-- // b used zero times
+--
+-- There is an orthogonal question, which is that for every runtime
+-- execution, the register may be used only once, but if we inline it
+-- in every conditional path, the binary size might increase a lot.
+-- But tracking this information would be tricky, because it violates
+-- the finite lattice restriction Hoopl requires for termination;
+-- we'd thus need to supply an alternate proof, which is probably
+-- something we should defer until we actually have an optimization
+-- that would take advantage of this. (This might also interact
+-- strangely with liveness information.)
+--
+-- a = ...;
+-- // a is used one time, but in X different paths
+-- case (b) of
+-- 1 -> ... a ...
+-- 2 -> ... a ...
+-- 3 -> ... a ...
+-- ...
+--
+-- This analysis is very similar to liveness analysis; we just keep a
+-- little extra info. (Maybe we should move it to CmmLive, and subsume
+-- the old liveness analysis.)
+
+data RegUsage = SingleUse | ManyUse
+ deriving (Ord, Eq, Show)
+-- Absence in map = ZeroUse
+
+{-
+-- minBound is bottom, maxBound is top, least-upper-bound is max
+-- ToDo: Put this in Hoopl. Note that this isn't as useful as I
+-- originally hoped, because you usually want to leave out the bottom
+-- element when you have things like this put in maps. Maybe f is
+-- useful on its own as a combining function.
+boundedOrdLattice :: (Bounded a, Ord a) => String -> DataflowLattice a
+boundedOrdLattice n = DataflowLattice n minBound f
+ where f _ (OldFact x) (NewFact y)
+ | x >= y = (NoChange, x)
+ | otherwise = (SomeChange, y)
+-}
+
+-- Custom node type we'll rewrite to. CmmAssign nodes to local
+-- registers are replaced with AssignLocal nodes.
+data WithRegUsage n e x where
+ Plain :: n e x -> WithRegUsage n e x
+ AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O
+
+instance UserOfLocalRegs (n e x) => UserOfLocalRegs (WithRegUsage n e x) where
+ foldRegsUsed f z (Plain n) = foldRegsUsed f z n
+ foldRegsUsed f z (AssignLocal _ e _) = foldRegsUsed f z e
+
+instance DefinerOfLocalRegs (n e x) => DefinerOfLocalRegs (WithRegUsage n e x) where
+ foldRegsDefd f z (Plain n) = foldRegsDefd f z n
+ foldRegsDefd f z (AssignLocal r _ _) = foldRegsDefd f z r
+
+instance NonLocal n => NonLocal (WithRegUsage n) where
+ entryLabel (Plain n) = entryLabel n
+ successors (Plain n) = successors n
+
+liftRegUsage :: Graph n e x -> Graph (WithRegUsage n) e x
+liftRegUsage = mapGraph Plain
+
+eraseRegUsage :: Graph (WithRegUsage CmmNode) e x -> Graph CmmNode e x
+eraseRegUsage = mapGraph f
+ where f :: WithRegUsage CmmNode e x -> CmmNode e x
+ f (AssignLocal l e _) = CmmAssign (CmmLocal l) e
+ f (Plain n) = n
+
+type UsageMap = UniqFM RegUsage
+
+usageLattice :: DataflowLattice UsageMap
+usageLattice = DataflowLattice "usage counts for registers" emptyUFM (joinUFM f)
+ where f _ (OldFact x) (NewFact y)
+ | x >= y = (NoChange, x)
+ | otherwise = (SomeChange, y)
+
+-- We reuse the names 'gen' and 'kill', although we're doing something
+-- slightly different from the Dragon Book
+usageTransfer :: BwdTransfer (WithRegUsage CmmNode) UsageMap
+usageTransfer = mkBTransfer3 first middle last
+ where first _ f = f
+ middle :: WithRegUsage CmmNode O O -> UsageMap -> UsageMap
+ middle n f = gen_kill n f
+ last :: WithRegUsage CmmNode O C -> FactBase UsageMap -> UsageMap
+ -- Checking for CmmCall/CmmForeignCall is unnecessary, because
+ -- spills/reloads have already occurred by the time we do this
+ -- analysis.
+ -- XXX Deprecated warning is puzzling: what label are we
+ -- supposed to use?
+ -- ToDo: With a bit more cleverness here, we can avoid
+ -- disappointment and heartbreak associated with the inability
+ -- to inline into CmmCall and CmmForeignCall by
+ -- over-estimating the usage to be ManyUse.
+ last n f = gen_kill n (joinOutFacts usageLattice n f)
+ gen_kill a = gen a . kill a
+ gen a f = foldRegsUsed increaseUsage f a
+ kill a f = foldRegsDefd delFromUFM f a
+ increaseUsage f r = addToUFM_C combine f r SingleUse
+ where combine _ _ = ManyUse
+
+usageRewrite :: BwdRewrite FuelUniqSM (WithRegUsage CmmNode) UsageMap
+usageRewrite = mkBRewrite3 first middle last
+ where first _ _ = return Nothing
+ middle :: Monad m => WithRegUsage CmmNode O O -> UsageMap -> m (Maybe (Graph (WithRegUsage CmmNode) O O))
+ middle (Plain (CmmAssign (CmmLocal l) e)) f
+ = return . Just
+ $ case lookupUFM f l of
+ Nothing -> emptyGraph
+ Just usage -> mkMiddle (AssignLocal l e usage)
+ middle _ _ = return Nothing
+ last _ _ = return Nothing
+
+type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode)
+annotateUsage :: CmmGraph -> FuelUniqSM (CmmGraphWithRegUsage)
+annotateUsage vanilla_g =
+ let g = modifyGraph liftRegUsage vanilla_g
+ in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $
+ analRewBwd usageLattice usageTransfer usageRewrite
+
+----------------------------------------------------------------
+--- Assignment tracking
+
+-- The idea is to maintain a map of local registers do expressions,
+-- such that the value of that register is the same as the value of that
+-- expression at any given time. We can then do several things,
+-- as described by Assignment.
+
+-- Assignment describes the various optimizations that are valid
+-- at a given point in the program.
+data Assignment =
+-- This assignment can always be inlined. It is cheap or single-use.
+ AlwaysInline CmmExpr
+-- This assignment should be sunk down to its first use. (This will
+-- increase code size if the register is used in multiple control flow
+-- paths, but won't increase execution time, and the reduction of
+-- register pressure is worth it.)
+ | AlwaysSink CmmExpr
+-- We cannot safely optimize occurrences of this local register. (This
+-- corresponds to top in the lattice structure.)
+ | NeverOptimize
+
+-- Extract the expression that is being assigned to
+xassign :: Assignment -> Maybe CmmExpr
+xassign (AlwaysInline e) = Just e
+xassign (AlwaysSink e) = Just e
+xassign NeverOptimize = Nothing
+
+-- Extracts the expression, but only if they're the same constructor
+xassign2 :: (Assignment, Assignment) -> Maybe (CmmExpr, CmmExpr)
+xassign2 (AlwaysInline e, AlwaysInline e') = Just (e, e')
+xassign2 (AlwaysSink e, AlwaysSink e') = Just (e, e')
+xassign2 _ = Nothing
+
+-- Note: We'd like to make decisions about "not optimizing" as soon as
+-- possible, because this will make running the transfer function more
+-- efficient.
+type AssignmentMap = UniqFM Assignment
+
+assignmentLattice :: DataflowLattice AssignmentMap
+assignmentLattice = DataflowLattice "assignments for registers" emptyUFM (joinUFM add)
+ where add _ (OldFact old) (NewFact new)
+ = case (old, new) of
+ (NeverOptimize, _) -> (NoChange, NeverOptimize)
+ (_, NeverOptimize) -> (SomeChange, NeverOptimize)
+ (xassign2 -> Just (e, e'))
+ | e == e' -> (NoChange, old)
+ | otherwise -> (SomeChange, NeverOptimize)
+ _ -> (SomeChange, NeverOptimize)
+
+-- Deletes sinks from assignment map, because /this/ is the place
+-- where it will be sunk to.
+deleteSinks :: UserOfLocalRegs n => n -> AssignmentMap -> AssignmentMap
+deleteSinks n m = foldRegsUsed (adjustUFM f) m n
+ where f (AlwaysSink _) = NeverOptimize
+ f old = old
+
+-- Invalidates any expressions that use a register.
+invalidateUsersOf :: CmmReg -> AssignmentMap -> AssignmentMap
+-- foldUFM_Directly :: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
+invalidateUsersOf reg m = foldUFM_Directly f m m -- [foldUFM performance]
+ where f u (xassign -> Just e) m | reg `regUsedIn` e = addToUFM_Directly m u NeverOptimize
+ f _ _ m = m
+{- This requires the entire spine of the map to be continually rebuilt,
+ - which causes crazy memory usage!
+invalidateUsersOf reg = mapUFM (invalidateUsers' reg)
+ where invalidateUsers' reg (xassign -> Just e) | reg `regUsedIn` e = NeverOptimize
+ invalidateUsers' _ old = old
+-}
+
+-- Note [foldUFM performance]
+-- These calls to fold UFM no longer leak memory, but they do cause
+-- pretty killer amounts of allocation. So they'll be something to
+-- optimize; we need an algorithmic change to prevent us from having to
+-- traverse the /entire/ map continually.
+
+middleAssignment :: WithRegUsage CmmNode O O -> AssignmentMap -> AssignmentMap
+
+-- Algorithm for annotated assignments:
+-- 1. Delete any sinking assignments that were used by this instruction
+-- 2. Add the assignment to our list of valid local assignments with
+-- the correct optimization policy.
+-- 3. Look for all assignments that reference that register and
+-- invalidate them.
+middleAssignment n@(AssignLocal r e usage) assign
+ = invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign
+ where add m = addToUFM m r
+ $ case usage of
+ SingleUse -> AlwaysInline e
+ ManyUse -> decide e
+ decide CmmLit{} = AlwaysInline e
+ decide CmmReg{} = AlwaysInline e
+ decide CmmLoad{} = AlwaysSink e
+ decide CmmStackSlot{} = AlwaysSink e
+ decide CmmMachOp{} = AlwaysSink e
+ -- We'll always inline simple operations on the global
+ -- registers, to reduce register pressure: Sp - 4 or Hp - 8
+ -- EZY: Justify this optimization more carefully.
+ decide CmmRegOff{} = AlwaysInline e
+
+-- Algorithm for unannotated assignments of global registers:
+-- 1. Delete any sinking assignments that were used by this instruction
+-- 2. Look for all assignments that reference this register and
+-- invalidate them.
+middleAssignment (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign
+ = invalidateUsersOf reg . deleteSinks n $ assign
+
+-- Algorithm for unannotated assignments of *local* registers: do
+-- nothing (it's a reload, so no state should have changed)
+middleAssignment (Plain (CmmAssign (CmmLocal _) _)) assign = assign
+
+-- Algorithm for stores:
+-- 1. Delete any sinking assignments that were used by this instruction
+-- 2. Look for all assignments that load from memory locations that
+-- were clobbered by this store and invalidate them.
+middleAssignment (Plain n@(CmmStore lhs rhs)) assign
+ = let m = deleteSinks n assign
+ in foldUFM_Directly f m m -- [foldUFM performance]
+ where f u (xassign -> Just x) m | (lhs, rhs) `clobbers` (u, x) = addToUFM_Directly m u NeverOptimize
+ f _ _ m = m
+{- Also leaky
+ = mapUFM_Directly p . deleteSinks n $ assign
+ -- ToDo: There's a missed opportunity here: even if a memory
+ -- access we're attempting to sink gets clobbered at some
+ -- location, it's still /better/ to sink it to right before the
+ -- point where it gets clobbered. How might we do this?
+ -- Unfortunately, it's too late to change the assignment...
+ where p r (xassign -> Just x) | (lhs, rhs) `clobbers` (r, x) = NeverOptimize
+ p _ old = old
+-}
+
+-- Assumption: Unsafe foreign calls don't clobber memory
+-- Since foreign calls clobber caller saved registers, we need
+-- invalidate any assignments that reference those global registers.
+-- This is kind of expensive. (One way to optimize this might be to
+-- store extra information about expressions that allow this and other
+-- checks to be done cheaply.)
+middleAssignment (Plain n@(CmmUnsafeForeignCall{})) assign
+ = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n)
+ where deleteCallerSaves m = foldUFM_Directly f m m
+ f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize
+ f _ _ m = m
+ g (CmmReg (CmmGlobal r)) _ | callerSaves r = True
+ g (CmmRegOff (CmmGlobal r) _) _ | callerSaves r = True
+ g _ b = b
+
+middleAssignment (Plain (CmmComment {})) assign
+ = assign
+
+-- Assumptions:
+-- * Writes using Hp do not overlap with any other memory locations
+-- (An important invariant being relied on here is that we only ever
+-- use Hp to allocate values on the heap, which appears to be the
+-- case given hpReg usage, and that our heap writing code doesn't
+-- do anything stupid like overlapping writes.)
+-- * Stack slots do not overlap with any other memory locations
+-- * Stack slots for different areas do not overlap
+-- * Stack slots within the same area and different offsets may
+-- overlap; we need to do a size check (see 'overlaps').
+-- * Register slots only overlap with themselves. (But this shouldn't
+-- happen in practice, because we'll fail to inline a reload across
+-- the next spill.)
+-- * Non stack-slot stores always conflict with each other. (This is
+-- not always the case; we could probably do something special for Hp)
+clobbers :: (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore
+ -> (Unique, CmmExpr) -- (register, expression) that may be clobbered
+ -> Bool
+clobbers (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False
+clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False
+-- ToDo: Also catch MachOp case
+clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _)
+ | getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?)
+clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr
+ where f (CmmLoad (CmmStackSlot (CallArea a') o') t)
+ = (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t))
+ f (CmmLoad e _) = containsStackSlot e
+ f (CmmMachOp _ es) = or (map f es)
+ f _ = False
+ -- Maybe there's an invariant broken if this actually ever
+ -- returns True
+ containsStackSlot (CmmLoad{}) = True -- load of a load, all bets off
+ containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es)
+ containsStackSlot (CmmStackSlot{}) = True
+ containsStackSlot _ = False
+clobbers (CmmStackSlot (RegSlot l) _, _) (_, expr) = f expr
+ where f (CmmLoad (CmmStackSlot (RegSlot l') _) _) = l == l'
+ f _ = False
+clobbers _ (_, e) = f e
+ where f (CmmLoad (CmmStackSlot _ _) _) = False
+ f (CmmLoad{}) = True -- conservative
+ f (CmmMachOp _ es) = or (map f es)
+ f _ = False
+
+-- Check for memory overlapping.
+-- Diagram:
+-- 4 8 12
+-- s -w- o
+-- [ I32 ]
+-- [ F64 ]
+-- s' -w'- o'
+type CallSubArea = (AreaId, Int, Int) -- area, offset, width
+overlaps :: CallSubArea -> CallSubArea -> Bool
+overlaps (a, _, _) (a', _, _) | a /= a' = False
+overlaps (_, o, w) (_, o', w') =
+ let s = o - w
+ s' = o' - w'
+ in (s' < o) && (s < o) -- Not LTE, because [ I32 ][ I32 ] is OK
+
+lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)]
+-- Variables are dead across calls, so invalidating all mappings is justified
+lastAssignment (Plain (CmmCall _ (Just k) _ _ _)) assign = [(k, mapUFM (const NeverOptimize) assign)]
+lastAssignment (Plain (CmmForeignCall {succ=k})) assign = [(k, mapUFM (const NeverOptimize) assign)]
+lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l
+
+assignmentTransfer :: FwdTransfer (WithRegUsage CmmNode) AssignmentMap
+assignmentTransfer = mkFTransfer3 (flip const) middleAssignment ((mkFactBase assignmentLattice .) . lastAssignment)
+
+assignmentRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) AssignmentMap
+assignmentRewrite = mkFRewrite3 first middle last
+ where
+ first _ _ = return Nothing
+ middle :: WithRegUsage CmmNode O O -> AssignmentMap -> GenCmmReplGraph (WithRegUsage CmmNode) O O
+ middle (Plain m) assign = return $ rewrite assign (precompute assign m) mkMiddle m
+ middle (AssignLocal l e u) assign = return $ rewriteLocal assign (precompute assign (CmmAssign (CmmLocal l) e)) mkMiddle l e u
+ last (Plain l) assign = return $ rewrite assign (precompute assign l) mkLast l
+ -- Tuple is (inline?, reloads)
+ precompute assign n = foldRegsUsed f (False, []) n -- duplicates are harmless
+ where f (i, l) r = case lookupUFM assign r of
+ Just (AlwaysSink e) -> (i, (Plain (CmmAssign (CmmLocal r) e)):l)
+ Just (AlwaysInline _) -> (True, l)
+ Just NeverOptimize -> (i, l)
+ -- This case can show up when we have
+ -- limited optimization fuel.
+ Nothing -> (i, l)
+ rewrite _ (False, []) _ _ = Nothing
+ -- Note [CmmCall Inline Hack]
+ -- Conservative hack: don't do any inlining on what will
+ -- be translated into an OldCmm CmmCalls, since the code
+ -- produced here tends to be unproblematic and I need to write
+ -- lint passes to ensure that we don't put anything in the
+ -- arguments that could be construed as a global register by
+ -- some later translation pass. (For example, slots will turn
+ -- into dereferences of Sp). See [Register parameter passing].
+ -- ToDo: Fix this up to only bug out if all inlines were for
+ -- CmmExprs with global registers (we can't use the
+ -- straightforward mapExpDeep call, in this case.) ToDo: We miss
+ -- an opportunity here, where all possible inlinings should
+ -- instead be sunk.
+ rewrite _ (True, []) _ n | not (inlinable n) = Nothing -- see [CmmCall Inline Hack]
+ rewrite assign (i, xs) mk n = Just $ mkMiddles xs <*> mk (Plain (inline i assign n))
+
+ rewriteLocal _ (False, []) _ _ _ _ = Nothing
+ rewriteLocal assign (i, xs) mk l e u = Just $ mkMiddles xs <*> mk n'
+ where n' = AssignLocal l e' u
+ e' = if i then wrapRecExp (inlineExp assign) e else e
+ -- inlinable check omitted, since we can always inline into
+ -- assignments.
+
+ inline :: Bool -> AssignmentMap -> CmmNode e x -> CmmNode e x
+ inline False _ n = n
+ inline True _ n | not (inlinable n) = n -- see [CmmCall Inline Hack]
+ inline True assign n = mapExpDeep (inlineExp assign) n
+
+ inlineExp assign old@(CmmReg (CmmLocal r))
+ = case lookupUFM assign r of
+ Just (AlwaysInline x) -> x
+ _ -> old
+ inlineExp assign old@(CmmRegOff (CmmLocal r) i)
+ = case lookupUFM assign r of
+ Just (AlwaysInline x) ->
+ case x of
+ (CmmRegOff r' i') -> CmmRegOff r' (i + i')
+ _ -> CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
+ where rep = typeWidth (localRegType r)
+ _ -> old
+ inlineExp _ old = old
+
+ inlinable :: CmmNode e x -> Bool
+ inlinable (CmmCall{}) = False
+ inlinable (CmmForeignCall{}) = False
+ inlinable (CmmUnsafeForeignCall{}) = False
+ inlinable _ = True
+
+rewriteAssignments :: CmmGraph -> FuelUniqSM CmmGraph
+rewriteAssignments g = do
+ g' <- annotateUsage g
+ g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $
+ analRewFwd assignmentLattice assignmentTransfer assignmentRewrite
+ return (modifyGraph eraseRegUsage g'')
---------------------
-- prettyprinting
if isEmptyUniqSet stack then PP.empty
else (ppr_regs "live on stack =" stack)]
-instance Outputable AvailRegs where
- ppr (UniverseMinus s) = if isEmptyUniqSet s then text "<everything available>"
- else ppr_regs "available = all but" s
- ppr (AvailRegs s) = if isEmptyUniqSet s then text "<nothing available>"
- else ppr_regs "available = " s
+-- ToDo: Outputable instance for UsageMap and AssignmentMap
my_trace :: String -> SDoc -> a -> a
my_trace = if False then pprTrace else \_ _ a -> a
module CmmStackLayout
( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
- , layout, manifestSP, igraph, areaBuilder
+ , getSpEntryMap, layout, manifestSP, igraph, areaBuilder
, stubSlotsOnDeath ) -- to help crash early during debugging
where
type Set x = Map x ()
data IGraphBuilder n =
Builder { foldNodes :: forall z. SubArea -> (n -> z -> z) -> z -> z
- , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int]
+ , _wordsOccupied :: AreaSizeMap -> AreaMap -> n -> [Int]
}
areaBuilder :: IGraphBuilder Area
-- what's the highest offset (in bytes) used in each Area?
-- We'll need to allocate that much space for each Area.
+-- Mapping of areas to area sizes (not offsets!)
+type AreaSizeMap = AreaMap
+
-- JD: WHY CAN'T THIS COME FROM THE slot-liveness info?
-getAreaSize :: ByteOff -> CmmGraph -> AreaMap
+getAreaSize :: ByteOff -> CmmGraph -> AreaSizeMap
-- The domain of the returned mapping consists only of Areas
- -- used for (a) variable spill slots, and (b) parameter passing ares for calls
+ -- used for (a) variable spill slots, and (b) parameter passing areas for calls
getAreaSize entry_off g =
foldGraphBlocks (foldBlockNodesF3 (first, add_regslots, last))
(Map.singleton (CallArea Old) entry_off) g
-- The 'max' is important. Two calls, to f and g, might share a common
-- continuation (and hence a common CallArea), but their number of overflow
-- parameters might differ.
+ -- EZY: Ought to use insert with combining function...
-- Find the Stack slots occupied by the subarea's conflicts
-conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int
+conflictSlots :: Ord x => IGPair x -> AreaSizeMap -> AreaMap -> SubArea -> Set Int
conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea =
foldNodes subarea foldNode Map.empty
where foldNode n set = Map.foldRightWithKey conflict set $ Map.findWithDefault Map.empty n ig
liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n)
setAdd w s = Map.insert w () s
--- Find any open space on the stack, starting from the offset.
--- If the area is a CallArea or a spill slot for a pointer, then it must
--- be word-aligned.
-freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int
+-- Find any open space for 'area' on the stack, starting from the
+-- 'offset'. If the area is a CallArea or a spill slot for a pointer,
+-- then it must be word-aligned.
+freeSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> Int
freeSlotFrom ig areaSize offset areaMap area =
let size = Map.lookup area areaSize `orElse` 0
conflicts = conflictSlots ig areaSize areaMap (area, size, size)
in findSpace (align (offset + size)) size
-- Find an open space on the stack, and assign it to the area.
-allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap
+allocSlotFrom :: Ord x => IGPair x -> AreaSizeMap -> Int -> AreaMap -> Area -> AreaMap
allocSlotFrom ig areaSize from areaMap area =
if Map.member area areaMap then areaMap
else Map.insert area (freeSlotFrom ig areaSize from areaMap area) areaMap
+-- Figure out all of the offsets from the slot location; this will be
+-- non-zero for procpoints.
+type SpEntryMap = BlockEnv Int
+getSpEntryMap :: Int -> CmmGraph -> SpEntryMap
+getSpEntryMap entry_off g@(CmmGraph {g_entry = entry})
+ = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g
+ where add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int
+ add_sp_off b env =
+ case lastNode b of
+ CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env
+ CmmForeignCall {succ=succ} -> mapInsert succ wORD_SIZE env
+ _ -> env
+
-- | Greedy stack layout.
-- Compute liveness, build the interference graph, and allocate slots for the areas.
-- We visit each basic block in a (generally) forward order.
-- Note: The stack pointer only has to be younger than the youngest live stack slot
-- at proc points. Otherwise, the stack pointer can point anywhere.
-layout :: ProcPointSet -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap
+layout :: ProcPointSet -> SpEntryMap -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap
-- The domain of the returned map includes an Area for EVERY block
-- including each block that is not the successor of a call (ie is not a proc-point)
--- That's how we return the info of what the SP should be at the entry of every block
+-- That's how we return the info of what the SP should be at the entry of every non
+-- procpoint block. However, note that procpoint blocks have their
+-- /slot/ stored, which is not necessarily the value of the SP on entry
+-- to the block (in fact, it probably isn't, due to argument passing).
+-- See [Procpoint Sp offset]
-layout procPoints env entry_off g =
+layout procPoints spEntryMap env entry_off g =
let ig = (igraph areaBuilder env g, areaBuilder)
env' bid = mapLookup bid env `orElse` panic "unknown blockId in igraph"
areaSize = getAreaSize entry_off g
allocMid m areaMap = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap m) m
allocLast bid l areaMap =
foldr (setSuccSPs inSp) areaMap' (successors l)
- where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young bid)) areaMap
+ where inSp = slot + spOffset -- [Procpoint Sp offset]
+ -- If it's not in the map, we should use our previous
+ -- calculation unchanged.
+ spOffset = mapLookup bid spEntryMap `orElse` 0
+ slot = expectJust "slot in" $ Map.lookup (CallArea (Young bid)) areaMap
areaMap' = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap l) l
alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a
alloc' areaMap _ = areaMap
- initMap = Map.insert (CallArea (Young (g_entry g))) 0 $
- Map.insert (CallArea Old) 0 Map.empty
-
+ initMap = Map.insert (CallArea (Young (g_entry g))) 0
+ . Map.insert (CallArea Old) 0
+ $ Map.empty
+
areaMap = foldl layoutAreas initMap (postorderDfs g)
in -- pprTrace "ProcPoints" (ppr procPoints) $
- -- pprTrace "Area SizeMap" (ppr areaSize) $
- -- pprTrace "Entry SP" (ppr entrySp) $
- -- pprTrace "Area Map" (ppr areaMap) $
+ -- pprTrace "Area SizeMap" (ppr areaSize) $
+ -- pprTrace "Entry offset" (ppr entry_off) $
+ -- pprTrace "Area Map" (ppr areaMap) $
areaMap
+{- Note [Procpoint Sp offset]
+
+The calculation of inSp is a little tricky. (Un)fortunately, if you get
+it wrong, you will get inefficient but correct code. You know you've
+got it wrong if the generated stack pointer bounces up and down for no
+good reason.
+
+Why can't we just set inSp to the location of the slot? (This is what
+the code used to do.) The trouble is when we actually hit the proc
+point the start of the slot will not be the same as the actual Sp due
+to argument passing:
+
+ a:
+ I32[(young<b> + 4)] = cde;
+ // Stack pointer is moved to young end (bottom) of young<b> for call
+ // +-------+
+ // | arg 1 |
+ // +-------+ <- Sp
+ call (I32[foobar::I32])(...) returns to Just b (4) (4) with update frame 4;
+ b:
+ // After call, stack pointer is above the old end (top) of
+ // young<b> (the difference is spOffset)
+ // +-------+ <- Sp
+ // | arg 1 |
+ // +-------+
+
+If we blithely set the Sp to be the same as the slot (the young end of
+young<b>), an adjustment will be necessary when we go to the next block.
+This is wasteful. So, instead, for the next block after a procpoint,
+the actual Sp should be set to the same as the true Sp when we just
+entered the procpoint. Then manifestSP will automatically do the right
+thing.
+
+Questions you may ask:
+
+1. Why don't we need to change the mapping for the procpoint itself?
+ Because manifestSP does its own calculation of the true stack value,
+ manifestSP will notice the discrepancy between the actual stack
+ pointer and the slot start, and adjust all of its memory accesses
+ accordingly. So the only problem is when we adjust the Sp in
+ preparation for the successor block; that's why this code is here and
+ not in setSuccSPs.
+
+2. Why don't we make the procpoint call area and the true offset match
+ up? If we did that, we would never use memory above the true value
+ of the stack pointer, thus wasting all of the stack we used to store
+ arguments. You might think that some clever changes to the slot
+ offsets, using negative offsets, might fix it, but this does not make
+ semantic sense.
+
+3. If manifestSP is already calculating the true stack value, why we can't
+ do this trick inside manifestSP itself? The reason is that if two
+ branches join with inconsistent SPs, one of them has to be fixed: we
+ can't know what the fix should be without already knowing what the
+ chosen location of SP is on the next successor. (This is
+ the "succ already knows incoming SP" case), This calculation cannot
+ be easily done in manifestSP, since it processes the nodes
+ /backwards/. So we need to have figured this out before we hit
+ manifestSP.
+-}
+
-- After determining the stack layout, we can:
-- 1. Replace references to stack Areas with addresses relative to the stack
-- pointer.
-- stack pointer to be younger than the live values on the stack at proc points.
-- 3. Compute the maximum stack offset used in the procedure and replace
-- the stack high-water mark with that offset.
-manifestSP :: AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph
-manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) =
+manifestSP :: SpEntryMap -> AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph
+manifestSP spEntryMap areaMap entry_off g@(CmmGraph {g_entry=entry}) =
ofBlockMap entry `liftM` foldl replB (return mapEmpty) (postorderDfs g)
where slot a = -- pprTrace "slot" (ppr a) $
Map.lookup a areaMap `orElse` panic "unallocated Area"
sp_high = maxSlot slot g
proc_entry_sp = slot (CallArea Old) + entry_off
- add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int
- add_sp_off b env =
- case lastNode b of
- CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env
- CmmForeignCall {succ=succ} -> mapInsert succ wORD_SIZE env
- _ -> env
- spEntryMap = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g
spOffset id = mapLookup id spEntryMap `orElse` 0
sp_on_entry id | id == entry = proc_entry_sp
where spIn = sp_on_entry (entryLabel block)
middle spOff m = mapExpDeep (replSlot spOff) m
+ -- XXX there shouldn't be any global registers in the
+ -- CmmCall, so there shouldn't be any slots in
+ -- CmmCall... check that...
last spOff l = mapExpDeep (replSlot spOff) l
replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark
CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
+ -- Invariant: Sp is always greater than SpLim. Thus, if
+ -- the high water mark is zero, we can optimize away the
+ -- conditional branch. Relies on dead code elimination
+ -- to get rid of the dead GC blocks.
+ -- EZY: Maybe turn this into a guard that checks if a
+ -- statement is stack-check ish? Maybe we should make
+ -- an actual mach-op for it, so there's no chance of
+ -- mixing this up with something else...
+ replSlot _ (CmmMachOp (MO_U_Lt _)
+ [CmmMachOp (MO_Sub _)
+ [ CmmReg (CmmGlobal Sp)
+ , CmmLit (CmmInt 0 _)],
+ CmmReg (CmmGlobal SpLim)]) = CmmLit (CmmInt 0 wordWidth)
replSlot _ e = e
replLast :: MaybeC C (CmmNode C O) -> [CmmNode O O] -> CmmNode O C -> FuelUniqSM [CmmBlock]
| CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is
-- given by cmmExprType of the rhs.
- | CmmCall -- A call (forign, native or primitive), with
+ | CmmCall -- A call (foreign, native or primitive), with
CmmCallTarget
HintedCmmFormals -- zero or more results
HintedCmmActuals -- zero or more arguments
CmmSafety -- whether to build a continuation
CmmReturnInfo
+ -- Some care is necessary when handling the arguments of these, see
+ -- [Register parameter passing] and the hack in cmm/CmmOpt.hs
| CmmBranch BlockId -- branch to another BB in this fn
import Data.Array.ST
import Control.Monad.ST
-#if x86_64_TARGET_ARCH
-import StaticFlags ( opt_Unregisterised )
-#endif
-
#if defined(alpha_TARGET_ARCH) || defined(mips_TARGET_ARCH) || defined(mipsel_TARGET_ARCH) || defined(arm_TARGET_ARCH)
#define BEWARE_LOAD_STORE_ALIGNMENT
#endif
| CmmNeverReturns <- ret ->
let myCall = pprCall (pprCLabel lbl) cconv results args safety
in (real_fun_proto lbl, myCall)
- | not (isMathFun lbl || isCas lbl) ->
+ | not (isMathFun lbl) ->
let myCall = braces (
pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
$$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
| otherwise
=
-#if x86_64_TARGET_ARCH
- -- HACK around gcc optimisations.
- -- x86_64 needs a __DISCARD__() here, to create a barrier between
- -- putting the arguments into temporaries and passing the arguments
- -- to the callee, because the argument expressions may refer to
- -- machine registers that are also used for passing arguments in the
- -- C calling convention.
- (if (not opt_Unregisterised)
- then ptext (sLit "__DISCARD__();")
- else empty) $$
-#endif
ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
where
ppr_assign [] rhs = rhs
+More notes (May 11)\r
+~~~~~~~~~~~~~~~~~~~\r
+In CmmNode, consider spliting CmmCall into two: call and jump\r
+\r
Notes on new codegen (Aug 10)\r
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\r
\r
This will fix the spill before stack check problem but only really as a side\r
effect. A 'real fix' probably requires making the spiller know about sp checks.\r
\r
- - There is some silly stuff happening with the Sp. We end up with code like:\r
- Sp = Sp + 8; R1 = _vwf::I64; Sp = Sp -8\r
- Seems to be perhaps caused by the issue above but also maybe a optimisation\r
- pass needed?\r
+ EZY: I don't understand this comment. David Terei, can you clarify?\r
\r
- - Proc pass all arguments on the stack, adding more code and slowing down things\r
- a lot. We either need to fix this or even better would be to get rid of\r
- proc points.\r
+ - Proc points pass all arguments on the stack, adding more code and\r
+ slowing down things a lot. We either need to fix this or even better\r
+ would be to get rid of proc points.\r
\r
- CmmInfo.cmmToRawCmm uses Old.Cmm, so it is called after converting Cmm.Cmm to\r
Old.Cmm. We should abstract it to work on both representations, it needs only to\r
we could convert codeGen/StgCmm* clients to the Hoopl's semantics?\r
It's all deeply unsatisfactory.\r
\r
- - Improve preformance of Hoopl.\r
+ - Improve performance of Hoopl.\r
\r
A nofib comparison of -fasm vs -fnewcodegen nofib compilation parameters\r
(using the same ghc-cmm branch +libraries compiled by the old codegenerator)\r
\r
So we generate a bit better code, but it takes us longer!\r
\r
+ EZY: Also importantly, Hoopl uses dramatically more memory than the\r
+ old code generator.\r
+\r
- Are all blockToNodeList and blockOfNodeList really needed? Maybe we could\r
splice blocks instead?\r
\r
a block catenation function would be probably nicer than blockToNodeList\r
/ blockOfNodeList combo.\r
\r
- - loweSafeForeignCall seems too lowlevel. Just use Dataflow. After that\r
+ - lowerSafeForeignCall seems too lowlevel. Just use Dataflow. After that\r
delete splitEntrySeq from HooplUtils.\r
\r
- manifestSP seems to touch a lot of the graph representation. It is\r
calling convention, and the code for calling foreign calls is generated\r
\r
- AsmCodeGen has a generic Cmm optimiser; move this into new pipeline\r
+ EZY (2011-04-16): The mini-inliner has been generalized and ported,\r
+ but the constant folding and other optimizations need to still be\r
+ ported.\r
\r
- AsmCodeGen has post-native-cg branch eliminator (shortCutBranches);\r
we ultimately want to share this with the Cmm branch eliminator.\r
- See "CAFs" below; we want to totally refactor the way SRTs are calculated\r
\r
- Pull out Areas into its own module\r
- Parameterise AreaMap\r
+ Parameterise AreaMap (note there are type synonyms in CmmStackLayout!)\r
Add ByteWidth = Int\r
type SubArea = (Area, ByteOff, ByteWidth) \r
ByteOff should not be defined in SMRep -- that is too high up the hierarchy\r
insert spills/reloads across \r
LastCalls, and \r
Branches to proc-points\r
- Now sink those reloads:\r
- - CmmSpillReload.insertLateReloads\r
+ Now sink those reloads (and other instructions):\r
+ - CmmSpillReload.rewriteAssignments\r
- CmmSpillReload.removeDeadAssignmentsAndReloads\r
\r
* CmmStackLayout.stubSlotsOnDeath\r
never pass variables to join points via arguments.)\r
\r
Furthermore, there is *no way* to pass q to J in a register (other\r
-than a paramter register).\r
+than a parameter register).\r
\r
What we want is to do register allocation across the whole caboodle.\r
Then we could drop all the code that deals with the above awkward\r
cgPrimOp
) where
+import BasicTypes
import ForeignCall
import ClosureInfo
import StgSyn
import CgForeignCall
import CgBindery
import CgMonad
+import CgHeapery
import CgInfoTbls
+import CgTicky
+import CgProf
import CgUtils
import OldCmm
import CLabel
emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] _
= stmtC (CmmAssign (CmmLocal res) arg)
+emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] live =
+ doCopyArrayOp src src_off dst dst_off n live
+emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] live =
+ doCopyMutableArrayOp src src_off dst dst_off n live
+emitPrimOp [res] CloneArrayOp [src,src_off,n] live =
+ emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live
+emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] live =
+ emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live
+emitPrimOp [res] FreezeArrayOp [src,src_off,n] live =
+ emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live
+emitPrimOp [res] ThawArrayOp [src,src_off,n] live =
+ emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live
+
-- Reading/writing pointer arrays
emitPrimOp [r] ReadArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix
setInfo :: CmmExpr -> CmmExpr -> CmmStmt
setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr
+-- ----------------------------------------------------------------------------
+-- Copying pointer arrays
+
+-- | Takes a source 'Array#', an offset in the source array, a
+-- destination 'MutableArray#', an offset into the destination array,
+-- and the number of elements to copy. Copies the given number of
+-- elements from the source array to the destination array.
+doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+ -> StgLiveVars -> Code
+doCopyArrayOp = emitCopyArray copy
+ where
+ -- Copy data (we assume the arrays aren't overlapping since
+ -- they're of different types)
+ copy _src _dst = emitMemcpyCall
+
+-- | Takes a source 'MutableArray#', an offset in the source array, a
+-- destination 'MutableArray#', an offset into the destination array,
+-- and the number of elements to copy. Copies the given number of
+-- elements from the source array to the destination array.
+doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+ -> StgLiveVars -> Code
+doCopyMutableArrayOp = emitCopyArray copy
+ where
+ -- The only time the memory might overlap is when the two arrays
+ -- we were provided are the same array!
+ -- TODO: Optimize branch for common case of no aliasing.
+ copy src dst dst_p src_p bytes live =
+ emitIfThenElse (cmmEqWord src dst)
+ (emitMemmoveCall dst_p src_p bytes live)
+ (emitMemcpyCall dst_p src_p bytes live)
+
+emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+ -> StgLiveVars -> Code)
+ -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+ -> StgLiveVars
+ -> Code
+emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do
+ -- Assign the arguments to temporaries so the code generator can
+ -- calculate liveness for us.
+ src <- assignTemp_ src0
+ src_off <- assignTemp_ src_off0
+ dst <- assignTemp_ dst0
+ dst_off <- assignTemp_ dst_off0
+ n <- assignTemp_ n0
+
+ -- Set the dirty bit in the header.
+ stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
+
+ dst_elems_p <- assignTemp $ cmmOffsetB dst arrPtrsHdrSize
+ dst_p <- assignTemp $ cmmOffsetExprW dst_elems_p dst_off
+ src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off
+ bytes <- assignTemp $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE))
+
+ copy src dst dst_p src_p bytes live
+
+ -- The base address of the destination card table
+ dst_cards_p <- assignTemp $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst)
+
+ emitSetCards dst_off dst_cards_p n live
+
+-- | Takes an info table label, a register to return the newly
+-- allocated array in, a source array, an offset in the source array,
+-- and the number of elements to copy. Allocates a new array and
+-- initializes it form the source array.
+emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr
+ -> StgLiveVars -> Code
+emitCloneArray info_p res_r src0 src_off0 n0 live = do
+ -- Assign the arguments to temporaries so the code generator can
+ -- calculate liveness for us.
+ src <- assignTemp_ src0
+ src_off <- assignTemp_ src_off0
+ n <- assignTemp_ n0
+
+ card_words <- assignTemp $ (n `cmmUShrWord`
+ (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)))
+ `cmmAddWord` CmmLit (mkIntCLit 1)
+ size <- assignTemp $ n `cmmAddWord` card_words
+ words <- assignTemp $ arrPtrsHdrSizeW `cmmAddWord` size
+
+ arr_r <- newTemp bWord
+ emitAllocateCall arr_r myCapability words live
+ tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize)
+ (CmmLit $ mkIntCLit 0)
+
+ let arr = CmmReg (CmmLocal arr_r)
+ emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr
+ stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
+ oFFSET_StgMutArrPtrs_ptrs)) n
+ stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
+ oFFSET_StgMutArrPtrs_size)) size
+
+ dst_p <- assignTemp $ cmmOffsetB arr arrPtrsHdrSize
+ src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize)
+ src_off
+
+ emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) live
+
+ emitMemsetCall (cmmOffsetExprW dst_p n)
+ (CmmLit (CmmInt (toInteger (1 :: Int)) W8))
+ (card_words `cmmMulWord` wordSize)
+ live
+ stmtC $ CmmAssign (CmmLocal res_r) arr
+ where
+ arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize +
+ (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
+ wordSize = CmmLit (mkIntCLit wORD_SIZE)
+ myCapability = CmmReg baseReg `cmmSubWord`
+ CmmLit (mkIntCLit oFFSET_Capability_r)
+
+-- | Takes and offset in the destination array, the base address of
+-- the card table, and the number of elements affected (*not* the
+-- number of cards). Marks the relevant cards as dirty.
+emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitSetCards dst_start dst_cards_start n live = do
+ start_card <- assignTemp $ card dst_start
+ emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
+ (CmmLit (CmmInt (toInteger (1 :: Int)) W8))
+ ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card)
+ `cmmAddWord` CmmLit (mkIntCLit 1))
+ live
+ where
+ -- Convert an element index to a card index
+ card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
+
+-- | Emit a call to @memcpy@.
+emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitMemcpyCall dst src n live = do
+ vols <- getVolatileRegs live
+ emitForeignCall' PlayRisky
+ [{-no results-}]
+ (CmmCallee memcpy CCallConv)
+ [ (CmmHinted dst AddrHint)
+ , (CmmHinted src AddrHint)
+ , (CmmHinted n NoHint)
+ ]
+ (Just vols)
+ NoC_SRT -- No SRT b/c we do PlayRisky
+ CmmMayReturn
+ where
+ memcpy = CmmLit (CmmLabel (mkForeignLabel (fsLit "memcpy") Nothing
+ ForeignLabelInExternalPackage IsFunction))
+
+-- | Emit a call to @memmove@.
+emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitMemmoveCall dst src n live = do
+ vols <- getVolatileRegs live
+ emitForeignCall' PlayRisky
+ [{-no results-}]
+ (CmmCallee memmove CCallConv)
+ [ (CmmHinted dst AddrHint)
+ , (CmmHinted src AddrHint)
+ , (CmmHinted n NoHint)
+ ]
+ (Just vols)
+ NoC_SRT -- No SRT b/c we do PlayRisky
+ CmmMayReturn
+ where
+ memmove = CmmLit (CmmLabel (mkForeignLabel (fsLit "memmove") Nothing
+ ForeignLabelInExternalPackage IsFunction))
+
+-- | Emit a call to @memset@. The second argument must be of type
+-- 'W8'.
+emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitMemsetCall dst c n live = do
+ vols <- getVolatileRegs live
+ emitForeignCall' PlayRisky
+ [{-no results-}]
+ (CmmCallee memset CCallConv)
+ [ (CmmHinted dst AddrHint)
+ , (CmmHinted c NoHint)
+ , (CmmHinted n NoHint)
+ ]
+ (Just vols)
+ NoC_SRT -- No SRT b/c we do PlayRisky
+ CmmMayReturn
+ where
+ memset = CmmLit (CmmLabel (mkForeignLabel (fsLit "memset") Nothing
+ ForeignLabelInExternalPackage IsFunction))
+
+-- | Emit a call to @allocate@.
+emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitAllocateCall res cap n live = do
+ vols <- getVolatileRegs live
+ emitForeignCall' PlayRisky
+ [CmmHinted res AddrHint]
+ (CmmCallee allocate CCallConv)
+ [ (CmmHinted cap AddrHint)
+ , (CmmHinted n NoHint)
+ ]
+ (Just vols)
+ NoC_SRT -- No SRT b/c we do PlayRisky
+ CmmMayReturn
+ where
+ allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing
+ ForeignLabelInExternalPackage IsFunction))
emitRODataLits, mkRODataLits,
emitIf, emitIfThenElse,
emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
- assignTemp, newTemp,
+ assignTemp, assignTemp_, newTemp,
emitSimultaneously,
emitSwitch, emitLitSwitch,
tagToClosure,
activeStgRegs, fixStgRegisters,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
- cmmUGtWord,
+ cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
cmmOffsetExprW, cmmOffsetExprB,
cmmRegOffW, cmmRegOffB,
cmmLabelOffW, cmmLabelOffB,
cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
--cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
---cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
+cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
+cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2]
cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
+cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2]
cmmNegate :: CmmExpr -> CmmExpr
cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
--
-------------------------------------------------------------------------
+-- | If the expression is trivial, return it. Otherwise, assign the
+-- expression to a temporary register and return an expression
+-- referring to this register.
assignTemp :: CmmExpr -> FCode CmmExpr
-- For a non-trivial expression, e, create a local
-- variable and assign the expression to it
; stmtC (CmmAssign (CmmLocal reg) e)
; return (CmmReg (CmmLocal reg)) }
+-- | If the expression is trivial and doesn't refer to a global
+-- register, return it. Otherwise, assign the expression to a
+-- temporary register and return an expression referring to this
+-- register.
+assignTemp_ :: CmmExpr -> FCode CmmExpr
+assignTemp_ e
+ | isTrivialCmmExpr e && hasNoGlobalRegs e = return e
+ | otherwise = do
+ reg <- newTemp (cmmExprType e)
+ stmtC (CmmAssign (CmmLocal reg) e)
+ return (CmmReg (CmmLocal reg))
+
newTemp :: CmmType -> FCode LocalReg
newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
-- * Regs.h claims that BaseReg should be saved last and loaded first
-- * This might not have been tickled before since BaseReg is callee save
-- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
+--
+-- This code isn't actually used right now, because callerSaves
+-- only ever returns true in the current universe for registers NOT in
+-- system_regs (just do a grep for CALLER_SAVES in
+-- includes/stg/MachRegs.h). It's all one giant no-op, and for
+-- good reason: having to save system registers on every foreign call
+-- would be very expensive, so we avoid assigning them to those
+-- registers when we add support for an architecture.
+--
+-- Note that the old code generator actually does more work here: it
+-- also saves other global registers. We can't (nor want) to do that
+-- here, as we don't have liveness information. And really, we
+-- shouldn't be doing the workaround at this point in the pipeline, see
+-- Note [Register parameter passing] and the ToDo on CmmCall in
+-- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across
+-- unsafe foreign calls in rewriteAssignments, but this is strictly
+-- temporary.
callerSaveVolatileRegs :: (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs = (caller_save, caller_load)
where
#ifdef CALLER_SAVES_Base
callerSaves BaseReg = True
#endif
+#ifdef CALLER_SAVES_R1
+callerSaves (VanillaReg 1 _) = True
+#endif
+#ifdef CALLER_SAVES_R2
+callerSaves (VanillaReg 2 _) = True
+#endif
+#ifdef CALLER_SAVES_R3
+callerSaves (VanillaReg 3 _) = True
+#endif
+#ifdef CALLER_SAVES_R4
+callerSaves (VanillaReg 4 _) = True
+#endif
+#ifdef CALLER_SAVES_R5
+callerSaves (VanillaReg 5 _) = True
+#endif
+#ifdef CALLER_SAVES_R6
+callerSaves (VanillaReg 6 _) = True
+#endif
+#ifdef CALLER_SAVES_R7
+callerSaves (VanillaReg 7 _) = True
+#endif
+#ifdef CALLER_SAVES_R8
+callerSaves (VanillaReg 8 _) = True
+#endif
+#ifdef CALLER_SAVES_F1
+callerSaves (FloatReg 1) = True
+#endif
+#ifdef CALLER_SAVES_F2
+callerSaves (FloatReg 2) = True
+#endif
+#ifdef CALLER_SAVES_F3
+callerSaves (FloatReg 3) = True
+#endif
+#ifdef CALLER_SAVES_F4
+callerSaves (FloatReg 4) = True
+#endif
+#ifdef CALLER_SAVES_D1
+callerSaves (DoubleReg 1) = True
+#endif
+#ifdef CALLER_SAVES_D2
+callerSaves (DoubleReg 2) = True
+#endif
+#ifdef CALLER_SAVES_L1
+callerSaves (LongReg 1) = True
+#endif
#ifdef CALLER_SAVES_Sp
callerSaves Sp = True
#endif
import Unique
import Outputable
import FastString
+import Pair
\end{code}
%************************************************************************
go (Lam x e) | isId x = go e + 1
| otherwise = go e
go (Note n e) | notSccNote n = go e
- go (Cast e co) = go e `min` length (typeArity (snd (coercionKind co)))
- -- Note [exprArity invariant]
+ go (Cast e co) = go e `min` length (typeArity (pSnd (coercionKind co)))
+ -- Note [exprArity invariant]
go (App e (Type _)) = go e
go (App f a) | exprIsTrivial a = (go f - 1) `max` 0
-- See Note [exprArity for applications]
+ -- NB: coercions count as a value argument
+
go _ = 0
| isId x = arityLam x (arityType cheap_fn e)
| otherwise = arityType cheap_fn e
- -- Applications; decrease arity
+ -- Applications; decrease arity, except for types
arityType cheap_fn (App fun (Type _))
= arityType cheap_fn fun
arityType cheap_fn (App fun arg )
-- Strip off existing lambdas and casts
-- Note [Eta expansion and SCCs]
go 0 expr = expr
- go n (Lam v body) | isTyCoVar v = Lam v (go n body)
- | otherwise = Lam v (go (n-1) body)
+ go n (Lam v body) | isTyVar v = Lam v (go n body)
+ | otherwise = Lam v (go (n-1) body)
go n (Cast expr co) = Cast (go n expr) co
go n expr = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
etaInfoAbs etas (etaInfoApp subst' expr etas)
where
in_scope = mkInScopeSet (exprFreeVars expr)
- (in_scope', etas) = mkEtaWW n in_scope (exprType expr)
+ (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr)
subst' = mkEmptySubst in_scope'
-- Wrapper Unwrapper
pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo]
pushCoercion co1 (EtaCo co2 : eis)
- | isIdentityCoercion co = eis
- | otherwise = EtaCo co : eis
+ | isReflCo co = eis
+ | otherwise = EtaCo co : eis
where
- co = co1 `mkTransCoercion` co2
+ co = co1 `mkTransCo` co2
pushCoercion co eis = EtaCo co : eis
etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr
etaInfoAbs [] expr = expr
etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr)
-etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCoercion co)
+etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co)
--------------
etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
-- ((substExpr s e) `appliedto` eis)
etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis)
- = etaInfoApp subst' e eis
- where
- subst' | isTyCoVar v1 = CoreSubst.extendTvSubst subst v1 (mkTyVarTy v2)
- | otherwise = CoreSubst.extendIdSubst subst v1 (Var v2)
+ = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis
etaInfoApp subst (Cast e co1) eis
= etaInfoApp subst e (pushCoercion co' eis)
where
- co' = CoreSubst.substTy subst co1
+ co' = CoreSubst.substCo subst co1
etaInfoApp subst (Case e b _ alts) eis
= Case (subst_expr subst e) b1 (coreAltsType alts') alts'
go e (EtaCo co : eis) = go (Cast e co) eis
--------------
-mkEtaWW :: Arity -> InScopeSet -> Type
+mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type
-> (InScopeSet, [EtaInfo])
-- EtaInfo contains fresh variables,
-- not free in the incoming CoreExpr
-- Outgoing InScopeSet includes the EtaInfo vars
-- and the original free vars
-mkEtaWW orig_n in_scope orig_ty
+mkEtaWW orig_n orig_expr in_scope orig_ty
= go orig_n empty_subst orig_ty []
where
- empty_subst = mkTvSubst in_scope emptyTvSubstEnv
+ empty_subst = TvSubst in_scope emptyTvSubstEnv
go n subst ty eis -- See Note [exprArity invariant]
| n == 0
= (getTvInScope subst, reverse eis)
| Just (tv,ty') <- splitForAllTy_maybe ty
- , let (subst', tv') = substTyVarBndr subst tv
+ , let (subst', tv') = Type.substTyVarBndr subst tv
-- Avoid free vars of the original expression
= go n subst' ty' (EtaVar tv' : eis)
-- eta_expand 1 e T
-- We want to get
-- coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
- go n subst ty' (EtaCo (Type.substTy subst co) : eis)
+ go n subst ty' (EtaCo co : eis)
| otherwise -- We have an expression of arity > 0,
-- but its type isn't a function.
- = WARN( True, ppr orig_n <+> ppr orig_ty )
+ = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )
(getTvInScope subst, reverse eis)
-- This *can* legitmately happen:
-- e.g. coerce Int (\x. x) Essentially the programmer is
import VarSet
import Var
import TcType
+import Coercion
import Util
import BasicTypes( Activation )
import Outputable
expr_fvs :: CoreExpr -> FV
expr_fvs (Type ty) = someVars (tyVarsOfType ty)
+expr_fvs (Coercion co) = someVars (tyCoVarsOfCo co)
expr_fvs (Var var) = oneVar var
expr_fvs (Lit _) = noVars
expr_fvs (Note _ expr) = expr_fvs expr
expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg
expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
-expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyVarsOfType co)
+expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyCoVarsOfCo co)
expr_fvs (Case scrut bndr ty alts)
= expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr
where n = idName v
go (Lit _) = emptyNameSet
go (Type ty) = orphNamesOfType ty -- Don't need free tyvars
+ go (Coercion co) = orphNamesOfCo co
go (App e1 e2) = go e1 `unionNameSets` go e2
go (Lam v e) = go e `delFromNameSet` idName v
go (Note _ e) = go e
- go (Cast e co) = go e `unionNameSets` orphNamesOfType co
+ go (Cast e co) = go e `unionNameSets` orphNamesOfCo co
go (Let (NonRec _ r) e) = go e `unionNameSets` go r
go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSets` go e
go (Case e _ ty as) = go e `unionNameSets` orphNamesOfType ty
-- Find the type variables free in the type of the variable
-- Remember, coercion variables can mention type variables...
varTypeTyVars var
- | isLocalId var || isCoVar var = tyVarsOfType (idType var)
- | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars
+ | isLocalId var = tyVarsOfType (idType var)
+ | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars
varTypeTcTyVars :: Var -> TyVarSet
-- Find the type variables free in the type of the variable
-- Remember, coercion variables can mention type variables...
varTypeTcTyVars var
- | isLocalId var || isCoVar var = tcTyVarsOfType (idType var)
- | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars
+ | isLocalId var = tcTyVarsOfType (idType var)
+ | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars
idFreeVars :: Id -> VarSet
-- Type variables, rule variables, and inline variables
bndrRuleAndUnfoldingVars ::Var -> VarSet
-- A 'let' can bind a type variable, and idRuleVars assumes
-- it's seeing an Id. This function tests first.
-bndrRuleAndUnfoldingVars v | isTyCoVar v = emptyVarSet
+bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet
| otherwise = idRuleAndUnfoldingVars v
idRuleAndUnfoldingVars :: Id -> VarSet
body2 = freeVars body
body_fvs = freeVarsOf body2
-
freeVars (Cast expr co)
- = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 co)
+ = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co))
where
expr2 = freeVars expr
- cfvs = tyVarsOfType co
+ cfvs = tyCoVarsOfCo co
freeVars (Note other_note expr)
= (freeVarsOf expr2, AnnNote other_note expr2)
expr2 = freeVars expr
freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
+
+freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co)
\end{code}
import CoreSyn
import CoreFVs
import CoreUtils
+import Pair
import Bag
import Literal
import DataCon
import PprCore
import ErrUtils
import SrcLoc
+import Kind
import Type
import TypeRep
import Coercion
import Util
import Control.Monad
import Data.Maybe
+import Data.Traversable (traverse)
\end{code}
%************************************************************************
-- Check the rhs
do { ty <- lintCoreExpr rhs
; lintBinder binder -- Check match to RHS type
- ; binder_ty <- applySubst binder_ty
+ ; binder_ty <- applySubstTy binder_ty
; checkTys binder_ty ty (mkRhsMsg binder ty)
-- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
; checkL (not (isUnLiftedType binder_ty)
%************************************************************************
\begin{code}
-type InType = Type -- Substitution not yet applied
-type InVar = Var
-type InTyVar = TyVar
+type InType = Type -- Substitution not yet applied
+type InCoercion = Coercion
+type InVar = Var
+type InTyVar = TyVar
-type OutType = Type -- Substitution has been applied to this
-type OutVar = Var
-type OutTyVar = TyVar
-type OutCoVar = CoVar
+type OutType = Type -- Substitution has been applied to this
+type OutCoercion = Coercion
+type OutVar = Var
+type OutTyVar = TyVar
lintCoreExpr :: CoreExpr -> LintM OutType
-- The returned type has the substitution from the monad
= do { checkL (not (var == oneTupleDataConId))
(ptext (sLit "Illegal one-tuple"))
+ ; checkL (isId var && not (isCoVar var))
+ (ptext (sLit "Non term variable") <+> ppr var)
+
; checkDeadIdOcc var
; var' <- lookupIdInScope var
; return (idType var') }
lintCoreExpr (Cast expr co)
= do { expr_ty <- lintCoreExpr expr
- ; co' <- applySubst co
+ ; co' <- applySubstCo co
; (from_ty, to_ty) <- lintCoercion co'
; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
; return to_ty }
; lintTyBndr tv $ \ tv' ->
addLoc (BodyOfLetRec [tv]) $
extendSubstL tv' ty' $ do
- { checkKinds tv' ty'
+ { checkTyKind tv' ty'
-- Now extend the substitution so we
-- take advantage of it in the body
; lintCoreExpr body } }
- | isCoVar tv
- = do { co <- applySubst ty
- ; (s1,s2) <- addLoc (RhsOf tv) $ lintCoercion co
- ; lintTyBndr tv $ \ tv' ->
- addLoc (BodyOfLetRec [tv]) $ do
- { let (t1,t2) = coVarKind tv'
- ; checkTys s1 t1 (mkTyVarLetErr tv ty)
- ; checkTys s2 t2 (mkTyVarLetErr tv ty)
- ; lintCoreExpr body } }
-
- | otherwise
- = failWithL (mkTyVarLetErr tv ty) -- Not quite accurate
-
lintCoreExpr (Let (NonRec bndr rhs) body)
+ | isId bndr
= do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
- ; addLoc (BodyOfLetRec [bndr])
+ ; addLoc (BodyOfLetRec [bndr])
(lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
+ | otherwise
+ = failWithL (mkLetErr bndr rhs) -- Not quite accurate
+
lintCoreExpr (Let (Rec pairs) body)
= lintAndScopeIds bndrs $ \_ ->
do { checkL (null dups) (dupVars dups)
else
return (mkForAllTy var' body_ty)
}
- -- The applySubst is needed to apply the subst to var
+ -- The applySubstTy is needed to apply the subst to var
lintCoreExpr e@(Case scrut var alt_ty alts) =
-- Check the scrutinee
lintCoreExpr (Type ty)
= do { ty' <- lintInTy ty
; return (typeKind ty') }
+
+lintCoreExpr (Coercion co)
+ = do { co' <- lintInCo co
+ ; let Pair ty1 ty2 = coercionKind co'
+ ; return (mkPredTy $ EqPred ty1 ty2) }
\end{code}
%************************************************************************
\begin{code}
lintCoreArg :: OutType -> CoreArg -> LintM OutType
lintCoreArg fun_ty (Type arg_ty)
- = do { arg_ty' <- applySubst arg_ty
- ; lintTyApp fun_ty arg_ty' }
+ = do { arg_ty' <- applySubstTy arg_ty
+ ; lintTyApp fun_ty arg_ty' }
lintCoreArg fun_ty arg
- = do { arg_ty <- lintCoreExpr arg
- ; lintValApp arg fun_ty arg_ty }
+ = do { arg_ty <- lintCoreExpr arg
+ ; lintValApp arg fun_ty arg_ty }
-----------------
lintAltBinders :: OutType -- Scrutinee type
lintAltBinders scrut_ty con_ty []
= checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)
lintAltBinders scrut_ty con_ty (bndr:bndrs)
- | isTyCoVar bndr
+ | isTyVar bndr
= do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)
; lintAltBinders scrut_ty con_ty' bndrs }
| otherwise
lintTyApp :: OutType -> OutType -> LintM OutType
lintTyApp fun_ty arg_ty
| Just (tyvar,body_ty) <- splitForAllTy_maybe fun_ty
- = do { checkKinds tyvar arg_ty
- ; if isCoVar tyvar then
- return body_ty -- Co-vars don't appear in body_ty!
- else
- return (substTyWith [tyvar] [arg_ty] body_ty) }
+ , isTyVar tyvar
+ = do { checkTyKind tyvar arg_ty
+ ; return (substTyWith [tyvar] [arg_ty] body_ty) }
+
| otherwise
= failWithL (mkTyAppMsg fun_ty arg_ty)
\end{code}
\begin{code}
-checkKinds :: OutVar -> OutType -> LintM ()
+checkTyKind :: OutTyVar -> OutType -> LintM ()
-- Both args have had substitution applied
-checkKinds tyvar arg_ty
+checkTyKind tyvar arg_ty
-- Arg type might be boxed for a function with an uncommitted
-- tyvar; notably this is used so that we can give
-- error :: forall a:*. String -> a
-- and then apply it to both boxed and unboxed types.
- | isCoVar tyvar = do { (s2,t2) <- lintCoercion arg_ty
- ; unless (s1 `coreEqType` s2 && t1 `coreEqType` t2)
- (addErrL (mkCoAppErrMsg tyvar arg_ty)) }
- | otherwise = do { arg_kind <- lintType arg_ty
- ; unless (arg_kind `isSubKind` tyvar_kind)
- (addErrL (mkKindErrMsg tyvar arg_ty)) }
+ = do { arg_kind <- lintType arg_ty
+ ; unless (arg_kind `isSubKind` tyvar_kind)
+ (addErrL (mkKindErrMsg tyvar arg_ty)) }
where
tyvar_kind = tyVarKind tyvar
- (s1,t1) = coVarKind tyvar
+
+-- Check that the kinds of a type variable and a coercion match, that
+-- is, if tv :: k then co :: t1 ~ t2 where t1 :: k and t2 :: k.
+checkTyCoKind :: TyVar -> OutCoercion -> LintM (OutType, OutType)
+checkTyCoKind tv co
+ = do { (t1,t2) <- lintCoercion co
+ ; k1 <- lintType t1
+ ; k2 <- lintType t2
+ ; unless ((k1 `isSubKind` tyvar_kind) && (k2 `isSubKind` tyvar_kind))
+ (addErrL (mkTyCoAppErrMsg tv co))
+ ; return (t1,t2) }
+ where
+ tyvar_kind = tyVarKind tv
+
+checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)]
+checkTyCoKinds = zipWithM checkTyCoKind
checkDeadIdOcc :: Id -> LintM ()
-- Occurrences of an Id should never be dead....
lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a
lintTyBndr tv thing_inside
= do { subst <- getTvSubst
- ; let (subst', tv') = substTyVarBndr subst tv
+ ; let (subst', tv') = Type.substTyVarBndr subst tv
; lintTyBndrKind tv'
; updateTvSubst subst' (thing_inside tv') }
-- ToDo: check the kind structure of the type
lintInTy ty
= addLoc (InType ty) $
- do { ty' <- applySubst ty
+ do { ty' <- applySubstTy ty
; _ <- lintType ty'
; return ty' }
+lintInCo :: InCoercion -> LintM OutCoercion
+-- Check the coercion, and apply the substitution to it
+-- See Note [Linting type lets]
+lintInCo co
+ = addLoc (InCo co) $
+ do { co' <- applySubstCo co
+ ; _ <- lintCoercion co'
+ ; return co' }
+
-------------------
lintKind :: Kind -> LintM ()
-- Check well-formedness of kinds: *, *->*, etc
-------------------
lintTyBndrKind :: OutTyVar -> LintM ()
-lintTyBndrKind tv
- | isCoVar tv = lintCoVarKind tv
- | otherwise = lintKind (tyVarKind tv)
-
--------------------
-lintCoVarKind :: OutCoVar -> LintM ()
--- Check the kind of a coercion binder
-lintCoVarKind tv
- = do { (ty1,ty2) <- lintSplitCoVar tv
- ; k1 <- lintType ty1
- ; k2 <- lintType ty2
- ; unless (k1 `eqKind` k2)
- (addErrL (sep [ ptext (sLit "Kind mis-match in coercion kind of:")
- , nest 2 (quotes (ppr tv))
- , ppr [k1,k2] ])) }
+lintTyBndrKind tv = lintKind (tyVarKind tv)
-------------------
-lintSplitCoVar :: CoVar -> LintM (Type,Type)
-lintSplitCoVar cv
- = case coVarKind_maybe cv of
- Just ts -> return ts
- Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:")
- , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))])
-
--------------------
-lintCoercion, lintCoercion' :: OutType -> LintM (OutType, OutType)
+lintCoercion :: OutCoercion -> LintM (OutType, OutType)
-- Check the kind of a coercion term, returning the kind
-lintCoercion co
- = addLoc (InCoercion co) $ lintCoercion' co
-
-lintCoercion' ty@(TyVarTy tv)
- = do { checkTyVarInScope tv
- ; if isCoVar tv then return (coVarKind tv)
- else return (ty, ty) }
-
-lintCoercion' ty@(AppTy ty1 ty2)
- = do { (s1,t1) <- lintCoercion ty1
- ; (s2,t2) <- lintCoercion ty2
- ; check_co_app ty (typeKind s1) [s2]
- ; return (mkAppTy s1 s2, mkAppTy t1 t2) }
-
-lintCoercion' ty@(FunTy ty1 ty2)
- = do { (s1,t1) <- lintCoercion ty1
- ; (s2,t2) <- lintCoercion ty2
- ; check_co_app ty (tyConKind funTyCon) [s1, s2]
- ; return (FunTy s1 s2, FunTy t1 t2) }
-
-lintCoercion' ty@(TyConApp tc tys)
- | Just (ar, desc) <- isCoercionTyCon_maybe tc
- = do { unless (tys `lengthAtLeast` ar) (badCo ty)
- ; (s,t) <- lintCoTyConApp ty desc (take ar tys)
- ; (ss,ts) <- mapAndUnzipM lintCoercion (drop ar tys)
- ; check_co_app ty (typeKind s) ss
- ; return (mkAppTys s ss, mkAppTys t ts) }
+lintCoercion (Refl ty)
+ = do { ty' <- lintInTy ty
+ ; return (ty', ty') }
- | not (tyConHasKind tc) -- Just something bizarre like SuperKindTyCon
- = badCo ty
+lintCoercion co@(TyConAppCo tc cos)
+ = do { (ss,ts) <- mapAndUnzipM lintCoercion cos
+ ; check_co_app co (tyConKind tc) ss
+ ; return (mkTyConApp tc ss, mkTyConApp tc ts) }
- | otherwise
- = do { (ss,ts) <- mapAndUnzipM lintCoercion tys
- ; check_co_app ty (tyConKind tc) ss
- ; return (TyConApp tc ss, TyConApp tc ts) }
-
-lintCoercion' ty@(PredTy (ClassP cls tys))
- = do { (ss,ts) <- mapAndUnzipM lintCoercion tys
- ; check_co_app ty (tyConKind (classTyCon cls)) ss
- ; return (PredTy (ClassP cls ss), PredTy (ClassP cls ts)) }
-
-lintCoercion' (PredTy (IParam n p_ty))
- = do { (s,t) <- lintCoercion p_ty
- ; return (PredTy (IParam n s), PredTy (IParam n t)) }
-
-lintCoercion' ty@(PredTy (EqPred {}))
- = failWithL (badEq ty)
-
-lintCoercion' (ForAllTy tv ty)
- | isCoVar tv
- = do { (co1, co2) <- lintSplitCoVar tv
- ; (s1,t1) <- lintCoercion co1
- ; (s2,t2) <- lintCoercion co2
- ; (sr,tr) <- lintCoercion ty
- ; return (mkCoPredTy s1 s2 sr, mkCoPredTy t1 t2 tr) }
+lintCoercion co@(AppCo co1 co2)
+ = do { (s1,t1) <- lintCoercion co1
+ ; (s2,t2) <- lintCoercion co2
+ ; check_co_app co (typeKind s1) [s2]
+ ; return (mkAppTy s1 s2, mkAppTy t1 t2) }
- | otherwise
- = do { lintKind (tyVarKind tv)
- ; (s,t) <- addInScopeVar tv (lintCoercion ty)
- ; return (ForAllTy tv s, ForAllTy tv t) }
-
-badCo :: Coercion -> LintM a
-badCo co = failWithL (hang (ptext (sLit "Ill-kinded coercion term:")) 2 (ppr co))
-
----------------
-lintCoTyConApp :: Coercion -> CoTyConDesc -> [Coercion] -> LintM (Type,Type)
--- Always called with correct number of coercion arguments
--- First arg is just for error message
-lintCoTyConApp _ CoLeft (co:_) = lintLR fst co
-lintCoTyConApp _ CoRight (co:_) = lintLR snd co
-lintCoTyConApp _ CoCsel1 (co:_) = lintCsel fstOf3 co
-lintCoTyConApp _ CoCsel2 (co:_) = lintCsel sndOf3 co
-lintCoTyConApp _ CoCselR (co:_) = lintCsel thirdOf3 co
-
-lintCoTyConApp _ CoSym (co:_)
- = do { (ty1,ty2) <- lintCoercion co
- ; return (ty2,ty1) }
-
-lintCoTyConApp co CoTrans (co1:co2:_)
+lintCoercion (ForAllCo v co)
+ = do { lintKind (tyVarKind v)
+ ; (s,t) <- addInScopeVar v (lintCoercion co)
+ ; return (ForAllTy v s, ForAllTy v t) }
+
+lintCoercion (CoVarCo cv)
+ = do { checkTyCoVarInScope cv
+ ; return (coVarKind cv) }
+
+lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = tvs
+ , co_ax_lhs = lhs
+ , co_ax_rhs = rhs })
+ cos)
+ = do { (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs cos)
+ ; return (substTyWith tvs tys1 lhs,
+ substTyWith tvs tys2 rhs) }
+
+lintCoercion (UnsafeCo ty1 ty2)
+ = do { ty1' <- lintInTy ty1
+ ; ty2' <- lintInTy ty2
+ ; return (ty1', ty2') }
+
+lintCoercion (SymCo co)
+ = do { (ty1, ty2) <- lintCoercion co
+ ; return (ty2, ty1) }
+
+lintCoercion co@(TransCo co1 co2)
= do { (ty1a, ty1b) <- lintCoercion co1
; (ty2a, ty2b) <- lintCoercion co2
- ; checkL (ty1b `coreEqType` ty2a)
+ ; checkL (ty1b `eqType` ty2a)
(hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co)
2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
; return (ty1a, ty2b) }
-lintCoTyConApp _ CoInst (co:arg_ty:_)
- = do { co_tys <- lintCoercion co
+lintCoercion the_co@(NthCo d co)
+ = do { (s,t) <- lintCoercion co
+ ; sn <- checkTcApp the_co d s
+ ; tn <- checkTcApp the_co d t
+ ; return (sn, tn) }
+
+lintCoercion (InstCo co arg_ty)
+ = do { co_tys <- lintCoercion co
; arg_kind <- lintType arg_ty
- ; case decompInst_maybe co_tys of
- Just ((tv1,tv2), (ty1,ty2))
+ ; case splitForAllTy_maybe `traverse` toPair co_tys of
+ Just (Pair (tv1,ty1) (tv2,ty2))
| arg_kind `isSubKind` tyVarKind tv1
-> return (substTyWith [tv1] [arg_ty] ty1,
substTyWith [tv2] [arg_ty] ty2)
-> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
Nothing -> failWithL (ptext (sLit "Bad argument of inst")) }
-lintCoTyConApp _ (CoAxiom { co_ax_tvs = tvs
- , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos
- = do { (tys1, tys2) <- mapAndUnzipM lintCoercion cos
- ; sequence_ (zipWith checkKinds tvs tys1)
- ; return (substTyWith tvs tys1 lhs_ty,
- substTyWith tvs tys2 rhs_ty) }
-
-lintCoTyConApp _ CoUnsafe (ty1:ty2:_)
- = do { _ <- lintType ty1
- ; _ <- lintType ty2 -- Ignore kinds; it's unsafe!
- ; return (ty1,ty2) }
-
-lintCoTyConApp _ _ _ = panic "lintCoTyConApp" -- Called with wrong number of coercion args
-
----------
-lintLR :: (forall a. (a,a)->a) -> Coercion -> LintM (Type,Type)
-lintLR sel co
- = do { (ty1,ty2) <- lintCoercion co
- ; case decompLR_maybe (ty1,ty2) of
- Just res -> return (sel res)
- Nothing -> failWithL (ptext (sLit "Bad argument of left/right")) }
-
-----------
-lintCsel :: (forall a. (a,a,a)->a) -> Coercion -> LintM (Type,Type)
-lintCsel sel co
- = do { (ty1,ty2) <- lintCoercion co
- ; case decompCsel_maybe (ty1,ty2) of
- Just res -> return (sel res)
- Nothing -> failWithL (ptext (sLit "Bad argument of csel")) }
+checkTcApp :: Coercion -> Int -> Type -> LintM Type
+checkTcApp co n ty
+ | Just (_, tys) <- splitTyConApp_maybe ty
+ , n < length tys
+ = return (tys !! n)
+ | otherwise
+ = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co)
+ 2 (ptext (sLit "Offending type:") <+> ppr ty))
-------------------
lintType :: OutType -> LintM Kind
lintType (TyVarTy tv)
- = do { checkTyVarInScope tv
+ = do { checkTyCoVarInScope tv
; return (tyVarKind tv) }
lintType ty@(AppTy t1 t2)
= lint_ty_app ty (tyConKind funTyCon) [t1,t2]
lintType ty@(TyConApp tc tys)
+ | tc `hasKey` eqPredPrimTyConKey -- See Note [The (~) TyCon] in TysPrim
+ = lint_eq_pred ty tys
| tyConHasKind tc
= lint_ty_app ty (tyConKind tc) tys
| otherwise
lintType (PredTy (IParam _ p_ty))
= lintType p_ty
-lintType ty@(PredTy (EqPred {}))
- = failWithL (badEq ty)
+lintType ty@(PredTy (EqPred t1 t2))
+ = do { k1 <- lintType t1
+ ; k2 <- lintType t2
+ ; unless (k1 `eqKind` k2)
+ (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:")
+ , nest 2 (ppr ty) ]))
+ ; return unliftedTypeKind }
----------------
lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
lint_ty_app ty k tys
= do { ks <- mapM lintType tys
; lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k ks }
-
+
+lint_eq_pred :: Type -> [OutType] -> LintM Kind
+lint_eq_pred ty arg_tys
+ | [ty1,ty2] <- arg_tys
+ = do { k1 <- lintType ty1
+ ; k2 <- lintType ty2
+ ; checkL (k1 `eqKind` k2)
+ (ptext (sLit "Mismatched arg kinds:") <+> ppr ty)
+ ; return unliftedTypeKind }
+ | otherwise
+ = failWithL (ptext (sLit "Unsaturated (~) type") <+> ppr ty)
+
----------------
check_co_app :: Coercion -> Kind -> [OutType] -> LintM ()
check_co_app ty k tys
Just (kfa, kfb) -> do { unless (k `isSubKind` kfa)
(addErrL fail_msg)
; go kfb ks }
---------------
-badEq :: Type -> SDoc
-badEq ty = hang (ptext (sLit "Unexpected equality predicate:"))
- 1 (quotes (ppr ty))
\end{code}
%************************************************************************
| ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
| TopLevelBindings
| InType Type -- Inside a type
- | InCoercion Coercion -- Inside a type
+ | InCo Coercion -- Inside a coercion
\end{code}
getTvSubst :: LintM TvSubst
getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
-applySubst :: Type -> LintM Type
-applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
+applySubstTy :: Type -> LintM Type
+applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) }
+
+applySubstCo :: Coercion -> LintM Coercion
+applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) }
extendSubstL :: TyVar -> Type -> LintM a -> LintM a
extendSubstL tv ty m
- = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
+ = LintM (\ loc subst errs -> unLintM m loc (Type.extendTvSubst subst tv ty) errs)
\end{code}
\begin{code}
msg = ptext (sLit "is out of scope inside info for") <+>
ppr binder
-checkTyVarInScope :: TyVar -> LintM ()
-checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv
+checkTyCoVarInScope :: TyCoVar -> LintM ()
+checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v
checkInScope :: SDoc -> Var -> LintM ()
checkInScope loc_msg var =
-- check ty2 is subtype of ty1 (ie, has same structure but usage
-- annotations need only be consistent, not equal)
-- Assumes ty1,ty2 are have alrady had the substitution applied
-checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
+checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
\end{code}
%************************************************************************
= (noSrcLoc, empty)
dumpLoc (InType ty)
= (noSrcLoc, text "In the type" <+> quotes (ppr ty))
-dumpLoc (InCoercion ty)
- = (noSrcLoc, text "In the coercion" <+> quotes (ppr ty))
+dumpLoc (InCo co)
+ = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))
pp_binders :: [Var] -> SDoc
pp_binders bs = sep (punctuate comma (map pp_binder bs))
hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
hang (ptext (sLit "Arg:")) 4 (ppr arg)]
-mkTyVarLetErr :: TyVar -> Type -> Message
-mkTyVarLetErr tyvar ty
- = vcat [ptext (sLit "Bad `let' binding for type or coercion variable:"),
- hang (ptext (sLit "Type/coercion variable:"))
- 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
- hang (ptext (sLit "Arg type/coercion:"))
- 4 (ppr ty)]
-
-mkKindErrMsg :: TyVar -> Type -> Message
-mkKindErrMsg tyvar arg_ty
- = vcat [ptext (sLit "Kinds don't match in type application:"),
- hang (ptext (sLit "Type variable:"))
- 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
- hang (ptext (sLit "Arg type:"))
- 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
-
-mkCoAppErrMsg :: TyVar -> Type -> Message
-mkCoAppErrMsg tyvar arg_ty
- = vcat [ptext (sLit "Kinds don't match in coercion application:"),
- hang (ptext (sLit "Coercion variable:"))
+mkLetErr :: TyVar -> CoreExpr -> Message
+mkLetErr bndr rhs
+ = vcat [ptext (sLit "Bad `let' binding:"),
+ hang (ptext (sLit "Variable:"))
+ 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)),
+ hang (ptext (sLit "Rhs:"))
+ 4 (ppr rhs)]
+
+mkTyCoAppErrMsg :: TyVar -> Coercion -> Message
+mkTyCoAppErrMsg tyvar arg_co
+ = vcat [ptext (sLit "Kinds don't match in lifted coercion application:"),
+ hang (ptext (sLit "Type variable:"))
4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
hang (ptext (sLit "Arg coercion:"))
- 4 (ppr arg_ty <+> dcolon <+> pprEqPred (coercionKind arg_ty))]
+ 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))]
mkTyAppMsg :: Type -> Type -> Message
mkTyAppMsg ty arg_ty
hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)]
]
+
+mkKindErrMsg :: TyVar -> Type -> Message
+mkKindErrMsg tyvar arg_ty
+ = vcat [ptext (sLit "Kinds don't match in type application:"),
+ hang (ptext (sLit "Type variable:"))
+ 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
+ hang (ptext (sLit "Arg type:"))
+ 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
+
mkArityMsg :: Id -> Message
mkArityMsg binder
= vcat [hsep [ptext (sLit "Demand type has "),
= hang (ptext (sLit "Duplicate top-level variables with the same qualified name"))
2 (ppr vars)
\end{code}
+
+-------------- DEAD CODE -------------------
+
+-------------------
+checkCoKind :: CoVar -> OutCoercion -> LintM ()
+-- Both args have had substitution applied
+checkCoKind covar arg_co
+ = do { (s2,t2) <- lintCoercion arg_co
+ ; unless (s1 `eqType` s2 && t1 `coreEqType` t2)
+ (addErrL (mkCoAppErrMsg covar arg_co)) }
+ where
+ (s1,t1) = coVarKind covar
+
+lintCoVarKind :: OutCoVar -> LintM ()
+-- Check the kind of a coercion binder
+lintCoVarKind tv
+ = do { (ty1,ty2) <- lintSplitCoVar tv
+ ; lintEqType ty1 ty2
+
+
+-------------------
+lintSplitCoVar :: CoVar -> LintM (Type,Type)
+lintSplitCoVar cv
+ = case coVarKind_maybe cv of
+ Just ts -> return ts
+ Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:")
+ , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))])
+
+mkCoVarLetErr :: CoVar -> Coercion -> Message
+mkCoVarLetErr covar co
+ = vcat [ptext (sLit "Bad `let' binding for coercion variable:"),
+ hang (ptext (sLit "Coercion variable:"))
+ 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)),
+ hang (ptext (sLit "Arg coercion:"))
+ 4 (ppr co)]
+
+mkCoAppErrMsg :: CoVar -> Coercion -> Message
+mkCoAppErrMsg covar arg_co
+ = vcat [ptext (sLit "Kinds don't match in coercion application:"),
+ hang (ptext (sLit "Coercion variable:"))
+ 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)),
+ hang (ptext (sLit "Arg coercion:"))
+ 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))]
+
+
+mkCoAppMsg :: Type -> Coercion -> Message
+mkCoAppMsg ty arg_co
+ = vcat [text "Illegal type application:",
+ hang (ptext (sLit "exp type:"))
+ 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
+ hang (ptext (sLit "arg type:"))
+ 4 (ppr arg_co <+> dcolon <+> ppr (coercionKind arg_co))]
+
import ErrUtils
import DynFlags
import Util
+import Pair
import Outputable
import MonadUtils
import FastString
weaker guarantee of no clashes which the simplifier provides.
And that is what the code generator needs.
- We don't clone TyVars. The code gen doesn't need that,
+ We don't clone TyVars or CoVars. The code gen doesn't need that,
and doing so would be tiresome because then we'd need
- to substitute in types.
+ to substitute in types and coercions.
7. Give each dynamic CCall occurrence a fresh unique; this is
Here is the syntax of the Core produced by CorePrep:
Trivial expressions
- triv ::= lit | var | triv ty | /\a. triv | triv |> co
+ triv ::= lit | var
+ | triv ty | /\a. triv
+ | truv co | /\c. triv | triv |> co
Applications
- app ::= lit | var | app triv | app ty | app |> co
+ app ::= lit | var | app triv | app ty | app co | app |> co
Expressions
body ::= app
| let(rec) x = rhs in body -- Boxed only
| case body of pat -> body
- | /\a. body
+ | /\a. body | /\c. body
| body |> co
- Right hand sides (only place where lambdas can occur)
+ Right hand sides (only place where value lambdas can occur)
rhs ::= /\a.rhs | \x.rhs | body
We define a synonym for each of these non-terminals. Functions
-- For example
-- f (g x) ===> ([v = g x], f v)
-cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
-cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr)
-cpeRhsE env expr@(Var {}) = cpeApp env expr
+cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)
+cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
+cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
+cpeRhsE env expr@(Var {}) = cpeApp env expr
cpeRhsE env (Var f `App` _ `App` arg)
| f `hasKey` lazyIdKey -- Replace (lazy a) by a
rhsToBody expr@(Lam {})
| Just no_lam_result <- tryEtaReducePrep bndrs body
= return (emptyFloats, no_lam_result)
- | all isTyCoVar bndrs -- Type lambdas are ok
+ | all isTyVar bndrs -- Type lambdas are ok
= return (emptyFloats, expr)
| otherwise -- Some value lambdas
= do { fn <- newVar (exprType expr)
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
+ collect_args (App fun arg@(Coercion arg_co)) depth
+ = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
+ ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) }
+
collect_args (App fun arg) depth
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
; let
-- partial application might be seq'd
collect_args (Cast fun co) depth
- = do { let (_ty1,ty2) = coercionKind co
+ = do { let Pair _ty1 ty2 = coercionKind co
; (fun', hd, _, floats, ss) <- collect_args fun depth
; return (Cast fun' co, hd, ty2, floats, ss) }
-- Version that doesn't consider an scc annotation to be trivial.
cpe_ExprIsTrivial (Var _) = True
cpe_ExprIsTrivial (Type _) = True
+cpe_ExprIsTrivial (Coercion _) = True
cpe_ExprIsTrivial (Lit _) = True
cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Note n e) = notSccNote n && cpe_ExprIsTrivial e
cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e
-cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body
+cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
cpe_ExprIsTrivial _ = False
\end{code}
cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
cloneBndr env bndr
- | isLocalId bndr
+ | isLocalId bndr, not (isCoVar bndr)
= do bndr' <- setVarUnique bndr <$> getUniqueM
-- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
| otherwise -- Top level things, which we don't want
-- to clone, have become GlobalIds by now
- -- And we don't clone tyvars
+ -- And we don't clone tyvars, or coercion variables
= return (env, bndr)
-- ** Substituting into expressions and related types
deShadowBinds, substSpec, substRulesForImportedIds,
- substTy, substExpr, substExprSC, substBind, substBindSC,
+ substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
substUnfolding, substUnfoldingSC,
- substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc,
+ substUnfoldingSource, lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc,
-- ** Operations on substitutions
emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,
extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
- extendSubst, extendSubstList, zapSubstEnv,
+ extendCvSubst, extendCvSubstList,
+ extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,
addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds,
isInScope, setInScope,
delBndr, delBndrs,
import CoreSyn
import CoreFVs
import CoreUtils
-import PprCore
import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
import qualified Type
-import Type ( Type, TvSubst(..), TvSubstEnv )
-import Coercion ( isIdentityCoercion )
+import qualified Coercion
+
+ -- We are defining local versions
+import Type hiding ( substTy, extendTvSubst, extendTvSubstList
+ , isInScope, substTyVarBndr )
+import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr )
+
import OptCoercion ( optCoercion )
+import PprCore ( pprCoreBindings )
import VarSet
import VarEnv
import Id
import Name ( Name )
-import Var ( Var, TyVar, setVarUnique )
+import Var
import IdInfo
import Unique
import UniqSupply
= Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/
-- applying the substitution
IdSubstEnv -- Substitution for Ids
- TvSubstEnv -- Substitution for TyVars
+ TvSubstEnv -- Substitution from TyVars to Types
+ CvSubstEnv -- Substitution from TyCoVars to Coercions
-- INVARIANT 1: See #in_scope_invariant#
-- This is what lets us deal with name capture properly
* In substIdBndr, we extend the IdSubstEnv only when the unique changes
+* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty,
+ substExpr does nothing (Note that the above rule for substIdBndr
+ maintains this property. If the incoming envts are both empty, then
+ substituting the type and IdInfo can't change anything.)
+
* In lookupIdSubst, we *must* look up the Id in the in-scope set, because
it may contain non-trivial changes. Example:
(/\a. \x:a. ...x...) Int
* (However, we don't need to do so for expressions found in the IdSubst
itself, whose range is assumed to be correct wrt the in-scope set.)
-Why do we make a different choice for the IdSubstEnv than the TvSubstEnv?
+Why do we make a different choice for the IdSubstEnv than the
+TvSubstEnv and CvSubstEnv?
* For Ids, we change the IdInfo all the time (e.g. deleting the
unfolding), and adding it back later, so using the TyVar convention
----------------------------
isEmptySubst :: Subst -> Bool
-isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env
+isEmptySubst (Subst _ id_env tv_env cv_env)
+ = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env
emptySubst :: Subst
-emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv
+emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv
mkEmptySubst :: InScopeSet -> Subst
-mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv
-
-mkSubst :: InScopeSet -> TvSubstEnv -> IdSubstEnv -> Subst
-mkSubst in_scope tvs ids = Subst in_scope ids tvs
-
--- getTvSubst :: Subst -> TvSubst
--- getTvSubst (Subst in_scope _ tv_env) = TvSubst in_scope tv_env
+mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
--- getTvSubstEnv :: Subst -> TvSubstEnv
--- getTvSubstEnv (Subst _ _ tv_env) = tv_env
---
--- setTvSubstEnv :: Subst -> TvSubstEnv -> Subst
--- setTvSubstEnv (Subst in_scope ids _) tvs = Subst in_scope ids tvs
+mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
+mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs
-- | Find the in-scope set: see "CoreSubst#in_scope_invariant"
substInScope :: Subst -> InScopeSet
-substInScope (Subst in_scope _ _) = in_scope
+substInScope (Subst in_scope _ _ _) = in_scope
-- | Remove all substitutions for 'Id's and 'Var's that might have been built up
-- while preserving the in-scope set
zapSubstEnv :: Subst -> Subst
-zapSubstEnv (Subst in_scope _ _) = Subst in_scope emptyVarEnv emptyVarEnv
+zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is
-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
extendIdSubst :: Subst -> Id -> CoreExpr -> Subst
-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
-extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs
+extendIdSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope (extendVarEnv ids v r) tvs cvs
-- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst'
extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst
-extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs
+extendIdSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs cvs
-- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is
-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
extendTvSubst :: Subst -> TyVar -> Type -> Subst
-extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r)
+extendTvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids (extendVarEnv tvs v r) cvs
-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst'
extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst
-extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs)
+extendTvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) cvs
--- | Add a substitution for a 'TyVar' or 'Id' as appropriate to the 'Var' being added. See also
--- 'extendIdSubst' and 'extendTvSubst'
-extendSubst :: Subst -> Var -> CoreArg -> Subst
-extendSubst (Subst in_scope ids tvs) tv (Type ty)
- = ASSERT( isTyCoVar tv ) Subst in_scope ids (extendVarEnv tvs tv ty)
-extendSubst (Subst in_scope ids tvs) id expr
- = ASSERT( isId id ) Subst in_scope (extendVarEnv ids id expr) tvs
+-- | Add a substitution from a 'TyCoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is
+-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
+extendCvSubst :: Subst -> TyCoVar -> Coercion -> Subst
+extendCvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids tvs (extendVarEnv cvs v r)
+
+-- | Adds multiple 'TyCoVar' -> 'Coercion' substitutions to the
+-- 'Subst': see also 'extendCvSubst'
+extendCvSubstList :: Subst -> [(TyCoVar,Coercion)] -> Subst
+extendCvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids tvs (extendVarEnvList cvs prs)
--- | Add a substitution for a 'TyVar' or 'Id' as appropriate to all the 'Var's being added. See also 'extendSubst'
+-- | Add a substitution appropriate to the thing being substituted
+-- (whether an expression, type, or coercion). See also
+-- 'extendIdSubst', 'extendTvSubst', and 'extendCvSubst'.
+extendSubst :: Subst -> Var -> CoreArg -> Subst
+extendSubst subst var arg
+ = case arg of
+ Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty
+ Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co
+ _ -> ASSERT( isId var ) extendIdSubst subst var arg
+
+extendSubstWithVar :: Subst -> Var -> Var -> Subst
+extendSubstWithVar subst v1 v2
+ | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2)
+ | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2)
+ | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2)
+
+-- | Add a substitution as appropriate to each of the terms being
+-- substituted (whether expressions, types, or coercions). See also
+-- 'extendSubst'.
extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst
extendSubstList subst [] = subst
extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs
-- | Find the substitution for an 'Id' in the 'Subst'
lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr
-lookupIdSubst doc (Subst in_scope ids _) v
+lookupIdSubst doc (Subst in_scope ids _ _) v
| not (isLocalId v) = Var v
| Just e <- lookupVarEnv ids v = e
| Just v' <- lookupInScope in_scope v = Var v'
-- | Find the substitution for a 'TyVar' in the 'Subst'
lookupTvSubst :: Subst -> TyVar -> Type
-lookupTvSubst (Subst _ _ tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
+lookupTvSubst (Subst _ _ tvs _) v = ASSERT( isTyVar v) lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
+
+-- | Find the coercion substitution for a 'TyCoVar' in the 'Subst'
+lookupCvSubst :: Subst -> CoVar -> Coercion
+lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) lookupVarEnv cvs v `orElse` mkCoVarCo v
delBndr :: Subst -> Var -> Subst
-delBndr (Subst in_scope tvs ids) v
- | isId v = Subst in_scope tvs (delVarEnv ids v)
- | otherwise = Subst in_scope (delVarEnv tvs v) ids
+delBndr (Subst in_scope ids tvs cvs) v
+ | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)
+ | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs
+ | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs
delBndrs :: Subst -> [Var] -> Subst
-delBndrs (Subst in_scope tvs ids) vs
- = Subst in_scope (delVarEnvList tvs vs_tv) (delVarEnvList ids vs_id)
- where
- (vs_id, vs_tv) = partition isId vs
+delBndrs (Subst in_scope ids tvs cvs) vs
+ = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs)
+ -- Easist thing is just delete all from all!
-- | Simultaneously substitute for a bunch of variables
-- No left-right shadowing
mkOpenSubst in_scope pairs = Subst in_scope
(mkVarEnv [(id,e) | (id, e) <- pairs, isId id])
(mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
+ (mkVarEnv [(v,co) | (v, Coercion co) <- pairs])
------------------------------
isInScope :: Var -> Subst -> Bool
-isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
+isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope
-- | Add the 'Var' to the in-scope set, but do not remove
-- any existing substitutions for it
addInScopeSet :: Subst -> VarSet -> Subst
-addInScopeSet (Subst in_scope ids tvs) vs
- = Subst (in_scope `extendInScopeSetSet` vs) ids tvs
+addInScopeSet (Subst in_scope ids tvs cvs) vs
+ = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs
-- | Add the 'Var' to the in-scope set: as a side effect,
-- and remove any existing substitutions for it
extendInScope :: Subst -> Var -> Subst
-extendInScope (Subst in_scope ids tvs) v
+extendInScope (Subst in_scope ids tvs cvs) v
= Subst (in_scope `extendInScopeSet` v)
- (ids `delVarEnv` v) (tvs `delVarEnv` v)
+ (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)
-- | Add the 'Var's to the in-scope set: see also 'extendInScope'
extendInScopeList :: Subst -> [Var] -> Subst
-extendInScopeList (Subst in_scope ids tvs) vs
+extendInScopeList (Subst in_scope ids tvs cvs) vs
= Subst (in_scope `extendInScopeSetList` vs)
- (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs)
+ (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs)
-- | Optimized version of 'extendInScopeList' that can be used if you are certain
--- all the things being added are 'Id's and hence none are 'TyVar's
+-- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's
extendInScopeIds :: Subst -> [Id] -> Subst
-extendInScopeIds (Subst in_scope ids tvs) vs
+extendInScopeIds (Subst in_scope ids tvs cvs) vs
= Subst (in_scope `extendInScopeSetList` vs)
- (ids `delVarEnvList` vs) tvs
+ (ids `delVarEnvList` vs) tvs cvs
setInScope :: Subst -> InScopeSet -> Subst
-setInScope (Subst _ ids tvs) in_scope = Subst in_scope ids tvs
+setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs
\end{code}
Pretty printing, for debugging only
\begin{code}
instance Outputable Subst where
- ppr (Subst in_scope ids tvs)
+ ppr (Subst in_scope ids tvs cvs)
= ptext (sLit "<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
$$ ptext (sLit " IdSubst =") <+> ppr ids
$$ ptext (sLit " TvSubst =") <+> ppr tvs
+ $$ ptext (sLit " CvSubst =") <+> ppr cvs
<> char '>'
\end{code}
where
go (Var v) = lookupIdSubst (text "subst_expr") subst v
go (Type ty) = Type (substTy subst ty)
+ go (Coercion co) = Coercion (substCo subst co)
go (Lit lit) = Lit lit
go (App fun arg) = App (go fun) (go arg)
go (Note note e) = Note (go_note note) (go e)
- go (Cast e co) = Cast (go e) (optCoercion (getTvSubst subst) co)
+ go (Cast e co) = Cast (go e) (substCo subst co)
-- Do not optimise even identity coercions
-- Reason: substitution applies to the LHS of RULES, and
-- if you "optimise" an identity coercion, you may
-- 'IdInfo' is preserved by this process, although it is substituted into appropriately.
substBndr :: Subst -> Var -> (Subst, Var)
substBndr subst bndr
- | isTyCoVar bndr = substTyVarBndr subst bndr
- | otherwise = substIdBndr (text "var-bndr") subst subst bndr
+ | isTyVar bndr = substTyVarBndr subst bndr
+ | isCoVar bndr = substCoVarBndr subst bndr
+ | otherwise = substIdBndr (text "var-bndr") subst subst bndr
-- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right
substBndrs :: Subst -> [Var] -> (Subst, [Var])
-> (Subst, Id) -- ^ Transformed pair
-- NB: unfolding may be zapped
-substIdBndr _doc rec_subst subst@(Subst in_scope env tvs) old_id
+substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
= -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $
- (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
+ (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)
where
id1 = uniqAway in_scope old_id -- id1 is cloned if necessary
id2 | no_type_change = id1
-> Subst -> (Id, Unique) -- Substitition and Id to transform
-> (Subst, Id) -- Transformed pair
-clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
- = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
+clone_id rec_subst subst@(Subst in_scope env tvs cvs) (old_id, uniq)
+ = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)
where
id1 = setVarUnique old_id uniq
id2 = substIdType subst id1
%************************************************************************
%* *
- Types
+ Types and Coercions
%* *
%************************************************************************
-For types we just call the corresponding function in Type, but we have
-to repackage the substitution, from a Subst to a TvSubst
+For types and coercions we just call the corresponding functions in
+Type and Coercion, but we have to repackage the substitution, from a
+Subst to a TvSubst.
\begin{code}
substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar)
-substTyVarBndr (Subst in_scope id_env tv_env) tv
+substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv
= case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
(TvSubst in_scope' tv_env', tv')
- -> (Subst in_scope' id_env tv_env', tv')
+ -> (Subst in_scope' id_env tv_env' cv_env, tv')
+
+substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar)
+substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv
+ = case Coercion.substCoVarBndr (CvSubst in_scope tv_env cv_env) cv of
+ (CvSubst in_scope' tv_env' cv_env', cv')
+ -> (Subst in_scope' id_env tv_env' cv_env', cv')
-- | See 'Type.substTy'
substTy :: Subst -> Type -> Type
substTy subst ty = Type.substTy (getTvSubst subst) ty
getTvSubst :: Subst -> TvSubst
-getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env
+getTvSubst (Subst in_scope _ tenv _) = TvSubst in_scope tenv
+
+getCvSubst :: Subst -> CvSubst
+getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv
+
+-- | See 'Coercion.substCo'
+substCo :: Subst -> Coercion -> Coercion
+substCo subst co = Coercion.substCo (getCvSubst subst) co
\end{code}
\begin{code}
substIdType :: Subst -> Id -> Id
-substIdType subst@(Subst _ _ tv_env) id
- | isEmptyVarEnv tv_env || isEmptyVarSet (Type.tyVarsOfType old_ty) = id
+substIdType subst@(Subst _ _ tv_env cv_env) id
+ | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id
| otherwise = setIdType id (substTy subst old_ty)
-- The tyVarsOfType is cheaper than it looks
-- because we cache the free tyvars of the type
substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
substIdInfo subst new_id info
| nothing_to_do = Nothing
- | otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules
+ | otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules
`setUnfoldingInfo` substUnfolding subst old_unf)
where
old_rules = specInfo info
-------------------
substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource
-substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr)
+substUnfoldingSource (Subst in_scope ids _ _) (InlineWrapper wkr)
| Just wkr_expr <- lookupVarEnv ids wkr
= case wkr_expr of
Var w1 -> InlineWrapper w1
where
subst_ru_fn = const (idName new_id)
new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules)
- (substVarSet subst rhs_fvs)
+ (substVarSet subst rhs_fvs)
------------------
substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
-- - Rules for *local* Ids are in the IdInfo for that Id,
-- and the ru_fn field is simply replaced by the new name
-- of the Id
-
substRule _ _ rule@(BuiltinRule {}) = rule
substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
, ru_fn = fn_name, ru_rhs = rhs
------------------
substVarSet :: Subst -> VarSet -> VarSet
-substVarSet subst fvs
+substVarSet subst fvs
= foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
where
subst_fv subst fv
-- won't *be* substituting for x if it occurs inside a
-- lambda.
--
- -- It's a bit painful to call exprFreeVars, because it makes
+ -- It's a bit painful to call exprFreeVars, because it makes
-- three passes instead of two (occ-anal, and go)
simpleOptExprWith :: Subst -> InExpr -> OutExpr
-- In these functions the substitution maps InVar -> OutExpr
----------------------
-simple_opt_expr :: Subst -> InExpr -> OutExpr
-simple_opt_expr subst expr
+simple_opt_expr, simple_opt_expr' :: Subst -> InExpr -> OutExpr
+simple_opt_expr s e = simple_opt_expr' s e
+
+simple_opt_expr' subst expr
= go expr
where
go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v
go (App e1 e2) = simple_app subst e1 [go e2]
- go (Type ty) = Type (substTy subst ty)
+ go (Type ty) = Type (substTy subst ty)
+ go (Coercion co) = Coercion (optCoercion (getCvSubst subst) co)
go (Lit lit) = Lit lit
go (Note note e) = Note note (go e)
- go (Cast e co) | isIdentityCoercion co' = go e
- | otherwise = Cast (go e) co'
+ go (Cast e co) | isReflCo co' = go e
+ | otherwise = Cast (go e) co'
where
- co' = substTy subst co
+ co' = optCoercion (getCvSubst subst) co
go (Let bind body) = case simple_opt_bind subst bind of
(subst', Nothing) -> simple_opt_expr subst' body
= foldl App (simple_opt_expr subst e) as
----------------------
-simple_opt_bind :: Subst -> CoreBind -> (Subst, Maybe CoreBind)
-simple_opt_bind subst (Rec prs)
- = (subst'', Just (Rec (reverse rev_prs')))
+simple_opt_bind,simple_opt_bind' :: Subst -> CoreBind -> (Subst, Maybe CoreBind)
+simple_opt_bind s b -- Can add trace stuff here
+ = simple_opt_bind' s b
+
+simple_opt_bind' subst (Rec prs)
+ = (subst'', res_bind)
where
+ res_bind = Just (Rec (reverse rev_prs'))
(subst', bndrs') = subst_opt_bndrs subst (map fst prs)
(subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
do_pr (subst, prs) ((b,r), b')
= case maybe_substitute subst b r2 of
Just subst' -> (subst', prs)
- Nothing -> (subst, (b2,r2):prs)
+ Nothing -> (subst, (b2,r2):prs)
where
b2 = add_info subst b b'
r2 = simple_opt_expr subst r
-simple_opt_bind subst (NonRec b r)
+simple_opt_bind' subst (NonRec b r)
= case maybe_substitute subst b r' of
Just ext_subst -> (ext_subst, Nothing)
Nothing -> (subst', Just (NonRec b2 r'))
-- or returns Nothing
maybe_substitute subst b r
| Type ty <- r -- let a::* = TYPE ty in <body>
- = ASSERT( isTyCoVar b )
+ = ASSERT( isTyVar b )
Just (extendTvSubst subst b ty)
- | isId b -- let x = e in <body>
+ | Coercion co <- r
+ = ASSERT( isCoVar b )
+ Just (extendCvSubst subst b co)
+
+ | isId b -- let x = e in <body>
, safe_to_inline (idOccInfo b)
, isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt]
, not (isStableUnfolding (idUnfolding b))
----------------------
subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar)
subst_opt_bndr subst bndr
- | isTyCoVar bndr = substTyVarBndr subst bndr
- | otherwise = subst_opt_id_bndr subst bndr
+ | isTyVar bndr = substTyVarBndr subst bndr
+ | isCoVar bndr = substCoVarBndr subst bndr
+ | otherwise = subst_opt_id_bndr subst bndr
subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId)
-- Nuke all fragile IdInfo, unfolding, and RULES;
-- it gets added back later by add_info
-- Rather like SimplEnv.substIdBndr
--
--- It's important to zap fragile OccInfo (which CoreSubst.SubstIdBndr
+-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr
-- carefully does not do) because simplOptExpr invalidates it
-subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst) old_id
- = (Subst new_in_scope new_id_subst tv_subst, new_id)
+subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id
+ = (Subst new_in_scope new_id_subst tv_subst cv_subst, new_id)
where
id1 = uniqAway in_scope old_id
id2 = setIdType id1 (substTy subst (idType old_id))
----------------------
add_info :: Subst -> InVar -> OutVar -> OutVar
-add_info subst old_bndr new_bndr
- | isTyCoVar old_bndr = new_bndr
- | otherwise = maybeModifyIdInfo mb_new_info new_bndr
+add_info subst old_bndr new_bndr
+ | isTyVar old_bndr = new_bndr
+ | otherwise = maybeModifyIdInfo mb_new_info new_bndr
where
mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
\end{code}
When inlining 'foo' in 'bar' we want the let-binding for 'inner'
to remain visible until Phase 1
+
-- ** 'Expr' construction
mkLets, mkLams,
- mkApps, mkTyApps, mkVarApps,
+ mkApps, mkTyApps, mkCoApps, mkVarApps,
mkIntLit, mkIntLitInt,
mkWordLit, mkWordLitWord,
mkFloatLit, mkFloatLitFloat,
mkDoubleLit, mkDoubleLitDouble,
- mkConApp, mkTyBind,
+ mkConApp, mkTyBind, mkCoBind,
varToCoreExpr, varsToCoreExprs,
- isTyCoVar, isId, cmpAltCon, cmpAlt, ltAlt,
+ isId, cmpAltCon, cmpAlt, ltAlt,
-- ** Simple 'Expr' access functions and predicates
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
collectArgs, coreExprCc, flattenBinds,
- isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
- notSccNote,
+ isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount,
+ isRuntimeArg, isRuntimeVar,
+ notSccNote,
-- * Unfolding data types
Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..),
import Data.Data
import Data.Word
-infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`
+infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
\end{code}
| Type Type -- ^ A type: this should only show up at the top
-- level of an Arg
+
+ | Coercion Coercion -- ^ A coercion
deriving (Data, Typeable)
-- | Type synonym for expressions that occur in function argument positions.
mkApps :: Expr b -> [Arg b] -> Expr b
-- | Apply a list of type argument expressions to a function expression in a nested fashion
mkTyApps :: Expr b -> [Type] -> Expr b
+-- | Apply a list of coercion argument expressions to a function expression in a nested fashion
+mkCoApps :: Expr b -> [Coercion] -> Expr b
-- | Apply a list of type or value variables to a function expression in a nested fashion
mkVarApps :: Expr b -> [Var] -> Expr b
-- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
mkApps f args = foldl App f args
mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
+mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args
mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
mkConApp con args = mkApps (Var (dataConWorkId con)) args
mkTyBind :: TyVar -> Type -> CoreBind
mkTyBind tv ty = NonRec tv (Type ty)
+-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
+-- this can only be used to bind something in a non-recursive @let@ expression
+mkCoBind :: CoVar -> Coercion -> CoreBind
+mkCoBind cv co = NonRec cv (Coercion co)
+
-- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
varToCoreExpr :: CoreBndr -> Expr b
-varToCoreExpr v | isId v = Var v
- | otherwise = Type (mkTyVarTy v)
+varToCoreExpr v | isTyVar v = Type (mkTyVarTy v)
+ | isCoVar v = Coercion (mkCoVarCo v)
+ | otherwise = ASSERT( isId v ) Var v
varsToCoreExprs :: [CoreBndr] -> [Expr b]
varsToCoreExprs vs = map varToCoreExpr vs
collectTyBinders expr
= go [] expr
where
- go tvs (Lam b e) | isTyCoVar b = go (b:tvs) e
+ go tvs (Lam b e) | isTyVar b = go (b:tvs) e
go tvs e = (reverse tvs, e)
collectValBinders expr
isRuntimeArg :: CoreExpr -> Bool
isRuntimeArg = isValArg
--- | Returns @False@ iff the expression is a 'Type' expression at its top level
+-- | Returns @False@ iff the expression is a 'Type' or 'Coercion'
+-- expression at its top level
isValArg :: Expr b -> Bool
-isValArg (Type _) = False
-isValArg _ = True
+isValArg e = not (isTypeArg e)
+
+-- | Returns @True@ iff the expression is a 'Type' or 'Coercion'
+-- expression at its top level
+isTyCoArg :: Expr b -> Bool
+isTyCoArg (Type {}) = True
+isTyCoArg (Coercion {}) = True
+isTyCoArg _ = False
--- | Returns @True@ iff the expression is a 'Type' expression at its top level
+-- | Returns @True@ iff the expression is a 'Type' expression at its
+-- top level. Note this does NOT include 'Coercion's.
isTypeArg :: Expr b -> Bool
-isTypeArg (Type _) = True
-isTypeArg _ = False
+isTypeArg (Type {}) = True
+isTypeArg _ = False
-- | The number of binders that bind values rather than types
valBndrCount :: [CoreBndr] -> Int
seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
seqExpr (Let b e) = seqBind b `seq` seqExpr e
seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
-seqExpr (Cast e co) = seqExpr e `seq` seqType co
+seqExpr (Cast e co) = seqExpr e `seq` seqCo co
seqExpr (Note n e) = seqNote n `seq` seqExpr e
-seqExpr (Type t) = seqType t
+seqExpr (Type t) = seqType t
+seqExpr (Coercion co) = seqCo co
seqExprs :: [CoreExpr] -> ()
seqExprs [] = ()
| AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
| AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
| AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
- | AnnCast (AnnExpr bndr annot) Coercion
+ | AnnCast (AnnExpr bndr annot) (annot, Coercion)
+ -- Put an annotation on the (root of) the coercion
| AnnNote Note (AnnExpr bndr annot)
| AnnType Type
+ | AnnCoercion Coercion
-- | A clone of the 'Alt' type but allowing annotation at every tree node
type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
deAnnotate (_, e) = deAnnotate' e
deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
-deAnnotate' (AnnType t) = Type t
+deAnnotate' (AnnType t) = Type t
+deAnnotate' (AnnCoercion co) = Coercion co
deAnnotate' (AnnVar v) = Var v
deAnnotate' (AnnLit lit) = Lit lit
deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
-deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
+deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co
deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
deAnnotate' (AnnLet bind body)
import CoreArity
import Id
import IdInfo
-import TcType( tidyType, tidyTyVarBndr )
+import TcType( tidyType, tidyCo, tidyTyVarBndr )
import Var
import VarEnv
import UniqFM
------------ Expressions --------------
tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr
tidyExpr env (Var v) = Var (tidyVarOcc env v)
-tidyExpr env (Type ty) = Type (tidyType env ty)
+tidyExpr env (Type ty) = Type (tidyType env ty)
+tidyExpr env (Coercion co) = Coercion (tidyCo env co)
tidyExpr _ (Lit lit) = Lit lit
tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
-tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyType env co)
+tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co)
tidyExpr env (Let b e)
= tidyBind env b =: \ (env', b') ->
-- tidyBndr is used for lambda and case binders
tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
tidyBndr env var
- | isTyCoVar var = tidyTyVarBndr env var
+ | isTyVar var = tidyTyVarBndr env var
| otherwise = tidyIdBndr env var
tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
import VarEnv ( mkInScopeSet )
import Bag
import Util
+import Pair
import FastTypes
import FastString
import Outputable
+import ForeignCall
+
import Data.Maybe
\end{code}
mkCompulsoryUnfolding :: CoreExpr -> Unfolding
mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
= mkCoreUnfolding InlineCompulsory True
- expr 0 -- Arity of unfolding doesn't matter
+ (simpleOptExpr expr) 0 -- Arity of unfolding doesn't matter
(UnfWhen unSaturatedOk boringCxtOk)
mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding
a function call to account for. Notice also that constructor applications
are very cheap, because exposing them to a caller is so valuable.
+[25/5/11] All sizes are now multiplied by 10, except for primops.
+This makes primops look cheap, and seems to be almost unversally
+beneficial. Done partly as a result of #4978.
Note [Do not inline top-level bottoming functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- See Note [INLINE for small functions]
uncondInline arity size
| arity == 0 = size == 0
- | otherwise = size <= arity + 1
+ | otherwise = size <= 10 * (arity + 1)
\end{code}
size_up (Cast e _) = size_up e
size_up (Note _ e) = size_up e
size_up (Type _) = sizeZero -- Types cost nothing
+ size_up (Coercion _) = sizeZero
size_up (Lit lit) = sizeN (litSize lit)
size_up (Var f) = size_up_call f [] -- Make sure we get constructor
-- discounts even on nullary constructors
size_up (App fun (Type _)) = size_up fun
+ size_up (App fun (Coercion _)) = size_up fun
size_up (App fun arg) = size_up arg `addSizeNSD`
size_up_app fun [arg]
- size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 1)
+ size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 10)
| otherwise = size_up e
size_up (Let (NonRec binder rhs) body)
= size_up rhs `addSizeNSD`
size_up body `addSizeN`
- (if isUnLiftedType (idType binder) then 0 else 1)
+ (if isUnLiftedType (idType binder) then 0 else 10)
-- For the allocation
-- If the binder has an unlifted type there is no allocation
size_up (Let (Rec pairs) body)
= foldr (addSizeNSD . size_up . snd)
- (size_up body `addSizeN` length pairs) -- (length pairs) for the allocation
+ (size_up body `addSizeN` (10 * length pairs)) -- (length pairs) for the allocation
pairs
size_up (Case (Var v) _ _ alts)
-- the case when we are scrutinising an argument variable
alts_size (SizeIs tot tot_disc tot_scrut) -- Size of all alternatives
(SizeIs max _ _) -- Size of biggest alternative
- = SizeIs tot (unitBag (v, iBox (_ILIT(2) +# tot -# max)) `unionBags` tot_disc) tot_scrut
+ = SizeIs tot (unitBag (v, iBox (_ILIT(20) +# tot -# max)) `unionBags` tot_disc) tot_scrut
-- If the variable is known, we produce a discount that
-- will take us back to 'max', the size of the largest alternative
-- The 1+ is a little discount for reduced allocation in the caller
alts_size tot_size _ = tot_size
- size_up (Case e _ _ alts) = size_up e `addSizeNSD`
- foldr (addAltSize . size_up_alt) sizeZero alts
- -- We don't charge for the case itself
- -- It's a strict thing, and the price of the call
- -- is paid by scrut. Also consider
- -- case f x of DEFAULT -> e
- -- This is just ';'! Don't charge for it.
- --
- -- Moreover, we charge one per alternative.
+ size_up (Case e _ _ alts) = size_up e `addSizeNSD`
+ foldr (addAltSize . size_up_alt) case_size alts
+ where
+ case_size
+ | is_inline_scrut e, not (lengthExceeds alts 1) = sizeN (-10)
+ | otherwise = sizeZero
+ -- Normally we don't charge for the case itself, but
+ -- we charge one per alternative (see size_up_alt,
+ -- below) to account for the cost of the info table
+ -- and comparisons.
+ --
+ -- However, in certain cases (see is_inline_scrut
+ -- below), no code is generated for the case unless
+ -- there are multiple alts. In these cases we
+ -- subtract one, making the first alt free.
+ -- e.g. case x# +# y# of _ -> ... should cost 1
+ -- case touch# x# of _ -> ... should cost 0
+ -- (see #4978)
+ --
+ -- I would like to not have the "not (lengthExceeds alts 1)"
+ -- condition above, but without that some programs got worse
+ -- (spectral/hartel/event and spectral/para). I don't fully
+ -- understand why. (SDM 24/5/11)
+
+ -- unboxed variables, inline primops and unsafe foreign calls
+ -- are all "inline" things:
+ is_inline_scrut (Var v) = isUnLiftedType (idType v)
+ is_inline_scrut scrut
+ | (Var f, _) <- collectArgs scrut
+ = case idDetails f of
+ FCallId fc -> not (isSafeForeignCall fc)
+ PrimOpId op -> not (primOpOutOfLine op)
+ _other -> False
+ | otherwise
+ = False
------------
-- size_up_app is used when there's ONE OR MORE value args
size_up_app (App fun arg) args
- | isTypeArg arg = size_up_app fun args
+ | isTyCoArg arg = size_up_app fun args
| otherwise = size_up arg `addSizeNSD`
size_up_app fun (arg:args)
size_up_app (Var fun) args = size_up_call fun args
size_up_call :: Id -> [CoreExpr] -> ExprSize
size_up_call fun val_args
= case idDetails fun of
- FCallId _ -> sizeN opt_UF_DearOp
+ FCallId _ -> sizeN (10 * (1 + length val_args))
DataConWorkId dc -> conSize dc (length val_args)
PrimOpId op -> primOpSize op (length val_args)
ClassOpId _ -> classOpSize top_args val_args
_ -> funSize top_args fun (length val_args)
------------
- size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 1
+ size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10
-- Don't charge for args, so that wrappers look cheap
-- (See comments about wrappers with Case)
--
-- | Finds a nominal size of a string literal.
litSize :: Literal -> Int
-- Used by CoreUnfold.sizeExpr
-litSize (MachStr str) = 1 + ((lengthFS str + 3) `div` 4)
+litSize (MachStr str) = 10 + 10 * ((lengthFS str + 3) `div` 4)
-- If size could be 0 then @f "x"@ might be too small
-- [Sept03: make literal strings a bit bigger to avoid fruitless
-- duplication of little strings]
classOpSize top_args (arg1 : other_args)
= SizeIs (iUnbox size) arg_discount (_ILIT(0))
where
- size = 2 + length other_args
+ size = 20 + (10 * length other_args)
-- If the class op is scrutinising a lambda bound dictionary then
-- give it a discount, to encourage the inlining of this function
-- The actual discount is rather arbitrarily chosen
res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount
| otherwise = 0
-- If the function is partially applied, show a result discount
-
- size | some_val_args = 1 + n_val_args
+ size | some_val_args = 10 * (1 + n_val_args)
| otherwise = 0
-- The 1+ is for the function itself
-- Add 1 for each non-trivial arg;
conSize :: DataCon -> Int -> ExprSize
conSize dc n_val_args
- | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(1)) -- Like variables
-
--- See Note [Constructor size]
- | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox n_val_args +# _ILIT(1))
+ | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(10)) -- Like variables
-- See Note [Unboxed tuple result discount]
--- | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (_ILIT(0))
+ | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox (10 * (1 + n_val_args)))
-- See Note [Constructor size]
- | otherwise = SizeIs (_ILIT(1)) emptyBag (iUnbox n_val_args +# _ILIT(1))
+ | otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (10 + n_val_args)))
+ -- discont was (10 * (1 + n_val_args)), but it turns out that
+ -- adding a bigger constant here is an unambiguous win. We
+ -- REALLY like unfolding constructors that get scrutinised.
+ -- [SDM, 25/5/11]
\end{code}
Note [Constructor size]
\begin{code}
primOpSize :: PrimOp -> Int -> ExprSize
primOpSize op n_val_args
- | not (primOpIsDupable op) = sizeN opt_UF_DearOp
- | not (primOpOutOfLine op) = sizeN 1
- -- Be very keen to inline simple primops.
- -- We give a discount of 1 for each arg so that (op# x y z) costs 2.
- -- We can't make it cost 1, else we'll inline let v = (op# x y z)
- -- at every use of v, which is excessive.
- --
- -- A good example is:
- -- let x = +# p q in C {x}
- -- Even though x get's an occurrence of 'many', its RHS looks cheap,
- -- and there's a good chance it'll get inlined back into C's RHS. Urgh!
-
- | otherwise = sizeN n_val_args
+ = if primOpOutOfLine op
+ then sizeN (op_size + n_val_args)
+ else sizeN op_size
+ where
+ op_size = primOpCodeSize op
buildSize :: ExprSize
-buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
+buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40))
-- We really want to inline applications of build
-- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)
-- Indeed, we should add a result_discount becuause build is
-- The "4" is rather arbitrary.
augmentSize :: ExprSize
-augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4))
+augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40))
-- Ditto (augment t (\cn -> e) ys) should cost only the cost of
-- e plus ys. The -2 accounts for the \cn
UnfNever -> False
UnfWhen {} -> True
UnfIfGoodArgs { ug_size = size}
- -> is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
+ -> is_cheap && size - (10 * (n_vals +1)) <= opt_UF_UseThreshold
certainlyWillInline _
= False
-- *efficiency* to be gained (e.g. beta reductions, case reductions)
-- by inlining.
- = 1 -- Discount of 1 because the result replaces the call
+ = 10 -- Discount of 1 because the result replaces the call
-- so we count 1 for the function itself
- + length (take n_vals_wanted arg_infos)
+ + 10 * length (take n_vals_wanted arg_infos)
-- Discount of (un-scaled) 1 for each arg supplied,
-- because the result replaces the call
arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos)
mk_arg_discount _ TrivArg = 0
- mk_arg_discount _ NonTrivArg = 1
+ mk_arg_discount _ NonTrivArg = 10
mk_arg_discount discount ValueArg = discount
res_discount' = case cont_info of
BoringCtxt -> 0
CaseCtxt -> res_discount
- _other -> 4 `min` res_discount
+ _other -> 40 `min` res_discount
-- res_discount can be very large when a function returns
-- constructors; but we only want to invoke that large discount
-- when there's a case continuation.
conlike_unfolding = isConLikeUnfolding (idUnfolding v)
go (Type _) _ = TrivArg
- go (App fn (Type _)) n = go fn n
+ go (Coercion _) _ = TrivArg
+ go (App fn (Type _)) n = go fn n
+ go (App fn (Coercion _)) n = go fn n
go (App fn _) n = go fn (n+1)
go (Note _ a) n = go a n
go (Cast e _) n = go e n
go (Lam v e) n
- | isTyCoVar v = go e n
+ | isTyVar v = go e n
| n>0 = go e (n-1)
| otherwise = ValueArg
go (Let _ e) n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
Nothing -> Nothing ;
Just (dc, _dc_univ_args, dc_args) ->
- let (_from_ty, to_ty) = coercionKind co
+ let Pair _from_ty to_ty = coercionKind co
dc_tc = dataConTyCon dc
in
case splitTyConApp_maybe to_ty of {
dc_ex_tyvars = dataConExTyVars dc
arg_tys = dataConRepArgTys dc
- dc_eqs :: [(Type,Type)] -- All equalities from the DataCon
- dc_eqs = [(mkTyVarTy tv, ty) | (tv,ty) <- dataConEqSpec dc] ++
- [getEqPredTys eq_pred | eq_pred <- dataConEqTheta dc]
-
- (ex_args, rest1) = splitAtList dc_ex_tyvars dc_args
- (co_args, val_args) = splitAtList dc_eqs rest1
+ (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args
-- Make the "theta" from Fig 3 of the paper
gammas = decomposeCo tc_arity co
- theta = zipOpenTvSubst (dc_univ_tyvars ++ dc_ex_tyvars)
- (gammas ++ stripTypeArgs ex_args)
-
- -- Cast the existential coercion arguments
- cast_co (ty1, ty2) (Type co)
- = Type $ mkSymCoercion (substTy theta ty1)
- `mkTransCoercion` co
- `mkTransCoercion` (substTy theta ty2)
- cast_co _ other_arg = pprPanic "cast_co" (ppr other_arg)
- new_co_args = zipWith cast_co dc_eqs co_args
-
+ theta = zipOpenCvSubst (dc_univ_tyvars ++ dc_ex_tyvars)
+ (gammas ++ map mkReflCo (stripTypeArgs ex_args))
+
-- Cast the value arguments (which include dictionaries)
new_val_args = zipWith cast_arg arg_tys val_args
- cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
+ cast_arg arg_ty arg = mkCoerce (liftCoSubst theta arg_ty) arg
in
#ifdef DEBUG
let dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars,
ppr arg_tys, ppr dc_args, ppr _dc_univ_args,
ppr ex_args, ppr val_args]
in
- ASSERT2( coreEqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
- ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc )
+ ASSERT2( eqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
+ ASSERT2( all isTypeArg ex_args, dump_doc )
ASSERT2( equalLength val_args arg_tys, dump_doc )
#endif
- Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args)
+ Just (dc, to_tc_arg_tys, ex_args ++ new_val_args)
}}
exprIsConApp_maybe id_unf expr
-----------
beta (Lam v body) pairs (arg : args)
- | isTypeArg arg
+ | isTyCoArg arg
= beta body ((v,arg):pairs) args
beta (Lam {}) _ _ -- Un-saturated, or not a type lambda
subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs
-- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args]
-
stripTypeArgs :: [CoreExpr] -> [Type]
stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args )
[ty | Type ty <- args]
+ -- We really do want isTypeArg here, not isTyCoArg!
\end{code}
Note [Unfolding DFuns]
-- | Commonly useful utilites for manipulating the Core language
module CoreUtils (
-- * Constructing expressions
- mkSCC, mkCoerce, mkCoerceI,
+ mkSCC, mkCoerce,
bindNonRec, needsCaseBinding,
mkAltExpr, mkPiType, mkPiTypes,
-- * Manipulating data constructors and types
applyTypeToArgs, applyTypeToArg,
- dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
+ dataConRepInstPat, dataConRepFSInstPat
) where
#include "HsVersions.h"
import PrimOp
import Id
import IdInfo
-import TcType ( isPredTy )
import Type
import Coercion
import TyCon
import FastString
import Maybes
import Util
+import Pair
import Data.Word
import Data.Bits
\end{code}
-- really be said to have a type
exprType (Var var) = idType var
exprType (Lit lit) = literalType lit
+exprType (Coercion co) = coercionType co
exprType (Let _ body) = exprType body
exprType (Case _ _ ty _) = ty
-exprType (Cast _ co) = snd (coercionKind co)
+exprType (Cast _ co) = pSnd (coercionKind co)
exprType (Note _ e) = exprType e
exprType (Lam binder expr) = mkPiType binder (exprType expr)
exprType e@(App _ _)
where
ty = exprType rhs
free_tvs = tyVarsOfType ty
- bad_binder b = isTyCoVar b && b `elemVarSet` free_tvs
+ bad_binder b = isTyVar b && b `elemVarSet` free_tvs
coreAltsType :: [CoreAlt] -> Type
-- ^ Returns the type of the first alternative, which should be the same as for all alternatives
we are doing here. It's not too expensive, I think.
\begin{code}
-mkPiType :: EvVar -> Type -> Type
+mkPiType :: Var -> Type -> Type
-- ^ Makes a @(->)@ type or a forall type, depending
-- on whether it is given a type variable or a term variable.
-mkPiTypes :: [EvVar] -> Type -> Type
+mkPiTypes :: [Var] -> Type -> Type
-- ^ 'mkPiType' for multiple type or value arguments
mkPiType v ty
go [ty] args
where
go rev_tys (Type ty : args) = go (ty:rev_tys) args
- go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
- where
- op_ty' = applyTysD msg op_ty (reverse rev_tys)
- msg = ptext (sLit "applyTypeToArgs") <+>
- panic_msg e op_ty
+ go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
+ where
+ op_ty' = applyTysD msg op_ty (reverse rev_tys)
+ msg = ptext (sLit "applyTypeToArgs") <+>
+ panic_msg e op_ty
applyTypeToArgs e op_ty (_ : args)
= case (splitFunTy_maybe op_ty) of
%************************************************************************
\begin{code}
--- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
-mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
-mkCoerceI (IdCo _) e = e
-mkCoerceI (ACo co) e = mkCoerce co e
-
--- | Wrap the given expression in the coercion safely, coalescing nested coercions
+-- | Wrap the given expression in the coercion safely, dropping
+-- identity coercions and coalescing nested coercions
mkCoerce :: Coercion -> CoreExpr -> CoreExpr
+mkCoerce co e | isReflCo co = e
mkCoerce co (Cast expr co2)
- = ASSERT(let { (from_ty, _to_ty) = coercionKind co;
- (_from_ty2, to_ty2) = coercionKind co2} in
- from_ty `coreEqType` to_ty2 )
- mkCoerce (mkTransCoercion co2 co) expr
+ = ASSERT(let { Pair from_ty _to_ty = coercionKind co;
+ Pair _from_ty2 to_ty2 = coercionKind co2} in
+ from_ty `eqType` to_ty2 )
+ mkCoerce (mkTransCo co2 co) expr
mkCoerce co expr
- = let (from_ty, _to_ty) = coercionKind co in
--- if to_ty `coreEqType` from_ty
+ = let Pair from_ty _to_ty = coercionKind co in
+-- if to_ty `eqType` from_ty
-- then expr
-- else
- WARN(not (from_ty `coreEqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
+ WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
(Cast expr co)
\end{code}
\begin{code}
exprIsTrivial :: CoreExpr -> Bool
exprIsTrivial (Var _) = True -- See Note [Variables are trivial]
-exprIsTrivial (Type _) = True
+exprIsTrivial (Type _) = True
+exprIsTrivial (Coercion _) = True
exprIsTrivial (Lit lit) = litIsTrivial lit
exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
exprIsTrivial (Note _ e) = exprIsTrivial e -- See Note [SCCs are trivial]
= isJust (go dupAppSize e)
where
go :: Int -> CoreExpr -> Maybe Int
- go n (Type {}) = Just n
- go n (Var {}) = decrement n
- go n (Note _ e) = go n e
- go n (Cast e _) = go n e
+ go n (Type {}) = Just n
+ go n (Coercion {}) = Just n
+ go n (Var {}) = decrement n
+ go n (Note _ e) = go n e
+ go n (Cast e _) = go n e
go n (App f a) | Just n' <- go n a = go n' f
go n (Lit lit) | litIsDupable lit = decrement n
go _ _ = Nothing
type CheapAppFun = Id -> Int -> Bool
exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
-exprIsCheap' _ (Lit _) = True
-exprIsCheap' _ (Type _) = True
-exprIsCheap' _ (Var _) = True
-exprIsCheap' good_app (Note _ e) = exprIsCheap' good_app e
-exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e
-exprIsCheap' good_app (Lam x e) = isRuntimeVar x
- || exprIsCheap' good_app e
+exprIsCheap' _ (Lit _) = True
+exprIsCheap' _ (Type _) = True
+exprIsCheap' _ (Coercion _) = True
+exprIsCheap' _ (Var _) = True
+exprIsCheap' good_app (Note _ e) = exprIsCheap' good_app e
+exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e
+exprIsCheap' good_app (Lam x e) = isRuntimeVar x
+ || exprIsCheap' good_app e
exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e &&
and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts]
go _ _ = False
--------------
- go_pap args = all exprIsTrivial args
- -- For constructor applications and primops, check that all
- -- the args are trivial. We don't want to treat as cheap, say,
- -- (1:2:3:4:5:[])
- -- We'll put up with one constructor application, but not dozens
-
+ go_pap args = all (exprIsCheap' good_app) args
+ -- Used to be "all exprIsTrivial args" due to concerns about
+ -- duplicating nested constructor applications, but see #4978.
+
--------------
go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args
-- In principle we should worry about primops
-- We can only do this if the @y + 1@ is ok for speculation: it has no
-- side effects, and can't diverge or raise an exception.
exprOkForSpeculation :: CoreExpr -> Bool
-exprOkForSpeculation (Lit _) = True
-exprOkForSpeculation (Type _) = True
+exprOkForSpeculation (Lit _) = True
+exprOkForSpeculation (Type _) = True
+exprOkForSpeculation (Coercion _) = True
exprOkForSpeculation (Var v)
| isTickBoxOp v = False -- Tick boxes are *not* suitable for speculation
-- we could get an infinite loop
is_hnf_like (Lit _) = True
- is_hnf_like (Type _) = True -- Types are honorary Values;
+ is_hnf_like (Type _) = True -- Types are honorary Values;
-- we don't mind copying them
+ is_hnf_like (Coercion _) = True -- Same for coercions
is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e
is_hnf_like (Note _ e) = is_hnf_like e
is_hnf_like (Cast e _) = is_hnf_like e
- is_hnf_like (App e (Type _)) = is_hnf_like e
+ is_hnf_like (App e (Type _)) = is_hnf_like e
+ is_hnf_like (App e (Coercion _)) = is_hnf_like e
is_hnf_like (App e a) = app_is_value e [a]
is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us
is_hnf_like _ = False
These InstPat functions go here to avoid circularity between DataCon and Id
\begin{code}
-dataConRepInstPat, dataConOrigInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
-dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
+dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
+dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
-dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat ((fsLit "ipv")))
-dataConRepFSInstPat = dataConInstPat dataConRepArgTys
-dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat ((fsLit "ipv")))
- where
- dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc
- -- Remember to include the existential dictionaries
-
-dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys
- -> [FastString] -- A long enough list of FSs to use for names
- -> [Unique] -- An equally long list of uniques, at least one for each binder
- -> DataCon
- -> [Type] -- Types to instantiate the universally quantified tyvars
- -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
+dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv")))
+dataConRepFSInstPat = dataConInstPat
+
+dataConInstPat :: [FastString] -- A long enough list of FSs to use for names
+ -> [Unique] -- An equally long list of uniques, at least one for each binder
+ -> DataCon
+ -> [Type] -- Types to instantiate the universally quantified tyvars
+ -> ([TyVar], [Id]) -- Return instantiated variables
-- dataConInstPat arg_fun fss us con inst_tys returns a triple
--- (ex_tvs, co_tvs, arg_ids),
+-- (ex_tvs, arg_ids),
--
-- ex_tvs are intended to be used as binders for existential type args
--
--- co_tvs are intended to be used as binders for coercion args and the kinds
--- of these vars have been instantiated by the inst_tys and the ex_tys
--- The co_tvs include both GADT equalities (dcEqSpec) and
--- programmer-specified equalities (dcEqTheta)
---
-- arg_ids are indended to be used as binders for value arguments,
-- and their types have been instantiated with inst_tys and ex_tys
--- The arg_ids include both dicts (dcDictTheta) and
--- programmer-specified arguments (after rep-ing) (deRepArgTys)
+-- The arg_ids include both evidence and
+-- programmer-specified arguments (both after rep-ing)
--
-- Example.
-- The following constructor T1
--
-- dataConInstPat fss us T1 (a1',b') will return
--
--- ([a1'', b''], [c :: (a1', b')~(a1'', b'')], [x :: Int, y :: b''])
+-- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b''])
--
-- where the double-primed variables are created with the FastStrings and
-- Uniques given as fss and us
-dataConInstPat arg_fun fss uniqs con inst_tys
- = (ex_bndrs, co_bndrs, arg_ids)
+dataConInstPat fss uniqs con inst_tys
+ = (ex_bndrs, arg_ids)
where
univ_tvs = dataConUnivTyVars con
ex_tvs = dataConExTyVars con
- arg_tys = arg_fun con
- eq_spec = dataConEqSpec con
- eq_theta = dataConEqTheta con
- eq_preds = eqSpecPreds eq_spec ++ eq_theta
+ arg_tys = dataConRepArgTys con
n_ex = length ex_tvs
- n_co = length eq_preds
-- split the Uniques and FastStrings
- (ex_uniqs, uniqs') = splitAt n_ex uniqs
- (co_uniqs, id_uniqs) = splitAt n_co uniqs'
-
- (ex_fss, fss') = splitAt n_ex fss
- (co_fss, id_fss) = splitAt n_co fss'
+ (ex_uniqs, id_uniqs) = splitAt n_ex uniqs
+ (ex_fss, id_fss) = splitAt n_ex fss
-- Make existential type variables
ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
-- Make the instantiating substitution
subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
- -- Make new coercion vars, instantiating kind
- co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
- mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind
- where
- new_name = mkSysTvName uniq fs
- co_kind = substTy subst (mkPredTy eq_pred)
-
- -- make value vars, instantiating types
- mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
+ -- Make value vars, instantiating types
+ mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (Type.substTy subst ty) noSrcSpan
arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
-
\end{code}
%************************************************************************
cheapEqExpr (Var v1) (Var v2) = v1==v2
cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
-cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2
+cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
+cheapEqExpr (Coercion c1) (Coercion c2) = c1 `coreEqCoercion` c2
cheapEqExpr (App f1 a1) (App f2 a2)
= f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
-- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'
exprIsBig (Lit _) = False
exprIsBig (Var _) = False
-exprIsBig (Type _) = False
+exprIsBig (Type _) = False
+exprIsBig (Coercion _) = False
exprIsBig (Lam _ e) = exprIsBig e
exprIsBig (App f a) = exprIsBig f || exprIsBig a
exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big!
, Just e2' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v2))
= go (nukeRnEnvR env) e1 e2'
- go _ (Lit lit1) (Lit lit2) = lit1 == lit2
- go env (Type t1) (Type t2) = tcEqTypeX env t1 t2
- go env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && go env e1 e2
+ go _ (Lit lit1) (Lit lit2) = lit1 == lit2
+ go env (Type t1) (Type t2) = eqTypeX env t1 t2
+ go env (Coercion co1) (Coercion co2) = coreEqCoercion2 env co1 co2
+ go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 env co1 co2 && go env e1 e2
go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2
go env (Note n1 e1) (Note n2 e2) = go_note n1 n2 && go env e1 e2
go env (Lam b1 e1) (Lam b2 e2)
- = tcEqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination
+ = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination
&& go (rnBndr2 env b1 b2) e1 e2
go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)
go env (Case e1 b1 _ a1) (Case e2 b2 _ a2)
= go env e1 e2
- && tcEqTypeX env (idType b1) (idType b2)
+ && eqTypeX env (idType b1) (idType b2)
&& all2 (go_alt (rnBndr2 env b1 b2)) a1 a2
go _ _ _ = False
exprSize (Lam b e) = varSize b + exprSize e
exprSize (Let b e) = bindSize b + exprSize e
exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
-exprSize (Cast e co) = (seqType co `seq` 1) + exprSize e
+exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e
exprSize (Note n e) = noteSize n + exprSize e
-exprSize (Type t) = seqType t `seq` 1
+exprSize (Type t) = seqType t `seq` 1
+exprSize (Coercion co) = seqCo co `seq` 1
noteSize :: Note -> Int
noteSize (SCC cc) = cc `seq` 1
noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
varSize :: Var -> Int
-varSize b | isTyCoVar b = 1
+varSize b | isTyVar b = 1
| otherwise = seqType (idType b) `seq`
megaSeqIdInfo (idInfo b) `seq`
1
exprStats :: CoreExpr -> CoreStats
exprStats (Var {}) = oneTM
exprStats (Lit {}) = oneTM
-exprStats (App f (Type t))= tyCoStats (exprType f) t
+exprStats (Type t) = tyStats t
+exprStats (Coercion c) = coStats c
exprStats (App f a) = exprStats f `plusCS` exprStats a
exprStats (Lam b e) = bndrStats b `plusCS` exprStats e
exprStats (Let b e) = bindStats b `plusCS` exprStats e
exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as
exprStats (Cast e co) = coStats co `plusCS` exprStats e
exprStats (Note _ e) = exprStats e
-exprStats (Type ty) = zeroCS { cs_ty = typeSize ty }
- -- Ugh (might be a co)
altStats :: CoreAlt -> CoreStats
altStats (_, bs, r) = sumCS bndrStats bs `plusCS` exprStats r
-tyCoStats :: Type -> Type -> CoreStats
-tyCoStats fun_ty arg
- = case splitForAllTy_maybe fun_ty of
- Just (tv,_) | isCoVar tv -> coStats arg
- _ -> tyStats arg
-
tyStats :: Type -> CoreStats
tyStats ty = zeroCS { cs_ty = typeSize ty }
coStats :: Coercion -> CoreStats
-coStats co = zeroCS { cs_co = typeSize co }
+coStats co = zeroCS { cs_co = coercionSize co }
\end{code}
%************************************************************************
hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1
-- Shouldn't happen. Better to use WARN than trace, because trace
-- prevents the CPR optimisation kicking in for hash_expr.
+hash_expr _ (Coercion _) = WARN(True, text "hash_expr: coercion") 1
fast_hash_expr :: HashEnv -> CoreExpr -> Word32
-fast_hash_expr env (Var v) = hashVar env v
-fast_hash_expr env (Type t) = fast_hash_type env t
-fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)
-fast_hash_expr env (Cast e _) = fast_hash_expr env e
-fast_hash_expr env (Note _ e) = fast_hash_expr env e
-fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
-fast_hash_expr _ _ = 1
+fast_hash_expr env (Var v) = hashVar env v
+fast_hash_expr env (Type t) = fast_hash_type env t
+fast_hash_expr env (Coercion co) = fast_hash_co env co
+fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit)
+fast_hash_expr env (Cast e _) = fast_hash_expr env e
+fast_hash_expr env (Note _ e) = fast_hash_expr env e
+fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
+fast_hash_expr _ _ = 1
fast_hash_type :: HashEnv -> Type -> Word32
fast_hash_type env ty
in foldr (\t n -> fast_hash_type env t + n) hash_tc tys
| otherwise = 1
+fast_hash_co :: HashEnv -> Coercion -> Word32
+fast_hash_co env co
+ | Just cv <- getCoVar_maybe co = hashVar env cv
+ | Just (tc,cos) <- splitTyConAppCo_maybe co = let hash_tc = fromIntegral (hashName (tyConName tc))
+ in foldr (\c n -> fast_hash_co env c + n) hash_tc cos
+ | otherwise = 1
+
extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
extend_env (n,env) b = (n+1, extendVarEnv env b n)
\begin{code}
tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
tryEtaReduce bndrs body
- = go (reverse bndrs) body (IdCo (exprType body))
+ = go (reverse bndrs) body (mkReflCo (exprType body))
where
incoming_arity = count isId bndrs
go :: [Var] -- Binders, innermost first, types [a3,a2,a1]
-> CoreExpr -- Of type tr
- -> CoercionI -- Of type tr ~ ts
+ -> Coercion -- Of type tr ~ ts
-> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts
-- See Note [Eta reduction with casted arguments]
-- for why we have an accumulating coercion
go [] fun co
- | ok_fun fun = Just (mkCoerceI co fun)
+ | ok_fun fun = Just (mkCoerce co fun)
go (b : bs) (App fun arg) co
| Just co' <- ok_arg b arg co
---------------
-- Note [Eta reduction conditions]
ok_fun (App fun (Type ty))
- | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
+ | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
= ok_fun fun
ok_fun (Var fun_id)
= not (fun_id `elem` bndrs)
| otherwise = idArity fun
---------------
- ok_lam v = isTyCoVar v || isDictId v
+ ok_lam v = isTyVar v || isEvVar v
---------------
- ok_arg :: Var -- Of type bndr_t
- -> CoreExpr -- Of type arg_t
- -> CoercionI -- Of kind (t1~t2)
- -> Maybe CoercionI -- Of type (arg_t -> t1 ~ bndr_t -> t2)
- -- (and similarly for tyvars, coercion args)
+ ok_arg :: Var -- Of type bndr_t
+ -> CoreExpr -- Of type arg_t
+ -> Coercion -- Of kind (t1~t2)
+ -> Maybe Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2)
+ -- (and similarly for tyvars, coercion args)
-- See Note [Eta reduction with casted arguments]
ok_arg bndr (Type ty) co
| Just tv <- getTyVar_maybe ty
- , bndr == tv = Just (mkForAllTyCoI tv co)
+ , bndr == tv = Just (mkForAllCo tv co)
ok_arg bndr (Var v) co
- | bndr == v = Just (mkFunTyCoI (IdCo (idType bndr)) co)
+ | bndr == v = Just (mkFunCo (mkReflCo (idType bndr)) co)
ok_arg bndr (Cast (Var v) co_arg) co
- | bndr == v = Just (mkFunTyCoI (ACo (mkSymCoercion co_arg)) co)
+ | bndr == v = Just (mkFunCo (mkSymCo co_arg) co)
-- The simplifier combines multiple casts into one,
-- so we can have a simple-minded pattern match here
ok_arg _ _ _ = Nothing
\begin{code}
module ExternalCore where
-
data Module
= Module Mname [Tdef] [Vdefg]
type Vbind = (Var,Ty)
type Tbind = (Tvar,Kind)
+-- Internally, we represent types and coercions separately; but for
+-- the purposes of external core (at least for now) it's still
+-- convenient to collapse them into a single type.
data Ty
= Tvar Tvar
| Tcon (Qual Tcon)
| Tapp Ty Ty
| Tforall Tbind Ty
--- We distinguish primitive coercions
--- (represented in GHC by wired-in names), because
--- External Core treats them specially, so we have
--- to print them out with special syntax.
+-- We distinguish primitive coercions because External Core treats
+-- them specially, so we have to print them out with special syntax.
| TransCoercion Ty Ty
| SymCoercion Ty
| UnsafeCoercion Ty Ty
| InstCoercion Ty Ty
- | LeftCoercion Ty
- | RightCoercion Ty
+ | NthCoercion Int Ty
data Kind
= Klifted
#include "HsVersions.h"
import Id
-import IdInfo
-import Var ( EvVar, mkWildCoVar, setTyVarUnique )
+import Var ( EvVar, setTyVarUnique )
import CoreSyn
import CoreUtils ( exprType, needsCaseBinding, bindNonRec )
import TcType ( mkSigmaTy )
import Type
+import Coercion
import TysPrim
import DataCon ( DataCon, dataConWorkId )
+import IdInfo ( vanillaIdInfo, setStrictnessInfo, setArityInfo )
import Demand
import Name
import Outputable
-- Check the invariant that the arg of an App is ok-for-speculation if unlifted
-- See CoreSyn Note [CoreSyn let/app invariant]
mkCoreApp fun (Type ty) = App fun (Type ty)
+mkCoreApp fun (Coercion co) = App fun (Coercion co)
mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
mk_val_app fun arg arg_ty res_ty
where
where
go fun _ [] = fun
go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
+ go fun fun_ty (Coercion co : args) = go (App fun (Coercion co)) (applyCo fun_ty co) args
go fun fun_ty (arg : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun $$ ppr orig_args )
go (mk_val_app fun arg arg_ty res_ty) res_ty args
where
-- fragmet of it as the fun part of a 'mk_val_app'.
mkWildEvBinder :: PredType -> EvVar
-mkWildEvBinder pred@(EqPred {}) = mkWildCoVar (mkPredTy pred)
-mkWildEvBinder pred = mkWildValBinder (mkPredTy pred)
+mkWildEvBinder pred = mkWildValBinder (mkPredTy pred)
-- | Make a /wildcard binder/. This is typically used when you need a binder
-- that you expect to use only at a *binding* site. Do not use it at
import CoreSyn
import HscTypes
import TyCon
+-- import Class
+-- import TysPrim( eqPredPrimTyCon )
import TypeRep
import Type
import PprExternalCore () -- Instances
where
tdef | isNewTyCon tcon =
C.Newtype (qtc tcon)
- (case newTyConCo_maybe tcon of
- Just co -> qtc co
- Nothing -> pprPanic ("MkExternalCore: newtype tcon\
- should have a coercion: ") (ppr tcon))
+ (qcc (newTyConCo tcon))
(map make_tbind tyvars)
(make_ty (snd (newTyConRhs tcon)))
| otherwise =
qtc :: TyCon -> C.Qual C.Tcon
qtc = make_con_qid . tyConName
+qcc :: CoAxiom -> C.Qual C.Tcon
+qcc = make_con_qid . co_ax_name
make_cdef :: DataCon -> C.Cdef
make_cdef dcon = C.Constr dcon_name existentials tys
make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)
make_exp (Lit l) = return $ C.Lit (make_lit l)
make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t))
+make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))" -- TODO
make_exp (App e1 e2) = do
rator <- make_exp e1
rand <- make_exp e2
return $ C.App rator rand
-make_exp (Lam v e) | isTyCoVar v = make_exp e >>= (\ b ->
+make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b ->
return $ C.Lam (C.Tb (make_tbind v)) b)
make_exp (Lam v e) | otherwise = make_exp e >>= (\ b ->
return $ C.Lam (C.Vb (make_vbind v)) b)
-make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_ty co))
+make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_co co))
make_exp (Let b e) = do
vd <- make_vdef False b
body <- make_exp e
(map make_tbind tbs)
(map make_vbind vbs)
newE
- where (tbs,vbs) = span isTyCoVar vs
+ where (tbs,vbs) = span isTyVar vs
make_alt (LitAlt l,_,e) = make_exp e >>= (return . (C.Alit (make_lit l)))
make_alt (DEFAULT,[],e) = make_exp e >>= (return . C.Adefault)
-- This should never happen, as the DEFAULT alternative binds no variables,
make_ty' (PredTy p) = make_ty (predTypeRep p)
make_tyConApp :: TyCon -> [Type] -> C.Ty
-make_tyConApp tc [t1, t2] | tc == transCoercionTyCon =
- C.TransCoercion (make_ty t1) (make_ty t2)
-make_tyConApp tc [t] | tc == symCoercionTyCon =
- C.SymCoercion (make_ty t)
-make_tyConApp tc [t1, t2] | tc == unsafeCoercionTyCon =
- C.UnsafeCoercion (make_ty t1) (make_ty t2)
-make_tyConApp tc [t] | tc == leftCoercionTyCon =
- C.LeftCoercion (make_ty t)
-make_tyConApp tc [t] | tc == rightCoercionTyCon =
- C.RightCoercion (make_ty t)
-make_tyConApp tc [t1, t2] | tc == instCoercionTyCon =
- C.InstCoercion (make_ty t1) (make_ty t2)
--- this fails silently if we have an application
--- of a wired-in coercion tycon to the wrong number of args.
--- Not great...
make_tyConApp tc ts =
foldl C.Tapp (C.Tcon (qtc tc))
(map make_ty ts)
-
make_kind :: Kind -> C.Kind
-make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2)
- where (t1, t2) = getEqPredTys p
+make_kind (PredTy (EqPred t1 t2)) = C.Keq (make_ty t1) (make_ty t2)
make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2)
make_kind k
| isLiftedTypeKind k = C.Klifted
make_con_qid :: Name -> C.Qual C.Id
make_con_qid = make_qid False False
+make_co :: Coercion -> C.Ty
+make_co (Refl ty) = make_ty ty
+make_co (TyConAppCo tc cos) = make_conAppCo (qtc tc) cos
+make_co (AppCo c1 c2) = C.Tapp (make_co c1) (make_co c2)
+make_co (ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co co)
+make_co (CoVarCo cv) = C.Tvar (make_var_id (coVarName cv))
+make_co (AxiomInstCo cc cos) = make_conAppCo (qcc cc) cos
+make_co (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty t1) (make_ty t2)
+make_co (SymCo co) = C.SymCoercion (make_co co)
+make_co (TransCo c1 c2) = C.TransCoercion (make_co c1) (make_co c2)
+make_co (NthCo d co) = C.NthCoercion d (make_co co)
+make_co (InstCo co ty) = C.InstCoercion (make_co co) (make_ty ty)
+
+-- Used for both tycon app coercions and axiom instantiations.
+make_conAppCo :: C.Qual C.Tcon -> [Coercion] -> C.Ty
+make_conAppCo con cos =
+ foldl C.Tapp (C.Tcon con)
+ (map make_co cos)
+
-------
isALocal :: Name -> CoreM Bool
isALocal vName = do
-- The function adds parens in context that need
-- an atomic value (e.g. function args)
-ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd
+ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd
+
+ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co)
ppr_expr _ (Var name) = ppr name
ppr_expr _ (Lit lit) = ppr lit
pprArg (Type ty)
| opt_SuppressTypeApplications = empty
| otherwise = ptext (sLit "@") <+> pprParendType ty
-
-pprArg expr = pprParendExpr expr
+pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
+pprArg expr = pprParendExpr expr
\end{code}
Other printing bits-and-bobs used with the general @pprCoreBinding@
pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder
- | isTyCoVar binder = pprKindedTyVarBndr binder
+ | isTyVar binder = pprKindedTyVarBndr binder
| otherwise = pprTypedBinder binder $$
ppIdInfo binder (idInfo binder)
pprUntypedBinder :: Var -> SDoc
pprUntypedBinder binder
- | isTyCoVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind
+ | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind
| otherwise = pprIdBndr binder
pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
pprTypedLCBinder bind_site debug_on var
| not debug_on && isDeadBinder var = char '_'
| not debug_on, CaseBind <- bind_site = pprUntypedBinder var -- No parens, no kind info
- | isTyCoVar var = parens (pprKindedTyVarBndr var)
+ | isTyVar var = parens (pprKindedTyVarBndr var)
| otherwise = parens (hang (pprIdBndr var)
2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
where
pprTypedBinder :: Var -> SDoc
-- Print binder with a type or kind signature (not paren'd)
pprTypedBinder binder
- | isTyCoVar binder = pprKindedTyVarBndr binder
+ | isTyVar binder = pprKindedTyVarBndr binder
| opt_SuppressTypeSignatures = empty
| otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
sep [text "%sym", paty t]
pty (UnsafeCoercion t1 t2) =
sep [text "%unsafe", paty t1, paty t2]
-pty (LeftCoercion t) =
- sep [text "%left", paty t]
-pty (RightCoercion t) =
- sep [text "%right", paty t]
+pty (NthCoercion n t) =
+ sep [text "%nth", int n, paty t]
pty (InstCoercion t1 t2) =
sep [text "%inst", paty t1, paty t2]
pty t = pbty t
import PrelNames
import TyCon
import Type
-import Unify( dataConCannotMatch )
import SrcLoc
import UniqSet
import Util
+import BasicTypes
import Outputable
import FastString
\end{code}
-- if there are view patterns, just give up - don't know what the function is
check qs = (untidy_warns, shadowed_eqns)
where
- (warns, used_nos) = check' ([1..] `zip` map tidy_eqn qs)
+ tidy_qs = map tidy_eqn qs
+ (warns, used_nos) = check' ([1..] `zip` tidy_qs)
untidy_warns = map untidy_exhaustive warns
shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..],
not (i `elementOfUniqSet` used_nos)]
-- It doesn't matter which one, because they will only be compared
-- with other HsLits gotten in the same way
get_lit (LitPat lit) = Just lit
-get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg mb i))
-get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg mb f))
+get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg negate mb i))
+get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))
get_lit (NPat (OverLit { ol_val = HsIsString s }) _ _) = Just (HsStringPrim s)
get_lit _ = Nothing
-mb_neg :: Num a => Maybe b -> a -> a
-mb_neg Nothing v = v
-mb_neg (Just _) v = -v
+mb_neg :: (a -> a) -> Maybe b -> a -> a
+mb_neg _ Nothing v = v
+mb_neg negate (Just _) v = negate v
get_unused_cons :: [Pat Id] -> [DataCon]
get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons
-- Finally the ones that are sure to succeed, or which are covered by the checking algorithm
might_fail_pat (LazyPat _) = False -- Always succeeds
-might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat, TypePat
+might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat
--------------
might_fail_lpat :: LPat Id -> Bool
tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))
tidy_pat (ViewPat _ _ ty) = WildPat ty
-tidy_pat (NPat lit mb_neg eq) = tidyNPat lit mb_neg eq
-
tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps })
= pat { pat_args = tidy_con id ps }
where
arity = length ps
--- Unpack string patterns fully, so we can see when they overlap with
--- each other, or even explicit lists of Chars.
-tidy_pat (LitPat lit)
+tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq
+tidy_pat (LitPat lit) = tidy_lit_pat lit
+
+tidy_lit_pat :: HsLit -> Pat Id
+-- Unpack string patterns fully, so we can see when they
+-- overlap with each other, or even explicit lists of Chars.
+tidy_lit_pat lit
| HsString s <- lit
- = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mk_char_lit c, pat] stringTy)
+ = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy)
(mkPrefixConPat nilDataCon [] stringTy) (unpackFS s)
| otherwise
= tidyLitPat lit
- where
- mk_char_lit c = mkPrefixConPat charDataCon [nlLitPat (HsCharPrim c)] charTy
-----------------
tidy_con :: DataCon -> HsConPatDetails Id -> HsConPatDetails Id
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprNeverOrAlways e)
-addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do
- (stmts', last_exp') <- addTickLStmts' forQual stmts
- (addTickLHsExpr last_exp)
- return (HsDo cxt stmts' last_exp' srcloc)
+addTickHsExpr (HsDo cxt stmts srcloc)
+ = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
+ ; return (HsDo cxt stmts' srcloc) }
where
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a
-> TM ([LStmt Id], a)
addTickLStmts' isGuard lstmts res
- = bindLocals binders $ do
- lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
- a <- res
- return (lstmts', a)
- where
- binders = collectLStmtsBinders lstmts
+ = bindLocals (collectLStmtsBinders lstmts) $
+ do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
+ ; a <- res
+ ; return (lstmts', a) }
addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id)
+addTickStmt _isGuard (LastStmt e ret) = do
+ liftM2 LastStmt
+ (addTickLHsExpr e)
+ (addTickSyntaxExpr hpcSrcSpan ret)
addTickStmt _isGuard (BindStmt pat e bind fail) = do
liftM4 BindStmt
(addTickLPat pat)
(addTickLHsExprAlways e)
(addTickSyntaxExpr hpcSrcSpan bind)
(addTickSyntaxExpr hpcSrcSpan fail)
-addTickStmt isGuard (ExprStmt e bind' ty) = do
- liftM3 ExprStmt
+addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
+ liftM4 ExprStmt
(addTick isGuard e)
(addTickSyntaxExpr hpcSrcSpan bind')
+ (addTickSyntaxExpr hpcSrcSpan guard')
(return ty)
addTickStmt _isGuard (LetStmt binds) = do
liftM LetStmt
(addTickHsLocalBinds binds)
-addTickStmt isGuard (ParStmt pairs) = do
- liftM ParStmt
+addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do
+ liftM4 ParStmt
(mapM (addTickStmtAndBinders isGuard) pairs)
-
-addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr) = do
- liftM4 TransformStmt
- (addTickLStmts isGuard stmts)
- (return ids)
- (addTickLHsExprAlways usingExpr)
- (addTickMaybeByLHsExpr maybeByExpr)
-
-addTickStmt isGuard (GroupStmt stmts binderMap by using) = do
- liftM4 GroupStmt
- (addTickLStmts isGuard stmts)
- (return binderMap)
- (fmapMaybeM addTickLHsExprAlways by)
- (fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using)
+ (addTickSyntaxExpr hpcSrcSpan mzipExpr)
+ (addTickSyntaxExpr hpcSrcSpan bindExpr)
+ (addTickSyntaxExpr hpcSrcSpan returnExpr)
+
+addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
+ , trS_by = by, trS_using = using
+ , trS_ret = returnExpr, trS_bind = bindExpr
+ , trS_fmap = liftMExpr }) = do
+ t_s <- addTickLStmts isGuard stmts
+ t_y <- fmapMaybeM addTickLHsExprAlways by
+ t_u <- addTickLHsExprAlways using
+ t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
+ t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
+ t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
+ return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
+ , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
addTickStmt isGuard stmt@(RecStmt {})
= do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
(addTickLStmts isGuard stmts)
(return ids)
-addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id))
-addTickMaybeByLHsExpr maybeByExpr =
- case maybeByExpr of
- Nothing -> return Nothing
- Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just)
-
addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
addTickHsLocalBinds (HsValBinds binds) =
liftM HsValBinds
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
-addTickHsCmd (HsDo cxt stmts last_exp srcloc) = do
- (stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp)
- return (HsDo cxt stmts' last_exp' srcloc)
+addTickHsCmd (HsDo cxt stmts srcloc)
+ = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
+ ; return (HsDo cxt stmts' srcloc) }
addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsArrApp
binders = collectLocalBinders local_binds
addTickCmdGRHS :: GRHS Id -> TM (GRHS Id)
-addTickCmdGRHS (GRHS stmts cmd) = do
- (stmts',expr') <- addTickLCmdStmts' stmts (addTickLHsCmd cmd)
- return $ GRHS stmts' expr'
+-- The *guards* are *not* Cmds, although the body is
+-- C.f. addTickGRHS for the BinBox stuff
+addTickCmdGRHS (GRHS stmts cmd)
+ = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
+ stmts (addTickLHsCmd cmd)
+ ; return $ GRHS stmts' expr' }
addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id]
addTickLCmdStmts stmts = do
(addTickLHsCmd c)
(return bind)
(return fail)
-addTickCmdStmt (ExprStmt c bind' ty) = do
- liftM3 ExprStmt
+addTickCmdStmt (LastStmt c ret) = do
+ liftM2 LastStmt
+ (addTickLHsCmd c)
+ (addTickSyntaxExpr hpcSrcSpan ret)
+addTickCmdStmt (ExprStmt c bind' guard' ty) = do
+ liftM4 ExprStmt
(addTickLHsCmd c)
- (return bind')
+ (addTickSyntaxExpr hpcSrcSpan bind')
+ (addTickSyntaxExpr hpcSrcSpan guard')
(return ty)
addTickCmdStmt (LetStmt binds) = do
liftM LetStmt
That keeps the desugaring of list comprehensions simple too.
+
+
Nor do we want to warn of conversion identities on the LHS;
the rule is precisly to optimise them:
{-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
else (NonRec b (simplify e)):(simplifyBind $ Rec rbs')
simplifyBinds = concatMap simplifyBind
-\end{code}
\ No newline at end of file
+\end{code}
core_body,
exprFreeVars core_binds `intersectVarSet` local_vars)
-dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _)
- = dsCmdDo ids local_vars env_ids res_ty stmts body
+dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _)
+ = dsCmdDo ids local_vars env_ids res_ty stmts
-- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
-- A | xs |- ci :: [tsi] ti
-- so don't pull on it too early
-> Type -- return type of the statement
-> [LStmt Id] -- statements to desugar
- -> LHsExpr Id -- body
-> DsM (CoreExpr, -- desugared expression
IdSet) -- set of local vars that occur free
-- --------------------------
-- A | xs |- do { c } :: [] t
-dsCmdDo ids local_vars env_ids res_ty [] body
+dsCmdDo _ _ _ _ [] = panic "dsCmdDo"
+
+dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)]
= dsLCmd ids local_vars env_ids [] res_ty body
-dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do
+dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = do
let
bound_vars = mkVarSet (collectLStmtBinders stmt)
local_vars' = local_vars `unionVarSet` bound_vars
(core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
- (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body
+ (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts
return (core_stmts, fv_stmts, varSetElems fv_stmts))
(core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
return (do_compose ids
-- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
-- arr snd >>> ss
-dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty) = do
+dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd
core_mux <- matchEnvStack env_ids []
(mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids))
go (SigPatIn pat _) = collectl pat bndrs
go (SigPatOut pat _) = collectl pat bndrs
- go (TypePat _) = bndrs
go (CoPat _ pat _) = collectl (noLoc pat) bndrs
go (ViewPat _ pat _) = collectl pat bndrs
go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p)
\begin{code}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
- dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
+ dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
DsEvBind(..), AutoScc(..)
) where
import TcType
import Type
+import Coercion
import TysPrim ( anyTypeOfKind )
import CostCentre
import Module
free_vars_of :: EvTerm -> [EvVar]
free_vars_of (EvId v) = [v]
- free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co)
- free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co)
+ free_vars_of (EvCast v co) = v : varSetElems (tyCoVarsOfCo co)
+ free_vars_of (EvCoercion co) = varSetElems (tyCoVarsOfCo co)
free_vars_of (EvDFunApp _ _ vs) = vs
free_vars_of (EvSuperClass d _) = [d]
(arg_tys, _) = splitFunTys rho
bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
++ map mkWildValBinder arg_tys
- mk_wild_pred (p, i) | i==n = ASSERT( p `tcEqPred` (coVarPred co_var))
+ mk_wild_pred (p, i) | i==n = ASSERT( p `eqPred` (coVarPred co_var))
co_var
| otherwise = mkWildEvBinder p
dsEvTerm (EvId v) = Var v
dsEvTerm (EvCast v co) = Cast (Var v) co
dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
-dsEvTerm (EvCoercion co) = Type co
+dsEvTerm (EvCoercion co) = Coercion co
dsEvTerm (EvSuperClass d n)
= ASSERT( isClassPred (classSCTheta cls !! n) )
-- We can only select *dictionary* superclasses
bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
2 (ppr opt_lhs)
- dead_msg bndr = hang (ptext (sLit "Forall'd") <+> pp_bndr bndr
- <+> ptext (sLit "is not bound in RULE lhs"))
+ dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
+ , ptext (sLit "is not bound in RULE lhs")])
2 (ppr opt_lhs)
pp_bndr bndr
- | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr
- | isCoVar bndr = ptext (sLit "coercion variable") <+> ppr bndr
- | isDictId bndr = ptext (sLit "constraint") <+> ppr (get_pred bndr)
- | otherwise = ptext (sLit "variable") <+> ppr bndr
-
- get_pred b = ASSERT( isId b ) expectJust "decomposeRuleLhs"
- (tcSplitPredTy_maybe (idType b))
+ | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr)
+ | isEvVar bndr = ptext (sLit "constraint") <+> quotes (ppr (evVarPred bndr))
+ | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr)
\end{code}
Note [Simplifying the left-hand side of a RULE]
NB: tcSimplifyRuleLhs is very careful not to generate complicated
dictionary expressions that we might have to match
-
Note [Matching seqId]
~~~~~~~~~~~~~~~~~~~
The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
; let io_data_con = head (tyConDataCons io_tycon)
toIOCon = dataConWrapId io_data_con
- wrap the_call = mkCoerceI (mkSymCoI co) $
+ wrap the_call = mkCoerce (mkSymCo co) $
mkApps (Var toIOCon)
[ Type io_res_ty,
Lam state_id $
-- Recursive newtypes
| Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
= do (maybe_ty, wrapper) <- resultWrapper rep_ty
- return (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
+ return (maybe_ty, \e -> mkCoerce (mkSymCo co) (wrapper e))
-- The type might contain foralls (eg. for dummy type arguments,
-- referring to 'Ptr a' is legal).
import StaticFlags
import CostCentre
import Id
-import Var
import VarSet
+import VarEnv
import DataCon
import TysWiredIn
import BasicTypes
-- 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.
--
-dsExpr (HsDo ListComp stmts body result_ty)
- = -- Special case for list comprehensions
- dsListComp stmts body elt_ty
- where
- [elt_ty] = tcTyConAppArgs result_ty
-
-dsExpr (HsDo DoExpr stmts body result_ty)
- = dsDo stmts body result_ty
-
-dsExpr (HsDo GhciStmt stmts body result_ty)
- = dsDo stmts body result_ty
-
-dsExpr (HsDo MDoExpr stmts body result_ty)
- = dsDo stmts body result_ty
-
-dsExpr (HsDo PArrComp stmts body result_ty)
- = -- Special case for array comprehensions
- dsPArrComp (map unLoc stmts) body elt_ty
- where
- [elt_ty] = tcTyConAppArgs result_ty
+dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty
+dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)
+dsExpr (HsDo DoExpr stmts _) = dsDo stmts
+dsExpr (HsDo GhciStmt stmts _) = dsDo stmts
+dsExpr (HsDo MDoExpr stmts _) = dsDo stmts
+dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts
dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
mk_alt upd_fld_env con
= do { let (univ_tvs, ex_tvs, eq_spec,
- eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
+ theta, arg_tys, _) = dataConFullSig con
subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
-- I'm not bothering to clone the ex_tvs
; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
- ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
+ ; theta_vars <- mapM newPredVarDs (substTheta subst theta)
; arg_ids <- newSysLocalsDs (substTys subst arg_tys)
; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
wrap = mkWpEvVarApps theta_vars `WpCompose`
mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
- , isNothing (lookupTyVar wrap_subst tv) ]
+ , not (tv `elemVarEnv` wrap_subst) ]
rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
-- Tediously wrap the application in a cast
-- Note [Update for GADTs]
wrapped_rhs | null eq_spec = rhs
| otherwise = mkLHsWrap (WpCast wrap_co) rhs
- wrap_co = mkTyConApp tycon [ lookup tv ty
- | (tv,ty) <- univ_tvs `zip` out_inst_tys]
- lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
- Just ty' -> ty'
- Nothing -> ty
- wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
- | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
-
+ wrap_co = mkTyConAppCo tycon [ lookup tv ty
+ | (tv,ty) <- univ_tvs `zip` out_inst_tys]
+ lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of
+ Just co' -> co'
+ Nothing -> mkReflCo ty
+ wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var))
+ | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
+
pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
, pat_dicts = eqs_vars ++ theta_vars
, pat_binds = emptyTcEvBinds
dsExpr (HsBinTick ixT ixF e) = do
e2 <- dsLExpr e
- do { ASSERT(exprType e2 `coreEqType` boolTy)
+ do { ASSERT(exprType e2 `eqType` boolTy)
mkBinaryTickBox ixT ixF e2
}
\end{code}
Haskell 98 report:
\begin{code}
-dsDo :: [LStmt Id]
- -> LHsExpr Id
- -> Type -- Type of the whole expression
- -> DsM CoreExpr
-
-dsDo stmts body result_ty
+dsDo :: [LStmt Id] -> DsM CoreExpr
+dsDo stmts
= goL stmts
where
- -- result_ty must be of the form (m b)
- (m_ty, _b_ty) = tcSplitAppTy result_ty
-
- goL [] = dsLExpr body
- goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
+ goL [] = panic "dsDo"
+ goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
- go _ (ExprStmt rhs then_expr _) stmts
+ go _ (LastStmt body _) stmts
+ = ASSERT( null stmts ) dsLExpr body
+ -- The 'return' op isn't used for 'do' expressions
+
+ go _ (ExprStmt rhs then_expr _ _) stmts
= do { rhs2 <- dsLExpr rhs
- ; case tcSplitAppTy_maybe (exprType rhs2) of
- Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty
- _ -> return ()
+ ; warnDiscardedDoBindings rhs (exprType rhs2)
; then_expr2 <- dsExpr then_expr
; rest <- goL stmts
; return (mkApps then_expr2 [rhs2, rest]) }
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = return_op
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
- , recS_rec_rets = rec_rets }) stmts
+ , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
= ASSERT( length rec_ids > 0 )
goL (new_bind_stmt : stmts)
where
- -- returnE <- dsExpr return_id
- -- mfixE <- dsExpr mfix_id
- new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
- bind_op
+ new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats)
+ mfix_app bind_op
noSyntaxExpr -- Tuple cannot fail
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
+ tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
rec_tup_pats = map nlVarPat tup_ids
later_pats = rec_tup_pats
rets = map noLoc rec_rets
-
- mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
- mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
- (mkFunTy tup_ty body_ty))
- mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
- body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty
- return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
- body_ty = mkAppTy m_ty tup_ty
- tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
+ mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
+ mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
+ (mkFunTy tup_ty body_ty))
+ mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
+ body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
+ ret_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
+ ret_stmt = noLoc $ mkLastStmt ret_app
+ -- This LastStmt will be desugared with dsDo,
+ -- which ignores the return_op in the LastStmt,
+ -- so we must apply the return_op explicitly
handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls
showSDoc (ppr (getLoc pat))
\end{code}
-Translation for RecStmt's:
------------------------------
-We turn (RecStmt [v1,..vn] stmts) into:
-
- (v1,..,vn) <- mfix (\~(v1,..vn). do stmts
- return (v1,..vn))
-
-\begin{code}
-{-
-dsMDo :: HsStmtContext Name
- -> [(Name,Id)]
- -> [LStmt Id]
- -> LHsExpr Id
- -> Type -- Type of the whole expression
- -> DsM CoreExpr
-
-dsMDo ctxt tbl stmts body result_ty
- = goL stmts
- where
- goL [] = dsLExpr body
- goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
-
- (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
- return_id = lookupEvidence tbl returnMName
- bind_id = lookupEvidence tbl bindMName
- then_id = lookupEvidence tbl thenMName
- fail_id = lookupEvidence tbl failMName
-
- go _ (LetStmt binds) stmts
- = do { rest <- goL stmts
- ; dsLocalBinds binds rest }
-
- go _ (ExprStmt rhs then_expr rhs_ty) stmts
- = do { rhs2 <- dsLExpr rhs
- ; warnDiscardedDoBindings rhs m_ty rhs_ty
- ; then_expr2 <- dsExpr then_expr
- ; rest <- goL stmts
- ; return (mkApps then_expr2 [rhs2, rest]) }
-
- go _ (BindStmt pat rhs bind_op _) stmts
- = do { body <- goL stmts
- ; rhs' <- dsLExpr rhs
- ; bind_op' <- dsExpr bind_op
- ; var <- selectSimpleMatchVarL pat
- ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
- result_ty (cantFailMatchResult body)
- ; match_code <- handle_failure pat match fail_op
- ; return (mkApps bind_op [rhs', Lam var match_code]) }
-
- go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
- , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
- , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts
- = ASSERT( length rec_ids > 0 )
- ASSERT( length rec_ids == length rec_rets )
- ASSERT( isEmptyTcEvBinds _ev_binds )
- pprTrace "dsMDo" (ppr later_ids) $
- goL (new_bind_stmt : stmts)
- where
- new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app
- bind_op noSyntaxExpr
-
- -- Remove the later_ids that appear (without fancy coercions)
- -- in rec_rets, because there's no need to knot-tie them separately
- -- See Note [RecStmt] in HsExpr
- later_ids' = filter (`notElem` mono_rec_ids) later_ids
- mono_rec_ids = [ id | HsVar id <- rec_rets ]
-
- mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
- mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
- (mkFunTy tup_ty body_ty))
-
- -- The rec_tup_pat must bind the rec_ids only; remember that the
- -- trimmed_laters may share the same Names
- -- Meanwhile, the later_pats must bind the later_vars
- rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids
- later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids
- rets = map nlHsVar later_ids' ++ map noLoc rec_rets
-
- mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
- body = noLoc $ HsDo ctxt rec_stmts return_app body_ty
- body_ty = mkAppTy m_ty tup_ty
- tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case
-
- return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
-
- mk_wild_pat :: Id -> LPat Id
- mk_wild_pat v = noLoc $ WildPat $ idType v
-
- mk_later_pat :: Id -> LPat Id
- mk_later_pat v | v `elem` later_ids' = mk_wild_pat v
- | otherwise = nlVarPat v
-
- mk_tup_pat :: [LPat Id] -> LPat Id
- mk_tup_pat [p] = p
- mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
--}
-\end{code}
-
%************************************************************************
%* *
| idName v `elem` conversionNames
, let fun_ty = exprType (co_fn (Var v))
, Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
- , arg_ty `tcEqType` res_ty -- So we are converting ty -> ty
+ , arg_ty `eqType` res_ty -- So we are converting ty -> ty
= warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
, nest 2 $ ptext (sLit "can probably be omitted")
, parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)"))
\begin{code}
-- Warn about certain types of values discarded in monadic bindings (#3263)
-warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM ()
-warnDiscardedDoBindings rhs container_ty returning_ty = do {
- -- Warn about discarding non-() things in 'monadic' binding
- ; warn_unused <- doptDs Opt_WarnUnusedDoBind
- ; if warn_unused && not (returning_ty `tcEqType` unitTy)
- then warnDs (unusedMonadBind rhs returning_ty)
- else do {
- -- Warn about discarding m a things in 'monadic' binding of the same type,
- -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
- ; warn_wrong <- doptDs Opt_WarnWrongDoBind
- ; case tcSplitAppTy_maybe returning_ty of
- Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $
- warnDs (wrongMonadBind rhs returning_ty)
- _ -> return () } }
+warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()
+warnDiscardedDoBindings rhs rhs_ty
+ | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
+ = do { -- Warn about discarding non-() things in 'monadic' binding
+ ; warn_unused <- doptDs Opt_WarnUnusedDoBind
+ ; if warn_unused && not (isUnitTy elt_ty)
+ then warnDs (unusedMonadBind rhs elt_ty)
+ else
+ -- Warn about discarding m a things in 'monadic' binding of the same type,
+ -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
+ do { warn_wrong <- doptDs Opt_WarnWrongDoBind
+ ; case tcSplitAppTy_maybe elt_ty of
+ Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty
+ -> warnDs (wrongMonadBind rhs elt_ty)
+ _ -> return () } }
+
+ | otherwise -- RHS does have type of form (m ty), which is wierd
+ = return () -- but at lesat this warning is irrelevant
unusedMonadBind :: LHsExpr Id -> Type -> SDoc
-unusedMonadBind rhs returning_ty
- = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
+unusedMonadBind rhs elt_ty
+ = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
ptext (sLit "or by using the flag -fno-warn-unused-do-bind")
wrongMonadBind :: LHsExpr Id -> Type -> SDoc
-wrongMonadBind rhs returning_ty
- = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$
+wrongMonadBind rhs elt_ty
+ = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$
ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$
ptext (sLit "or by using the flag -fno-warn-wrong-do-bind")
\end{code}
import TyCon
import Coercion
import TcType
-import Var
import CmmExpr
import CmmUtils
IsFunction
_ -> IsData
(resTy, foRhs) <- resultWrapper ty
- ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this
+ ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
let
rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
stdcall_info = fun_type_arg_stdcall_info cconv ty
ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
- let io_app = mkLams tvs $
- Lam cback $
- mkCoerceI (mkSymCoI co) $
+ let io_app = mkLams tvs $
+ Lam cback $
+ mkCoerce (mkSymCo co) $
mkApps (Var bindIOId)
[ Type stable_ptr_ty
, Type res_ty
typeCmmType (mkStablePtrPrimTy alphaTy))
-- stuff to do with the return type of the C function
- res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes
+ res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes
cResType | res_hty_is_unit = text "void"
| otherwise = showStgType res_hty
-- e.g. 'W' is a signed 32-bit integer.
primTyDescChar :: Type -> Char
primTyDescChar ty
- | ty `coreEqType` unitTy = 'v'
+ | ty `eqType` unitTy = 'v'
| otherwise
= case typePrimRep (getPrimTyOf ty) of
IntRep -> signed_word
-- NB: The success of this clause depends on the typechecker not
-- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
-- If it does, you'll get bogus overlap warnings
-matchGuards (ExprStmt e _ _ : stmts) ctx rhs rhs_ty
+matchGuards (ExprStmt e _ _ _ : stmts) ctx rhs rhs_ty
| Just addTicks <- isTrueLHsExpr e = do
match_result <- matchGuards stmts ctx rhs rhs_ty
return (adjustMatchResultDs addTicks match_result)
-matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty = do
+matchGuards (ExprStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
match_result <- matchGuards stmts ctx rhs rhs_ty
pred_expr <- dsLExpr expr
return (mkGuardedMatchResult pred_expr match_result)
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-Desugaring list comprehensions and array comprehensions
+Desugaring list comprehensions, monad comprehensions and array comprehensions
\begin{code}
+{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS -fno-warn-incomplete-patterns #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-module DsListComp ( dsListComp, dsPArrComp ) where
+module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where
#include "HsVersions.h"
-import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
import HsSyn
import TcHsSyn
import SrcLoc
import Outputable
import FastString
+import TcType
\end{code}
List comprehensions may be desugared in one of two ways: ``ordinary''
\begin{code}
dsListComp :: [LStmt Id]
- -> LHsExpr Id
- -> Type -- Type of list elements
+ -> Type -- Type of entire list
-> DsM CoreExpr
-dsListComp lquals body elt_ty = do
+dsListComp lquals res_ty = do
dflags <- getDOptsDs
let quals = map unLoc lquals
+ elt_ty = case tcTyConAppArgs res_ty of
+ [elt_ty] -> elt_ty
+ _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)
if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags
-- Either rules are switched off, or we are ignoring what there are;
-- Wadler-style desugaring
|| isParallelComp quals
-- Foldr-style desugaring can't handle parallel list comprehensions
- then deListComp quals body (mkNilExpr elt_ty)
- else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals body)
+ then deListComp quals (mkNilExpr elt_ty)
+ else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)
-- Foldr/build should be enabled, so desugar
-- into foldrs and builds
-- mix of possibly a single element in length, so we do this to leave the possibility open
isParallelComp = any isParallelStmt
- isParallelStmt (ParStmt _) = True
- isParallelStmt _ = False
+ isParallelStmt (ParStmt _ _ _ _) = True
+ isParallelStmt _ = False
-- This function lets you desugar a inner list comprehension and a list of the binders
-- of that comprehension that we need in the outer comprehension into such an expression
-- and the type of the elements that it outputs (tuples of binders)
dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type)
-dsInnerListComp (stmts, bndrs) = do
- expr <- dsListComp stmts (mkBigLHsVarTup bndrs) bndrs_tuple_type
- return (expr, bndrs_tuple_type)
- where
- bndrs_types = map idType bndrs
- bndrs_tuple_type = mkBigCoreTupTy bndrs_types
-
+dsInnerListComp (stmts, bndrs)
+ = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)])
+ (mkListTy bndrs_tuple_type)
+ ; return (expr, bndrs_tuple_type) }
+ where
+ bndrs_tuple_type = mkBigCoreVarTupTy bndrs
--- This function factors out commonality between the desugaring strategies for TransformStmt.
--- Given such a statement it gives you back an expression representing how to compute the transformed
--- list and the tuple that you need to bind from that list in order to proceed with your desugaring
-dsTransformStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
-dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr)
- = do { (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders)
- ; usingExpr' <- dsLExpr usingExpr
-
- ; using_args <-
- case maybeByExpr of
- Nothing -> return [expr]
- Just byExpr -> do
- byExpr' <- dsLExpr byExpr
-
- us <- newUniqueSupply
- [tuple_binder] <- newSysLocalsDs [binders_tuple_type]
- let byExprWrapper = mkTupleCase us binders byExpr' tuple_binder (Var tuple_binder)
-
- return [Lam tuple_binder byExprWrapper, expr]
-
- ; let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args)
- pat = mkBigLHsVarPatTup binders
- ; return (inner_list_expr, pat) }
-
-- This function factors out commonality between the desugaring strategies for GroupStmt.
-- Given such a statement it gives you back an expression representing how to compute the transformed
-- list and the tuple that you need to bind from that list in order to proceed with your desugaring
-dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
-dsGroupStmt (GroupStmt stmts binderMap by using) = do
- let (fromBinders, toBinders) = unzip binderMap
-
- fromBindersTypes = map idType fromBinders
- toBindersTypes = map idType toBinders
-
- toBindersTupleType = mkBigCoreTupTy toBindersTypes
+dsTransStmt :: Stmt Id -> DsM (CoreExpr, LPat Id)
+dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
+ , trS_by = by, trS_using = using }) = do
+ let (from_bndrs, to_bndrs) = unzip binderMap
+ from_bndrs_tys = map idType from_bndrs
+ to_bndrs_tys = map idType to_bndrs
+ to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
-- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
- (expr, from_tup_ty) <- dsInnerListComp (stmts, fromBinders)
+ (expr, from_tup_ty) <- dsInnerListComp (stmts, from_bndrs)
-- Work out what arguments should be supplied to that expression: i.e. is an extraction
-- function required? If so, create that desugared function and add to arguments
- usingExpr' <- dsLExpr (either id noLoc using)
+ usingExpr' <- dsLExpr using
usingArgs <- case by of
Nothing -> return [expr]
Just by_e -> do { by_e' <- dsLExpr by_e
- ; us <- newUniqueSupply
- ; [from_tup_id] <- newSysLocalsDs [from_tup_ty]
- ; let by_wrap = mkTupleCase us fromBinders by_e'
- from_tup_id (Var from_tup_id)
- ; return [Lam from_tup_id by_wrap, expr] }
+ ; lam <- matchTuple from_bndrs by_e'
+ ; return [lam, expr] }
-- Create an unzip function for the appropriate arity and element types and find "map"
- (unzip_fn, unzip_rhs) <- mkUnzipBind fromBindersTypes
+ unzip_stuff <- mkUnzipBind form from_bndrs_tys
map_id <- dsLookupGlobalId mapName
-- Generate the expressions to build the grouped list
let -- First we apply the grouping function to the inner list
- inner_list_expr = mkApps usingExpr' ((Type from_tup_ty) : usingArgs)
+ inner_list_expr = mkApps usingExpr' usingArgs
-- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
-- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
-- the "b" to be a tuple of "to" lists!
- unzipped_inner_list_expr = mkApps (Var map_id)
- [Type (mkListTy from_tup_ty), Type toBindersTupleType, Var unzip_fn, inner_list_expr]
-- Then finally we bind the unzip function around that expression
- bound_unzipped_inner_list_expr = Let (Rec [(unzip_fn, unzip_rhs)]) unzipped_inner_list_expr
-
- -- Build a pattern that ensures the consumer binds into the NEW binders, which hold lists rather than single values
- let pat = mkBigLHsVarPatTup toBinders
+ bound_unzipped_inner_list_expr
+ = case unzip_stuff of
+ Nothing -> inner_list_expr
+ Just (unzip_fn, unzip_rhs) -> Let (Rec [(unzip_fn, unzip_rhs)]) $
+ mkApps (Var map_id) $
+ [ Type (mkListTy from_tup_ty)
+ , Type to_bndrs_tup_ty
+ , Var unzip_fn
+ , inner_list_expr]
+
+ -- Build a pattern that ensures the consumer binds into the NEW binders,
+ -- which hold lists rather than single values
+ let pat = mkBigLHsVarPatTup to_bndrs
return (bound_unzipped_inner_list_expr, pat)
-
\end{code}
%************************************************************************
\begin{code}
-deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr
-
-deListComp (ParStmt stmtss_w_bndrs : quals) body list
- = do
- exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
- let (exps, qual_tys) = unzip exps_and_qual_tys
-
- (zip_fn, zip_rhs) <- mkZipBind qual_tys
+deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr
- -- Deal with [e | pat <- zip l1 .. ln] in example above
- deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
- quals body list
+deListComp [] _ = panic "deListComp"
- where
- bndrs_s = map snd stmtss_w_bndrs
-
- -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
- pat = mkBigLHsPatTup pats
- pats = map mkBigLHsVarPatTup bndrs_s
-
- -- Last: the one to return
-deListComp [] body list = do -- Figure 7.4, SLPJ, p 135, rule C above
- core_body <- dsLExpr body
- return (mkConsExpr (exprType core_body) core_body list)
+deListComp (LastStmt body _ : quals) list
+ = -- Figure 7.4, SLPJ, p 135, rule C above
+ ASSERT( null quals )
+ do { core_body <- dsLExpr body
+ ; return (mkConsExpr (exprType core_body) core_body list) }
-- Non-last: must be a guard
-deListComp (ExprStmt guard _ _ : quals) body list = do -- rule B above
+deListComp (ExprStmt guard _ _ _ : quals) list = do -- rule B above
core_guard <- dsLExpr guard
- core_rest <- deListComp quals body list
+ core_rest <- deListComp quals list
return (mkIfThenElse core_guard core_rest list)
-- [e | let B, qs] = let B in [e | qs]
-deListComp (LetStmt binds : quals) body list = do
- core_rest <- deListComp quals body list
+deListComp (LetStmt binds : quals) list = do
+ core_rest <- deListComp quals list
dsLocalBinds binds core_rest
-deListComp (stmt@(TransformStmt {}) : quals) body list = do
- (inner_list_expr, pat) <- dsTransformStmt stmt
- deBindComp pat inner_list_expr quals body list
+deListComp (stmt@(TransStmt {}) : quals) list = do
+ (inner_list_expr, pat) <- dsTransStmt stmt
+ deBindComp pat inner_list_expr quals list
-deListComp (stmt@(GroupStmt {}) : quals) body list = do
- (inner_list_expr, pat) <- dsGroupStmt stmt
- deBindComp pat inner_list_expr quals body list
-
-deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' above
+deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above
core_list1 <- dsLExpr list1
- deBindComp pat core_list1 quals body core_list2
+ deBindComp pat core_list1 quals core_list2
+
+deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
+ = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
+ ; let (exps, qual_tys) = unzip exps_and_qual_tys
+
+ ; (zip_fn, zip_rhs) <- mkZipBind qual_tys
+
+ -- Deal with [e | pat <- zip l1 .. ln] in example above
+ ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
+ quals list }
+ where
+ bndrs_s = map snd stmtss_w_bndrs
+
+ -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
+ pat = mkBigLHsPatTup pats
+ pats = map mkBigLHsVarPatTup bndrs_s
\end{code}
deBindComp :: OutPat Id
-> CoreExpr
-> [Stmt Id]
- -> LHsExpr Id
-> CoreExpr
-> DsM (Expr Id)
-deBindComp pat core_list1 quals body core_list2 = do
+deBindComp pat core_list1 quals core_list2 = do
let
u3_ty@u1_ty = exprType core_list1 -- two names, same thing
core_fail = App (Var h) (Var u3)
letrec_body = App (Var h) core_list1
- rest_expr <- deListComp quals body core_fail
+ rest_expr <- deListComp quals core_fail
core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
let
\begin{code}
dfListComp :: Id -> Id -- 'c' and 'n'
-> [Stmt Id] -- the rest of the qual's
- -> LHsExpr Id
-> DsM CoreExpr
- -- Last: the one to return
-dfListComp c_id n_id [] body = do
- core_body <- dsLExpr body
- return (mkApps (Var c_id) [core_body, Var n_id])
+dfListComp _ _ [] = panic "dfListComp"
+
+dfListComp c_id n_id (LastStmt body _ : quals)
+ = ASSERT( null quals )
+ do { core_body <- dsLExpr body
+ ; return (mkApps (Var c_id) [core_body, Var n_id]) }
-- Non-last: must be a guard
-dfListComp c_id n_id (ExprStmt guard _ _ : quals) body = do
+dfListComp c_id n_id (ExprStmt guard _ _ _ : quals) = do
core_guard <- dsLExpr guard
- core_rest <- dfListComp c_id n_id quals body
+ core_rest <- dfListComp c_id n_id quals
return (mkIfThenElse core_guard core_rest (Var n_id))
-dfListComp c_id n_id (LetStmt binds : quals) body = do
+dfListComp c_id n_id (LetStmt binds : quals) = do
-- new in 1.3, local bindings
- core_rest <- dfListComp c_id n_id quals body
+ core_rest <- dfListComp c_id n_id quals
dsLocalBinds binds core_rest
-dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) body = do
- (inner_list_expr, pat) <- dsTransformStmt stmt
- -- Anyway, we bind the newly transformed list via the generic binding function
- dfBindComp c_id n_id (pat, inner_list_expr) quals body
-
-dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) body = do
- (inner_list_expr, pat) <- dsGroupStmt stmt
+dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
+ (inner_list_expr, pat) <- dsTransStmt stmt
-- Anyway, we bind the newly grouped list via the generic binding function
- dfBindComp c_id n_id (pat, inner_list_expr) quals body
+ dfBindComp c_id n_id (pat, inner_list_expr) quals
-dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body = do
+dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do
-- evaluate the two lists
core_list1 <- dsLExpr list1
-- Do the rest of the work in the generic binding builder
- dfBindComp c_id n_id (pat, core_list1) quals body
+ dfBindComp c_id n_id (pat, core_list1) quals
dfBindComp :: Id -> Id -- 'c' and 'n'
-> (LPat Id, CoreExpr)
-> [Stmt Id] -- the rest of the qual's
- -> LHsExpr Id
-> DsM CoreExpr
-dfBindComp c_id n_id (pat, core_list1) quals body = do
+dfBindComp c_id n_id (pat, core_list1) quals = do
-- find the required type
let x_ty = hsLPatType pat
b_ty = idType n_id
[b, x] <- newSysLocalsDs [b_ty, x_ty]
-- build rest of the comprehesion
- core_rest <- dfListComp c_id b quals body
+ core_rest <- dfListComp c_id b quals
-- build the pattern match
core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
-- Increasing order of tag
-mkUnzipBind :: [Type] -> DsM (Id, CoreExpr)
+mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))
-- mkUnzipBind [t1, t2]
-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
-- -> case ax of
-- ys)
--
-- We use foldr here in all cases, even if rules are turned off, because we may as well!
-mkUnzipBind elt_tys = do
- ax <- newSysLocalDs elt_tuple_ty
- axs <- newSysLocalDs elt_list_tuple_ty
- ys <- newSysLocalDs elt_tuple_list_ty
- xs <- mapM newSysLocalDs elt_tys
- xss <- mapM newSysLocalDs elt_list_tys
+mkUnzipBind ThenForm _
+ = return Nothing -- No unzipping for ThenForm
+mkUnzipBind _ elt_tys
+ = do { ax <- newSysLocalDs elt_tuple_ty
+ ; axs <- newSysLocalDs elt_list_tuple_ty
+ ; ys <- newSysLocalDs elt_tuple_list_ty
+ ; xs <- mapM newSysLocalDs elt_tys
+ ; xss <- mapM newSysLocalDs elt_list_tys
- unzip_fn <- newSysLocalDs unzip_fn_ty
-
- [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
-
- let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
-
- concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
- tupled_concat_expression = mkBigCoreTup concat_expressions
-
- folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
- folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
- folder_body = mkLams [ax, axs] folder_body_outer_case
-
- unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
- return (unzip_fn, mkLams [ys] unzip_body)
+ ; unzip_fn <- newSysLocalDs unzip_fn_ty
+
+ ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
+
+ ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
+ concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
+ tupled_concat_expression = mkBigCoreTup concat_expressions
+
+ folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
+ folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
+ folder_body = mkLams [ax, axs] folder_body_outer_case
+
+ ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
+ ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }
where
elt_tuple_ty = mkBigCoreTupTy elt_tys
elt_tuple_list_ty = mkListTy elt_tuple_ty
unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
-
-
-
\end{code}
%************************************************************************
-- [:e | qss:] = <<[:e | qss:]>> () [:():]
--
dsPArrComp :: [Stmt Id]
- -> LHsExpr Id
- -> Type -- Don't use; called with `undefined' below
-> DsM CoreExpr
-dsPArrComp [ParStmt qss] body _ = -- parallel comprehension
- dePArrParComp qss body
+
+-- Special case for parallel comprehension
+dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
-- Special case for simple generators:
--
-- <<[:e' | p <- e, qs:]>> =
-- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
--
-dsPArrComp (BindStmt p e _ _ : qs) body _ = do
+dsPArrComp (BindStmt p e _ _ : qs) = do
filterP <- dsLookupDPHId filterPName
ce <- dsLExpr e
let ety'ce = parrElemType ce
pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false
let gen | isIrrefutableHsPat p = ce
| otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]
- dePArrComp qs body p gen
+ dePArrComp qs p gen
-dsPArrComp qs body _ = do -- no ParStmt in `qs'
+dsPArrComp qs = do -- no ParStmt in `qs'
sglP <- dsLookupDPHId singletonPName
let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]
- dePArrComp qs body (noLoc $ WildPat unitTy) unitArray
+ dePArrComp qs (noLoc $ WildPat unitTy) unitArray
-- the work horse
--
dePArrComp :: [Stmt Id]
- -> LHsExpr Id
-> LPat Id -- the current generator pattern
-> CoreExpr -- the current generator expression
-> DsM CoreExpr
+
+dePArrComp [] _ _ = panic "dePArrComp"
+
--
-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea
--
-dePArrComp [] e' pa cea = do
- mapP <- dsLookupDPHId mapPName
- let ty = parrElemType cea
- (clam, ty'e') <- deLambda ty pa e'
- return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea]
+dePArrComp (LastStmt e' _ : quals) pa cea
+ = ASSERT( null quals )
+ do { mapP <- dsLookupDPHId mapPName
+ ; let ty = parrElemType cea
+ ; (clam, ty'e') <- deLambda ty pa e'
+ ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }
--
-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)
--
-dePArrComp (ExprStmt b _ _ : qs) body pa cea = do
+dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do
filterP <- dsLookupDPHId filterPName
let ty = parrElemType cea
(clam,_) <- deLambda ty pa b
- dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea])
+ dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])
--
-- <<[:e' | p <- e, qs:]>> pa ea =
-- in
-- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
--
-dePArrComp (BindStmt p e _ _ : qs) body pa cea = do
+dePArrComp (BindStmt p e _ _ : qs) pa cea = do
filterP <- dsLookupDPHId filterPName
crossMapP <- dsLookupDPHId crossMapPName
ce <- dsLExpr e
let ety'cef = ety'ce -- filter doesn't change the element type
pa' = mkLHsPatTup [pa, p]
- dePArrComp qs body pa' (mkApps (Var crossMapP)
+ dePArrComp qs pa' (mkApps (Var crossMapP)
[Type ety'cea, Type ety'cef, cea, clam])
--
-- <<[:e' | let ds, qs:]>> pa ea =
-- where
-- {x_1, ..., x_n} = DV (ds) -- Defined Variables
--
-dePArrComp (LetStmt ds : qs) body pa cea = do
+dePArrComp (LetStmt ds : qs) pa cea = do
mapP <- dsLookupDPHId mapPName
let xs = collectLocalBinders ds
ty'cea = parrElemType cea
ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr
let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]
proj = mkLams [v] ccase
- dePArrComp qs body pa' (mkApps (Var mapP)
+ dePArrComp qs pa' (mkApps (Var mapP)
[Type ty'cea, Type errTy, proj, cea])
--
-- The parser guarantees that parallel comprehensions can only appear as
-- singeltons qualifier lists, which we already special case in the caller.
-- So, encountering one here is a bug.
--
-dePArrComp (ParStmt _ : _) _ _ _ =
+dePArrComp (ParStmt _ _ _ _ : _) _ _ =
panic "DsListComp.dePArrComp: malformed comprehension AST"
-- <<[:e' | qs | qss:]>> pa ea =
-- where
-- {x_1, ..., x_n} = DV (qs)
--
-dePArrParComp :: [([LStmt Id], [Id])] -> LHsExpr Id -> DsM CoreExpr
-dePArrParComp qss body = do
+dePArrParComp :: [([LStmt Id], [Id])] -> [Stmt Id] -> DsM CoreExpr
+dePArrParComp qss quals = do
(pQss, ceQss) <- deParStmt qss
- dePArrComp [] body pQss ceQss
+ dePArrComp quals pQss ceQss
where
deParStmt [] =
-- empty parallel statement lists have no source representation
panic "DsListComp.dePArrComp: Empty parallel list comprehension"
deParStmt ((qs, xs):qss) = do -- first statement
let res_expr = mkLHsVarTuple xs
- cqs <- dsPArrComp (map unLoc qs) res_expr undefined
+ cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
parStmts qss (mkLHsVarPatTup xs) cqs
---
parStmts [] pa cea = return (pa, cea)
let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]
ty'cea = parrElemType cea
res_expr = mkLHsVarTuple xs
- cqs <- dsPArrComp (map unLoc qs) res_expr undefined
+ cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
let ty'cqs = parrElemType cqs
cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]
parStmts qss pa' cea'
_ -> panic
"DsListComp.parrElemType: not a parallel array type"
\end{code}
+
+Translation for monad comprehensions
+
+\begin{code}
+-- Entry point for monad comprehension desugaring
+dsMonadComp :: [LStmt Id] -> DsM CoreExpr
+dsMonadComp stmts = dsMcStmts stmts
+
+dsMcStmts :: [LStmt Id] -> DsM CoreExpr
+dsMcStmts [] = panic "dsMcStmts"
+dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
+
+---------------
+dsMcStmt :: Stmt Id -> [LStmt Id] -> DsM CoreExpr
+
+dsMcStmt (LastStmt body ret_op) stmts
+ = ASSERT( null stmts )
+ do { body' <- dsLExpr body
+ ; ret_op' <- dsExpr ret_op
+ ; return (App ret_op' body') }
+
+-- [ .. | let binds, stmts ]
+dsMcStmt (LetStmt binds) stmts
+ = do { rest <- dsMcStmts stmts
+ ; dsLocalBinds binds rest }
+
+-- [ .. | a <- m, stmts ]
+dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts
+ = do { rhs' <- dsLExpr rhs
+ ; dsMcBindStmt pat rhs' bind_op fail_op stmts }
+
+-- Apply `guard` to the `exp` expression
+--
+-- [ .. | exp, stmts ]
+--
+dsMcStmt (ExprStmt exp then_exp guard_exp _) stmts
+ = do { exp' <- dsLExpr exp
+ ; guard_exp' <- dsExpr guard_exp
+ ; then_exp' <- dsExpr then_exp
+ ; rest <- dsMcStmts stmts
+ ; return $ mkApps then_exp' [ mkApps guard_exp' [exp']
+ , rest ] }
+
+-- Group statements desugar like this:
+--
+-- [| (q, then group by e using f); rest |]
+-- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->
+-- case unzip n_tup of qv' -> [| rest |]
+--
+-- where variables (v1:t1, ..., vk:tk) are bound by q
+-- qv = (v1, ..., vk)
+-- qt = (t1, ..., tk)
+-- (>>=) :: m2 a -> (a -> m3 b) -> m3 b
+-- f :: forall a. (a -> t) -> m1 a -> m2 (n a)
+-- n_tup :: n qt
+-- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n)
+
+dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
+ , trS_by = by, trS_using = using
+ , trS_ret = return_op, trS_bind = bind_op
+ , trS_fmap = fmap_op, trS_form = form }) stmts_rest
+ = do { let (from_bndrs, to_bndrs) = unzip bndrs
+ from_bndr_tys = map idType from_bndrs -- Types ty
+
+ -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
+ ; expr <- dsInnerMonadComp stmts from_bndrs return_op
+
+ -- Work out what arguments should be supplied to that expression: i.e. is an extraction
+ -- function required? If so, create that desugared function and add to arguments
+ ; usingExpr' <- dsLExpr using
+ ; usingArgs <- case by of
+ Nothing -> return [expr]
+ Just by_e -> do { by_e' <- dsLExpr by_e
+ ; lam <- matchTuple from_bndrs by_e'
+ ; return [lam, expr] }
+
+ -- Generate the expressions to build the grouped list
+ -- Build a pattern that ensures the consumer binds into the NEW binders,
+ -- which hold monads rather than single values
+ ; bind_op' <- dsExpr bind_op
+ ; let bind_ty = exprType bind_op' -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2
+ n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty -- n (a,b,c)
+ tup_n_ty = mkBigCoreVarTupTy to_bndrs
+
+ ; body <- dsMcStmts stmts_rest
+ ; n_tup_var <- newSysLocalDs n_tup_ty
+ ; tup_n_var <- newSysLocalDs tup_n_ty
+ ; tup_n_expr <- mkMcUnzipM form fmap_op n_tup_var from_bndr_tys
+ ; us <- newUniqueSupply
+ ; let rhs' = mkApps usingExpr' usingArgs
+ body' = mkTupleCase us to_bndrs body tup_n_var tup_n_expr
+
+ ; return (mkApps bind_op' [rhs', Lam n_tup_var body']) }
+
+-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
+-- statements, for example:
+--
+-- [ body | qs1 | qs2 | qs3 ]
+-- -> [ body | (bndrs1, (bndrs2, bndrs3))
+-- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
+--
+-- where `mzip` has type
+-- mzip :: forall a b. m a -> m b -> m (a,b)
+-- NB: we need a polymorphic mzip because we call it several times
+
+dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest
+ = do { exps_w_tys <- mapM ds_inner pairs -- Pairs (exp :: m ty, ty)
+ ; mzip_op' <- dsExpr mzip_op
+
+ ; let -- The pattern variables
+ pats = map (mkBigLHsVarPatTup . snd) pairs
+ -- Pattern with tuples of variables
+ -- [v1,v2,v3] => (v1, (v2, v3))
+ pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
+ (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->
+ (mkApps mzip_op' [Type t1, Type t2, e1, e2],
+ mkBoxedTupleTy [t1,t2]))
+ exps_w_tys
+
+ ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }
+ where
+ ds_inner (stmts, bndrs) = do { exp <- dsInnerMonadComp stmts bndrs mono_ret_op
+ ; return (exp, tup_ty) }
+ where
+ mono_ret_op = HsWrap (WpTyApp tup_ty) return_op
+ tup_ty = mkBigCoreVarTupTy bndrs
+
+dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
+
+
+matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
+-- (matchTuple [a,b,c] body)
+-- returns the Core term
+-- \x. case x of (a,b,c) -> body
+matchTuple ids body
+ = do { us <- newUniqueSupply
+ ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)
+ ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
+
+-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
+-- desugared `CoreExpr`
+dsMcBindStmt :: LPat Id
+ -> CoreExpr -- ^ the desugared rhs of the bind statement
+ -> SyntaxExpr Id
+ -> SyntaxExpr Id
+ -> [LStmt Id]
+ -> DsM CoreExpr
+dsMcBindStmt pat rhs' bind_op fail_op stmts
+ = do { body <- dsMcStmts stmts
+ ; bind_op' <- dsExpr bind_op
+ ; var <- selectSimpleMatchVarL pat
+ ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2
+ res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
+ ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
+ res1_ty (cantFailMatchResult body)
+ ; match_code <- handle_failure pat match fail_op
+ ; return (mkApps bind_op' [rhs', Lam var match_code]) }
+
+ where
+ -- In a monad comprehension expression, pattern-match failure just calls
+ -- the monadic `fail` rather than throwing an exception
+ handle_failure pat match fail_op
+ | matchCanFail match
+ = do { fail_op' <- dsExpr fail_op
+ ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+ ; extractMatchResult match (App fail_op' fail_msg) }
+ | otherwise
+ = extractMatchResult match (error "It can't fail")
+
+ mk_fail_msg :: Located e -> String
+ mk_fail_msg pat = "Pattern match failure in monad comprehension at " ++
+ showSDoc (ppr (getLoc pat))
+
+-- Desugar nested monad comprehensions, for example in `then..` constructs
+-- dsInnerMonadComp quals [a,b,c] ret_op
+-- returns the desugaring of
+-- [ (a,b,c) | quals ]
+
+dsInnerMonadComp :: [LStmt Id]
+ -> [Id] -- Return a tuple of these variables
+ -> HsExpr Id -- The monomorphic "return" operator
+ -> DsM CoreExpr
+dsInnerMonadComp stmts bndrs ret_op
+ = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTup bndrs) ret_op)])
+
+-- The `unzip` function for `GroupStmt` in a monad comprehensions
+--
+-- unzip :: m (a,b,..) -> (m a,m b,..)
+-- unzip m_tuple = ( liftM selN1 m_tuple
+-- , liftM selN2 m_tuple
+-- , .. )
+--
+-- mkMcUnzipM fmap ys [t1, t2]
+-- = ( fmap (selN1 :: (t1, t2) -> t1) ys
+-- , fmap (selN2 :: (t1, t2) -> t2) ys )
+
+mkMcUnzipM :: TransForm
+ -> SyntaxExpr TcId -- fmap
+ -> Id -- Of type n (a,b,c)
+ -> [Type] -- [a,b,c]
+ -> DsM CoreExpr -- Of type (n a, n b, n c)
+mkMcUnzipM ThenForm _ ys _
+ = return (Var ys) -- No unzipping to do
+
+mkMcUnzipM _ fmap_op ys elt_tys
+ = do { fmap_op' <- dsExpr fmap_op
+ ; xs <- mapM newSysLocalDs elt_tys
+ ; let tup_ty = mkBigCoreTupTy elt_tys
+ ; tup_xs <- newSysLocalDs tup_ty
+
+ ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b
+ [ Type tup_ty, Type (elt_tys !! i)
+ , mk_sel i, Var ys]
+
+ mk_sel n = Lam tup_xs $
+ mkTupleSelector xs (xs !! n) tup_xs (Var tup_xs)
+
+ ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
+\end{code}
-- Singleton => Ok
-- Empty => Too hard, signature ignored
rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
+rep_sig (L _ (GenericSig nm _)) = failWithDs msg
+ where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm)
+ , ptext (sLit "Default signatures are not supported by Template Haskell") ]
+
rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc
rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
rep_sig _ = return []
k1 <- repKind k
repTSig t1 k1
repTy (HsSpliceTy splice _ _) = repSplice splice
-repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty)
repTy ty = notHandled "Exotic form of type" (ppr ty)
-- represent a kind
; wrapGenSyms ss z }
-- FIXME: I haven't got the types here right yet
-repE e@(HsDo ctxt sts body _)
+repE e@(HsDo ctxt sts _)
| case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False }
= do { (ss,zs) <- repLSts sts;
- body' <- addBinds ss $ repLE body;
- ret <- repNoBindSt body';
- e' <- repDoE (nonEmptyCoreList (zs ++ [ret]));
+ e' <- repDoE (nonEmptyCoreList zs);
wrapGenSyms ss e' }
| ListComp <- ctxt
= do { (ss,zs) <- repLSts sts;
- body' <- addBinds ss $ repLE body;
- ret <- repNoBindSt body';
- e' <- repComp (nonEmptyCoreList (zs ++ [ret]));
+ e' <- repComp (nonEmptyCoreList zs);
wrapGenSyms ss e' }
| otherwise
- = notHandled "mdo and [: :]" (ppr e)
+ = notHandled "mdo, monad comprehension and [: :]" (ppr e)
repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
wrapGenSyms (concat xs) gd }
where
process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
- process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2))
+ process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2))
= do { x <- repLNormalGE e1 e2;
return ([], x) }
process (L _ (GRHS ss rhs))
; z <- repLetSt ds
; (ss2,zs) <- addBinds ss1 (repSts ss)
; return (ss1++ss2, z : zs) }
-repSts (ExprStmt e _ _ : ss) =
+repSts (ExprStmt e _ _ _ : ss) =
do { e2 <- repLE e
; z <- repNoBindSt e2
; (ss2,zs) <- repSts ss
mk_integer :: Integer -> DsM HsLit
mk_integer i = do integer_ty <- lookupType integerTyConName
return $ HsInteger i integer_ty
-mk_rational :: Rational -> DsM HsLit
+mk_rational :: FractionalLit -> DsM HsLit
mk_rational r = do rat_ty <- lookupType rationalTyConName
return $ HsRat r rat_ty
mk_string :: FastString -> DsM HsLit
import MkCore
import MkId
import Id
-import Var
import Name
import Literal
import TyCon
\end{code}
-
%************************************************************************
%* *
Rebindable syntax
wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
-wrapBind new old body -- Can deal with term variables *or* type variables
- | new==old = body
- | isTyCoVar new = Let (mkTyBind new (mkTyVarTy old)) body
- | otherwise = Let (NonRec new (Var old)) body
+wrapBind new old body -- NB: this function must deal with term
+ | new==old = body -- variables, type variables or coercion variables
+ | otherwise = Let (NonRec new (varToCoreExpr old)) body
seqVar :: Var -> CoreExpr -> CoreExpr
seqVar var body = Case (Var var) var (exprType body)
return (LitAlt lit, [], body)
-mkCoAlgCaseMatchResult :: Id -- Scrutinee
- -> Type -- Type of exp
- -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives
- -> MatchResult
+mkCoAlgCaseMatchResult
+ :: Id -- Scrutinee
+ -> Type -- Type of exp
+ -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives (bndrs *include* tyvars, dicts)
+ -> MatchResult
mkCoAlgCaseMatchResult var ty match_alts
| isNewTyCon tycon -- Newtype case; use a let
= ASSERT( null (tail match_alts) && null (tail arg_ids1) )
return (bndr_var, rhs_expr)
where
error_expr = mkCoerce co (Var err_var)
- co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
+ co = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
is_simple_lpat p = is_simple_pat (unLoc p)
import MatchCon
import MatchLit
import Type
+import Coercion
import TysWiredIn
import ListSetOps
import SrcLoc
-- NPats: we *might* be able to replace these w/ a simpler form
tidy1 _ (NPat lit mb_neg eq)
- = return (idDsWrapper, tidyNPat lit mb_neg eq)
+ = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)
-- BangPatterns: Pattern matching is already strict in constructors,
-- tuples etc, so the last case strips off the bang for thoses patterns.
sameGroup (PgLit _) (PgLit _) = True -- One case expression
sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant
sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns]
-sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2
+sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2
-- CoPats are in the same goup only if the type of the
-- enclosed pattern is the same. The patterns outside the CoPat
-- always have the same type, so this boils down to saying that
-- which resolve the overloading (e.g., fromInteger 1),
-- because these expressions get written as a bunch of different variables
-- (presumably to improve sharing)
- tcEqType (overLitType l) (overLitType l') && l == l'
+ eqType (overLitType l) (overLitType l') && l == l'
exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
-- the fixities have been straightened out by now, so it's safe
-- to ignore them?
---------
tup_arg (Present e1) (Present e2) = lexp e1 e2
- tup_arg (Missing t1) (Missing t2) = tcEqType t1 t2
+ tup_arg (Missing t1) (Missing t2) = eqType t1 t2
tup_arg _ _ = False
---------
-- equating different ways of writing a coercion)
wrap WpHole WpHole = True
wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
- wrap (WpCast c) (WpCast c') = tcEqType c c'
+ wrap (WpCast c) (WpCast c') = coreEqCoercion c c'
wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2
- wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
+ wrap (WpTyApp t) (WpTyApp t') = eqType t t'
-- Enhancement: could implement equality for more wrappers
-- if it seems useful (lams and lets)
wrap _ _ = False
---------
ev_term :: EvTerm -> EvTerm -> Bool
ev_term (EvId a) (EvId b) = a==b
- ev_term (EvCoercion a) (EvCoercion b) = tcEqType a b
+ ev_term (EvCoercion a) (EvCoercion b) = coreEqCoercion a b
ev_term _ _ = False
---------
cannot jump to the third equation! Because the same argument might
match '2'!
Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
+
import Util ( all2, takeList, zipEqual )
import ListSetOps ( runs )
import Id
-import Var ( Var )
import NameEnv
import SrcLoc
import Outputable
import SrcLoc
import Data.Ratio
import Outputable
+import BasicTypes
import Util
import FastString
\end{code}
dsLit (HsCharPrim c) = return (Lit (MachChar c))
dsLit (HsIntPrim i) = return (Lit (MachInt i))
dsLit (HsWordPrim w) = return (Lit (MachWord w))
-dsLit (HsFloatPrim f) = return (Lit (MachFloat f))
-dsLit (HsDoublePrim d) = return (Lit (MachDouble d))
+dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f)))
+dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d)))
dsLit (HsChar c) = return (mkCharExpr c)
dsLit (HsString str) = mkStringExprFS str
dsLit (HsInt i) = return (mkIntExpr i)
dsLit (HsRat r ty) = do
- num <- mkIntegerExpr (numerator r)
- denom <- mkIntegerExpr (denominator r)
+ num <- mkIntegerExpr (numerator (fl_value r))
+ denom <- mkIntegerExpr (denominator (fl_value r))
return (mkConApp ratio_data_con [Type integer_ty, num, denom])
where
(ratio_data_con, integer_ty)
hsLitKey (HsWordPrim w) = mkMachWord w
hsLitKey (HsCharPrim c) = MachChar c
hsLitKey (HsStringPrim s) = MachStr s
-hsLitKey (HsFloatPrim f) = MachFloat f
-hsLitKey (HsDoublePrim d) = MachDouble d
+hsLitKey (HsFloatPrim f) = MachFloat (fl_value f)
+hsLitKey (HsDoublePrim d) = MachDouble (fl_value d)
hsLitKey (HsString s) = MachStr s
hsLitKey l = pprPanic "hsLitKey" (ppr l)
litValKey :: OverLitVal -> Bool -> Literal
litValKey (HsIntegral i) False = MachInt i
litValKey (HsIntegral i) True = MachInt (-i)
-litValKey (HsFractional r) False = MachFloat r
-litValKey (HsFractional r) True = MachFloat (-r)
+litValKey (HsFractional r) False = MachFloat (fl_value r)
+litValKey (HsFractional r) True = MachFloat (negate (fl_value r))
litValKey (HsIsString s) neg = ASSERT( not neg) MachStr s
\end{code}
tidyLitPat lit = LitPat lit
----------------
-tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id
-tidyNPat (OverLit val False _ ty) mb_neg _
+tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat
+ -- We need this argument because tidyNPat is called
+ -- both by Match and by Check, but they tidy LitPats
+ -- slightly differently; and we must desugar
+ -- literals consistently (see Trac #5117)
+ -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
+ -> Pat Id
+tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
-- False: Take short cuts only if the literal is not using rebindable syntax
--
-- Once that is settled, look for cases where the type of the
| isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim int_lit)
| isFloatTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon (HsFloatPrim rat_lit)
| isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)
- | isStringTy ty, Just str_lit <- mb_str_lit = tidyLitPat (HsString str_lit)
+ | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit)
where
mk_con_pat :: DataCon -> HsLit -> Pat Id
mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty)
(Just _, HsIntegral i) -> Just (-i)
_ -> Nothing
- mb_rat_lit :: Maybe Rational
+ mb_rat_lit :: Maybe FractionalLit
mb_rat_lit = case (mb_neg, val) of
- (Nothing, HsIntegral i) -> Just (fromInteger i)
- (Just _, HsIntegral i) -> Just (fromInteger (-i))
+ (Nothing, HsIntegral i) -> Just (integralFractionalLit (fromInteger i))
+ (Just _, HsIntegral i) -> Just (integralFractionalLit (fromInteger (-i)))
(Nothing, HsFractional f) -> Just f
- (Just _, HsFractional f) -> Just (-f)
+ (Just _, HsFractional f) -> Just (negateFractionalLit f)
_ -> Nothing
mb_str_lit :: Maybe FastString
(Nothing, HsIsString s) -> Just s
_ -> Nothing
-tidyNPat over_lit mb_neg eq
+tidyNPat _ over_lit mb_neg eq
= NPat over_lit mb_neg eq
\end{code}
Default: False
Manual: True
-Flag ncg
- Description: Build the NCG.
- Default: False
- Manual: True
-
Flag stage1
Description: Is this stage 1?
Default: False
CPP-Options: -DGHCI
Include-Dirs: ../libffi/build/include
- if !flag(ncg)
- CPP-Options: -DOMIT_NATIVE_CODEGEN
-
Build-Depends: bin-package-db
Build-Depends: hoopl
Generics
InstEnv
TyCon
+ Kind
Type
TypeRep
Unify
MonadUtils
OrdList
Outputable
+ Pair
Panic
Pretty
Serialized
Vectorise.Exp
Vectorise
- -- We only need to expose more modules as some of the ncg code is used
- -- by the LLVM backend so its always included
- if flag(ncg)
- Exposed-Modules:
+ Exposed-Modules:
AsmCodeGen
TargetReg
NCGMonad
RegClass
PIC
Platform
- Alpha.Regs
- Alpha.RegInfo
- Alpha.Instr
- Alpha.CodeGen
X86.Regs
X86.RegInfo
X86.Instr
TcSplice
Convert
ByteCodeAsm
- ByteCodeFFI
ByteCodeGen
ByteCodeInstr
ByteCodeItbls
@echo '{-# LANGUAGE CPP #-}' >> $@
@echo 'module Config where' >> $@
@echo >> $@
- @echo 'import Distribution.System' >> $@
- @echo >> $@
@echo '#include "ghc_boot_platform.h"' >> $@
@echo >> $@
@echo 'cBuildPlatformString :: String' >> $@
@echo 'cTargetPlatformString :: String' >> $@
@echo 'cTargetPlatformString = TargetPlatform_NAME' >> $@
@echo >> $@
-# Sync this with checkArch in configure.ac
- @echo 'cTargetArch :: Arch' >> $@
- @echo '#if i386_TARGET_ARCH' >> $@
- @echo 'cTargetArch = I386' >> $@
- @echo '#elif x86_64_TARGET_ARCH' >> $@
- @echo 'cTargetArch = X86_64' >> $@
- @echo '#elif powerpc_TARGET_ARCH' >> $@
- @echo 'cTargetArch = PPC' >> $@
- @echo '#elif powerpc64_TARGET_ARCH' >> $@
- @echo 'cTargetArch = PPC64' >> $@
- @echo '#elif sparc_TARGET_ARCH || sparc64_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Sparc' >> $@
- @echo '#elif arm_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Arm' >> $@
- @echo '#elif mips_TARGET_ARCH || mipseb_TARGET_ARCH || mipsel_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Mips' >> $@
- @echo '#elif 0' >> $@
- @echo 'cTargetArch = SH' >> $@
- @echo '#elif ia64_TARGET_ARCH' >> $@
- @echo 'cTargetArch = IA64' >> $@
- @echo '#elif s390_TARGET_ARCH' >> $@
- @echo 'cTargetArch = S390' >> $@
- @echo '#elif alpha_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Alpha' >> $@
- @echo '#elif hppa_TARGET_ARCH || hppa1_1_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Hppa' >> $@
- @echo '#elif rs6000_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Rs6000' >> $@
- @echo '#elif m68k_TARGET_ARCH' >> $@
- @echo 'cTargetArch = M68k' >> $@
- @echo '#elif vax_TARGET_ARCH' >> $@
- @echo 'cTargetArch = Vax' >> $@
- @echo '#else' >> $@
- @echo '#error Unknown target arch' >> $@
- @echo '#endif' >> $@
- @echo >> $@
@echo 'cProjectName :: String' >> $@
@echo 'cProjectName = "$(ProjectName)"' >> $@
@echo 'cProjectVersion :: String' >> $@
@echo 'cBooterVersion = "$(GhcVersion)"' >> $@
@echo 'cStage :: String' >> $@
@echo 'cStage = show (STAGE :: Int)' >> $@
- @echo 'cCcOpts :: [String]' >> $@
- @echo 'cCcOpts = words "$(CONF_CC_OPTS_STAGE$*)"' >> $@
@echo 'cGccLinkerOpts :: [String]' >> $@
@echo 'cGccLinkerOpts = words "$(CONF_GCC_LINKER_OPTS_STAGE$*)"' >> $@
@echo 'cLdLinkerOpts :: [String]' >> $@
compiler/primop-has-side-effects.hs-incl \
compiler/primop-out-of-line.hs-incl \
compiler/primop-commutable.hs-incl \
- compiler/primop-needs-wrapper.hs-incl \
+ compiler/primop-code-size.hs-incl \
compiler/primop-can-fail.hs-incl \
compiler/primop-strictness.hs-incl \
compiler/primop-primop-info.hs-incl
"$(GENPRIMOP_INPLACE)" --out-of-line < $< > $@
compiler/primop-commutable.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
"$(GENPRIMOP_INPLACE)" --commutable < $< > $@
-compiler/primop-needs-wrapper.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
- "$(GENPRIMOP_INPLACE)" --needs-wrapper < $< > $@
+compiler/primop-code-size.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
+ "$(GENPRIMOP_INPLACE)" --code-size < $< > $@
compiler/primop-can-fail.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
"$(GENPRIMOP_INPLACE)" --can-fail < $< > $@
compiler/primop-strictness.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE)
endif
-ifeq "$(GhcWithNativeCodeGen)" "NO"
-# XXX This should logically be a CPP option, but there doesn't seem to
-# be a flag for that
-compiler_CONFIGURE_OPTS += --ghc-option=-DOMIT_NATIVE_CODEGEN
-endif
-
ifeq "$(TargetOS_CPP)" "openbsd"
compiler_CONFIGURE_OPTS += --ld-options=-E
endif
import Constants
import FastString
import SMRep
+import DynFlags
import Outputable
+import Platform
import Control.Monad ( foldM )
import Control.Monad.ST ( runST )
-- bytecode address in this BCO.
-- Top level assembler fn.
-assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
-assembleBCOs proto_bcos tycons
+assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode
+assembleBCOs dflags proto_bcos tycons
= do itblenv <- mkITbls tycons
- bcos <- mapM assembleBCO proto_bcos
+ bcos <- mapM (assembleBCO dflags) proto_bcos
return (ByteCode bcos itblenv)
-assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO
-assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
+assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
+assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
= let
-- pass 1: collect up the offsets of the local labels.
-- Remember that the first insn starts at offset
ptrs <- return emptySS :: IO (SizedSeq BCOPtr)
let init_asm_state = (insns,lits,ptrs)
(final_insns, final_lits, final_ptrs)
- <- mkBits findLabel init_asm_state instrs
+ <- mkBits dflags findLabel init_asm_state instrs
let asm_insns = ssElts final_insns
n_insns = sizeSS final_insns
| otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
-- This is where all the action is (pass 2 of the assembler)
-mkBits :: (Word16 -> Word) -- label finder
+mkBits :: DynFlags
+ -> (Word16 -> Word) -- label finder
-> AsmState
-> [BCInstr] -- instructions (in)
-> IO AsmState
-mkBits findLabel st proto_insns
+mkBits dflags findLabel st proto_insns
= foldM doInstr st proto_insns
where
doInstr :: AsmState -> BCInstr -> IO AsmState
instr2 st2 bci_PUSH_G p
PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op)
instr2 st2 bci_PUSH_G p
- PUSH_BCO proto -> do ul_bco <- assembleBCO proto
+ PUSH_BCO proto -> do ul_bco <- assembleBCO dflags proto
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 bci_PUSH_G p
- PUSH_ALTS proto -> do ul_bco <- assembleBCO proto
+ PUSH_ALTS proto -> do ul_bco <- assembleBCO dflags proto
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 bci_PUSH_ALTS p
PUSH_ALTS_UNLIFTED proto pk -> do
- ul_bco <- assembleBCO proto
+ ul_bco <- assembleBCO dflags proto
(p, st2) <- ptr st (BCOPtrBCO ul_bco)
instr2 st2 (push_alts pk) p
PUSH_UBX (Left lit) nws
= do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon))
return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
-#ifdef mingw32_TARGET_OS
literal st (MachLabel fs (Just sz) _)
+ | platformOS (targetPlatform dflags) == OSMinGW32
= litlabel st (appendFS fs (mkFastString ('@':show sz)))
-- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo@8. testcase: ffi012(ghci)
-#endif
literal st (MachLabel fs _ _) = litlabel st fs
literal st (MachWord w) = int st (fromIntegral w)
literal st (MachInt j) = int st (fromIntegral j)
+++ /dev/null
-%
-% (c) The University of Glasgow 2001-2008
-%
-
-ByteCodeGen: Generate machine-code sequences for foreign import
-
-\begin{code}
-module ByteCodeFFI ( moan64 ) where
-
-import Outputable
-import System.IO
-import System.IO.Unsafe
-
-moan64 :: String -> SDoc -> a
-moan64 msg pp_rep
- = unsafePerformIO (
- hPutStrLn stderr (
- "\nGHCi's bytecode generation machinery can't handle 64-bit\n" ++
- "code properly yet. You can work around this for the time being\n" ++
- "by compiling this module and all those it imports to object code,\n" ++
- "and re-starting your GHCi session. The panic below contains information,\n" ++
- "intended for the GHC implementors, about the exact place where GHC gave up.\n"
- )
- )
- `seq`
- pprPanic msg pp_rep
-\end{code}
-
import Type
import DataCon
import TyCon
--- import Type
import Util
--- import DataCon
-import Var
import VarSet
import TysPrim
import DynFlags
import Foreign
import Foreign.C
--- import GHC.Exts ( Int(..) )
-
-import Control.Monad ( when )
+import Control.Monad
import Data.Char
import UniqSupply
import BreakArray
import Data.Maybe
-import Module
-import IdInfo
+import Module
+import IdInfo
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
-- -----------------------------------------------------------------------------
--- Generating byte code for a complete module
+-- Generating byte code for a complete module
byteCodeGen :: DynFlags
-> [CoreBind]
- -> [TyCon]
- -> ModBreaks
+ -> [TyCon]
+ -> ModBreaks
-> IO CompiledByteCode
-byteCodeGen dflags binds tycs modBreaks
+byteCodeGen dflags binds tycs modBreaks
= do showPass dflags "ByteCodeGen"
- let flatBinds = [ (bndr, freeVars rhs)
- | (bndr, rhs) <- flattenBinds binds]
+ let flatBinds = [ (bndr, freeVars rhs)
+ | (bndr, rhs) <- flattenBinds binds]
- us <- mkSplitUniqSupply 'y'
- (BcM_State _us _final_ctr mallocd _, proto_bcos)
- <- runBc us modBreaks (mapM schemeTopBind flatBinds)
+ us <- mkSplitUniqSupply 'y'
+ (BcM_State _us _final_ctr mallocd _, proto_bcos)
+ <- runBc us modBreaks (mapM schemeTopBind flatBinds)
when (notNull mallocd)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
- assembleBCOs proto_bcos tycs
-
+ assembleBCOs dflags proto_bcos tycs
+
-- -----------------------------------------------------------------------------
-- Generating byte code for an expression
--- Returns: (the root BCO for this expression,
+-- Returns: (the root BCO for this expression,
-- a list of auxilary BCOs resulting from compiling closures)
coreExprToBCOs :: DynFlags
- -> CoreExpr
+ -> CoreExpr
-> IO UnlinkedBCO
coreExprToBCOs dflags expr
= do showPass dflags "ByteCodeGen"
-- should be harmless, since it's never used for anything
let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
invented_id = Id.mkLocalId invented_name (panic "invented_id's type")
-
+
-- the uniques are needed to generate fresh variables when we introduce new
-- let bindings for ticked expressions
us <- mkSplitUniqSupply 'y'
- (BcM_State _us _final_ctr mallocd _ , proto_bco)
+ (BcM_State _us _final_ctr mallocd _ , proto_bco)
<- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr))
when (notNull mallocd)
dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
- assembleBCO proto_bco
+ assembleBCO dflags proto_bco
-- -----------------------------------------------------------------------------
-> Int
-> Word16
-> [StgWord]
- -> Bool -- True <=> is a return point, rather than a function
+ -> Bool -- True <=> is a return point, rather than a function
-> [BcPtr]
-> ProtoBCO name
-mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
+mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
= ProtoBCO {
- protoBCOName = nm,
- protoBCOInstrs = maybe_with_stack_check,
- protoBCOBitmap = bitmap,
- protoBCOBitmapSize = bitmap_size,
- protoBCOArity = arity,
- protoBCOExpr = origin,
- protoBCOPtrs = mallocd_blocks
+ protoBCOName = nm,
+ protoBCOInstrs = maybe_with_stack_check,
+ protoBCOBitmap = bitmap,
+ protoBCOBitmapSize = bitmap_size,
+ protoBCOArity = arity,
+ protoBCOExpr = origin,
+ protoBCOPtrs = mallocd_blocks
}
where
-- Overestimate the stack usage (in words) of this BCO,
-- (hopefully rare) cases when the (overestimated) stack use
-- exceeds iNTERP_STACK_CHECK_THRESH.
maybe_with_stack_check
- | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d
- -- don't do stack checks at return points,
- -- everything is aggregated up to the top BCO
- -- (which must be a function).
+ | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d
+ -- don't do stack checks at return points,
+ -- everything is aggregated up to the top BCO
+ -- (which must be a function).
-- That is, unless the stack usage is >= AP_STACK_SPLIM,
-- see bug #1466.
| stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
= STKCHECK stack_usage : peep_d
| otherwise
- = peep_d -- the supposedly common case
-
+ = peep_d -- the supposedly common case
+
-- We assume that this sum doesn't wrap
stack_usage = sum (map bciStackUse peep_d)
schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
-schemeTopBind (id, rhs)
+schemeTopBind (id, rhs)
| Just data_con <- isDataConWorkId_maybe id,
isNullaryRepDataCon data_con = do
- -- Special case for the worker of a nullary data con.
- -- It'll look like this: Nil = /\a -> Nil a
- -- If we feed it into schemeR, we'll get
- -- Nil = Nil
- -- because mkConAppCode treats nullary constructor applications
- -- by just re-using the single top-level definition. So
- -- for the worker itself, we must allocate it directly.
+ -- Special case for the worker of a nullary data con.
+ -- It'll look like this: Nil = /\a -> Nil a
+ -- If we feed it into schemeR, we'll get
+ -- Nil = Nil
+ -- because mkConAppCode treats nullary constructor applications
+ -- by just re-using the single top-level definition. So
+ -- for the worker itself, we must allocate it directly.
-- ioToBc (putStrLn $ "top level BCO")
emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
- (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
+ (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
| otherwise
= schemeR [{- No free variables -}] (id, rhs)
--
-- Park the resulting BCO in the monad. Also requires the
-- variable to which this value was bound, so as to give the
--- resulting BCO a name.
+-- resulting BCO a name.
-schemeR :: [Id] -- Free vars of the RHS, ordered as they
- -- will appear in the thunk. Empty for
- -- top-level things, which have no free vars.
- -> (Id, AnnExpr Id VarSet)
- -> BcM (ProtoBCO Name)
+schemeR :: [Id] -- Free vars of the RHS, ordered as they
+ -- will appear in the thunk. Empty for
+ -- top-level things, which have no free vars.
+ -> (Id, AnnExpr Id VarSet)
+ -> BcM (ProtoBCO Name)
schemeR fvs (nm, rhs)
{-
| trace (showSDoc (
(char ' '
- $$ (ppr.filter (not.isTyCoVar).varSetElems.fst) rhs
+ $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
$$ pprCoreExpr (deAnnotate rhs)
$$ char ' '
))) False
go xs (AnnLam x (_,e)) = go (x:xs) e
go xs not_lambda = (reverse xs, not_lambda)
-schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
+schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
- = let
- all_args = reverse args ++ fvs
- arity = length all_args
- -- all_args are the args in reverse order. We're compiling a function
- -- \fv1..fvn x1..xn -> e
- -- i.e. the fvs come first
+ = let
+ all_args = reverse args ++ fvs
+ arity = length all_args
+ -- all_args are the args in reverse order. We're compiling a function
+ -- \fv1..fvn x1..xn -> e
+ -- i.e. the fvs come first
szsw_args = map (fromIntegral . idSizeW) all_args
szw_args = sum szsw_args
p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
- -- make the arg bitmap
- bits = argBits (reverse (map idCgRep all_args))
- bitmap_size = genericLength bits
- bitmap = mkBitmap bits
+ -- make the arg bitmap
+ bits = argBits (reverse (map idCgRep all_args))
+ bitmap_size = genericLength bits
+ bitmap = mkBitmap bits
in do
- body_code <- schemeER_wrk szw_args p_init body
-
+ body_code <- schemeER_wrk szw_args p_init body
+
emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
- arity bitmap_size bitmap False{-not alts-})
+ arity bitmap_size bitmap False{-not alts-})
-- introduce break instructions for ticked expressions
schemeER_wrk :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
schemeER_wrk d p rhs
- | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do
- code <- schemeE d 0 p newRhs
- arr <- getBreakArray
+ | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do
+ code <- schemeE d 0 p newRhs
+ arr <- getBreakArray
let idOffSets = getVarOffSets d p tickInfo
let tickNumber = tickInfo_number tickInfo
- let breakInfo = BreakInfo
+ let breakInfo = BreakInfo
{ breakInfo_module = tickInfo_module tickInfo
- , breakInfo_number = tickNumber
+ , breakInfo_number = tickNumber
, breakInfo_vars = idOffSets
, breakInfo_resty = exprType (deAnnotate' newRhs)
}
BA arr# ->
BRK_FUN arr# (fromIntegral tickNumber) breakInfo
return $ breakInstr `consOL` code
- | otherwise = schemeE d 0 p rhs
+ | otherwise = schemeE d 0 p rhs
getVarOffSets :: Word16 -> BCEnv -> TickInfo -> [(Id, Word16)]
-getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals
+getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals
getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16)
-getOffSet d env id
+getOffSet d env id
= case lookupBCEnv_maybe id env of
- Nothing -> Nothing
+ Nothing -> Nothing
Just offset -> Just (id, d - offset)
fvsToEnv :: BCEnv -> VarSet -> [Id]
--
-- The code that constructs the thunk, and the code that executes
-- it, have to agree about this layout
-fvsToEnv p fvs = [v | v <- varSetElems fvs,
- isId v, -- Could be a type variable
- v `Map.member` p]
+fvsToEnv p fvs = [v | v <- varSetElems fvs,
+ isId v, -- Could be a type variable
+ v `Map.member` p]
-- -----------------------------------------------------------------------------
-- schemeE
-data TickInfo
- = TickInfo
+data TickInfo
+ = TickInfo
{ tickInfo_number :: Int -- the (module) unique number of the tick
- , tickInfo_module :: Module -- the origin of the ticked expression
+ , tickInfo_module :: Module -- the origin of the ticked expression
, tickInfo_locals :: [Id] -- the local vars in scope at the ticked expression
- }
+ }
instance Outputable TickInfo where
- ppr info = text "TickInfo" <+>
+ ppr info = text "TickInfo" <+>
parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+>
ppr (tickInfo_locals info))
= schemeE d s p e'
-- Delegate tail-calls to schemeT.
-schemeE d s p e@(AnnApp _ _)
+schemeE d s p e@(AnnApp _ _)
= schemeT d s p e
schemeE d s p e@(AnnVar v)
schemeT d s p e
| otherwise
- = do -- Returning an unlifted value.
+ = do -- Returning an unlifted value.
-- Heave it on the stack, SLIDE, and RETURN.
(push, szw) <- pushAtom d p (AnnVar v)
- return (push -- value onto stack
- `appOL` mkSLIDE szw (d-s) -- clear to sequel
- `snocOL` RETURN_UBX v_rep) -- go
+ return (push -- value onto stack
+ `appOL` mkSLIDE szw (d-s) -- clear to sequel
+ `snocOL` RETURN_UBX v_rep) -- go
where
v_type = idType v
v_rep = typeCgRep v_type
schemeE d s p (AnnLit literal)
= do (push, szw) <- pushAtom d p (AnnLit literal)
let l_rep = typeCgRep (literalType literal)
- return (push -- value onto stack
- `appOL` mkSLIDE szw (d-s) -- clear to sequel
- `snocOL` RETURN_UBX l_rep) -- go
+ return (push -- value onto stack
+ `appOL` mkSLIDE szw (d-s) -- clear to sequel
+ `snocOL` RETURN_UBX l_rep) -- go
schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
| (AnnVar v, args_r_to_l) <- splitApp rhs,
Just data_con <- isDataConWorkId_maybe v,
dataConRepArity data_con == length args_r_to_l
- = do -- Special case for a non-recursive let whose RHS is a
- -- saturatred constructor application.
- -- Just allocate the constructor and carry on
+ = do -- Special case for a non-recursive let whose RHS is a
+ -- saturatred constructor application.
+ -- Just allocate the constructor and carry on
alloc_code <- mkConAppCode d s p data_con args_r_to_l
body_code <- schemeE (d+1) s (Map.insert x d p) body
return (alloc_code `appOL` body_code)
-- Sizes of free vars
sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW) rhs_fvs)) fvss
- -- the arity of each rhs
- arities = map (genericLength . fst . collect) rhss
+ -- the arity of each rhs
+ arities = map (genericLength . fst . collect) rhss
-- This p', d' defn is safe because all the items being pushed
-- are ptrs, so all have size 1. d' and p' reflect the stack
-- ToDo: don't build thunks for things with no free variables
build_thunk _ [] size bco off arity
= return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
- where
- mkap | arity == 0 = MKAP
- | otherwise = MKPAP
+ where
+ mkap | arity == 0 = MKAP
+ | otherwise = MKPAP
build_thunk dd (fv:fvs) size bco off arity = do
- (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
+ (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity
return (push_code `appOL` more_push_code)
alloc_code = toOL (zipWith mkAlloc sizes arities)
- where mkAlloc sz 0
+ where mkAlloc sz 0
| is_tick = ALLOC_AP_NOUPD sz
| otherwise = ALLOC_AP sz
- mkAlloc sz arity = ALLOC_PAP arity sz
+ mkAlloc sz arity = ALLOC_PAP arity sz
- is_tick = case binds of
+ is_tick = case binds of
AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
_other -> False
- compile_bind d' fvs x rhs size arity off = do
- bco <- schemeR fvs (x,rhs)
- build_thunk d' fvs size bco off arity
+ compile_bind d' fvs x rhs size arity off = do
+ bco <- schemeR fvs (x,rhs)
+ build_thunk d' fvs size bco off arity
- compile_binds =
- [ compile_bind d' fvs x rhs size arity n
- | (fvs, x, rhs, size, arity, n) <-
- zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
- ]
+ compile_binds =
+ [ compile_bind d' fvs x rhs size arity n
+ | (fvs, x, rhs, size, arity, n) <-
+ zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
+ ]
in do
body_code <- schemeE d' s p' body
thunk_codes <- sequence compile_binds
= if isUnLiftedType ty
then do
-- If the result type is unlifted, then we must generate
- -- let f = \s . case tick# of _ -> e
+ -- let f = \s . case tick# of _ -> e
-- in f realWorld#
-- When we stop at the breakpoint, _result will have an unlifted
-- type and hence won't be bound in the environment, but the
id <- newId (mkFunTy realWorldStatePrimTy ty)
st <- newId realWorldStatePrimTy
let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp)))
- (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id)
+ (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id)
(emptyVarSet, AnnVar realWorldPrimId)))
schemeE d s p letExp
else do
schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
- -- Convert
- -- case .... of x { (# VoidArg'd-thing, a #) -> ... }
- -- to
- -- case .... of a { DEFAULT -> ... }
- -- becuse the return convention for both are identical.
- --
- -- Note that it does not matter losing the void-rep thing from the
- -- envt (it won't be bound now) because we never look such things up.
+ -- Convert
+ -- case .... of x { (# VoidArg'd-thing, a #) -> ... }
+ -- to
+ -- case .... of a { DEFAULT -> ... }
+ -- becuse the return convention for both are identical.
+ --
+ -- Note that it does not matter losing the void-rep thing from the
+ -- envt (it won't be bound now) because we never look such things up.
= --trace "automagic mashing of case alts (# VoidArg, a #)" $
- doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
| isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
= --trace "automagic mashing of case alts (# a, VoidArg #)" $
- doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
- -- Similarly, convert
- -- case .... of x { (# a #) -> ... }
- -- to
- -- case .... of a { DEFAULT -> ... }
+ -- Similarly, convert
+ -- case .... of x { (# a #) -> ... }
+ -- to
+ -- case .... of a { DEFAULT -> ... }
= --trace "automagic mashing of case alts (# a #)" $
- doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
+ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
schemeE d s p (AnnCase scrut bndr _ alts)
- = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
+ = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
schemeE _ _ _ expr
- = pprPanic "ByteCodeGen.schemeE: unhandled case"
+ = pprPanic "ByteCodeGen.schemeE: unhandled case"
(pprCoreExpr (deAnnotate' expr))
-{-
+{-
Ticked Expressions
------------------
-
+
A ticked expression looks like this:
case tick<n> var1 ... varN of DEFAULT -> e
otherwise we return Nothing.
- The idea is that the "case tick<n> ..." is really just an annotation on
+ The idea is that the "case tick<n> ..." is really just an annotation on
the code. When we find such a thing, we pull out the useful information,
and then compile the code as if it was just the expression "e".
isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a)
isTickedExp' (AnnCase scrut _bndr _type alts)
| Just tickInfo <- isTickedScrut scrut,
- [(DEFAULT, _bndr, rhs)] <- alts
+ [(DEFAULT, _bndr, rhs)] <- alts
= Just (tickInfo, rhs)
where
- isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo
+ isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo
isTickedScrut expr
| Var id <- f,
Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id
where
(f, args) = collectArgs $ deAnnotate expr
idsOfArgs :: [Expr Id] -> [Id]
- idsOfArgs = catMaybes . map exprId
+ idsOfArgs = catMaybes . map exprId
exprId :: Expr Id -> Maybe Id
exprId (Var id) = Just id
exprId _ = Nothing
-- (# b #) and treat it as b.
--
-- 3. Application of a constructor, by defn saturated.
--- Split the args into ptrs and non-ptrs, and push the nonptrs,
+-- Split the args into ptrs and non-ptrs, and push the nonptrs,
-- then the ptrs, and then do PACK and RETURN.
--
-- 4. Otherwise, it must be a function call. Push the args
-- right to left, SLIDE and ENTER.
schemeT :: Word16 -- Stack depth
- -> Sequel -- Sequel depth
- -> BCEnv -- stack env
- -> AnnExpr' Id VarSet
+ -> Sequel -- Sequel depth
+ -> BCEnv -- stack env
+ -> AnnExpr' Id VarSet
-> BcM BCInstrList
schemeT d s p app
-- = panic "schemeT ?!?!"
-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False
--- = error "?!?!"
+-- = error "?!?!"
-- Case 0
| Just (arg, constr_names) <- maybe_is_tagToEnum_call
= do (push, arg_words) <- pushAtom d p arg
tagToId_sequence <- implement_tagToId constr_names
- return (push `appOL` tagToId_sequence
+ return (push `appOL` tagToId_sequence
`appOL` mkSLIDE 1 (d+arg_words-s)
`snocOL` ENTER)
| Just con <- maybe_saturated_dcon,
isUnboxedTupleCon con
= case args_r_to_l of
- [arg1,arg2] | isVoidArgAtom arg1 ->
- unboxedTupleReturn d s p arg2
- [arg1,arg2] | isVoidArgAtom arg2 ->
- unboxedTupleReturn d s p arg1
- _other -> unboxedTupleException
+ [arg1,arg2] | isVoidArgAtom arg1 ->
+ unboxedTupleReturn d s p arg2
+ [arg1,arg2] | isVoidArgAtom arg2 ->
+ unboxedTupleReturn d s p arg1
+ _other -> unboxedTupleException
-- Case 3: Ordinary data constructor
| Just con <- maybe_saturated_dcon
= do alloc_con <- mkConAppCode d s p con args_r_to_l
- return (alloc_con `appOL`
- mkSLIDE 1 (d - s) `snocOL`
- ENTER)
+ return (alloc_con `appOL`
+ mkSLIDE 1 (d - s) `snocOL`
+ ENTER)
- -- Case 4: Tail call of function
+ -- Case 4: Tail call of function
| otherwise
= doTailCall d s p fn args_r_to_l
maybe_is_tagToEnum_call
= let extract_constr_Names ty
| Just (tyc, _) <- splitTyConApp_maybe (repType ty),
- isDataTyCon tyc
- = map (getName . dataConWorkId) (tyConDataCons tyc)
- -- NOTE: use the worker name, not the source name of
- -- the DataCon. See DataCon.lhs for details.
- | otherwise
+ isDataTyCon tyc
+ = map (getName . dataConWorkId) (tyConDataCons tyc)
+ -- NOTE: use the worker name, not the source name of
+ -- the DataCon. See DataCon.lhs for details.
+ | otherwise
= pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
in
case app of
(AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
-> case isPrimOpId_maybe v of
Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
- _ -> Nothing
+ _ -> Nothing
_ -> Nothing
- -- Extract the args (R->L) and fn
- -- The function will necessarily be a variable,
- -- because we are compiling a tail call
+ -- Extract the args (R->L) and fn
+ -- The function will necessarily be a variable,
+ -- because we are compiling a tail call
(AnnVar fn, args_r_to_l) = splitApp app
-- Only consider this to be a constructor application iff it is
-- saturated. Otherwise, we'll call the constructor wrapper.
n_args = length args_r_to_l
- maybe_saturated_dcon
- = case isDataConWorkId_maybe fn of
- Just con | dataConRepArity con == n_args -> Just con
- _ -> Nothing
+ maybe_saturated_dcon
+ = case isDataConWorkId_maybe fn of
+ Just con | dataConRepArity con == n_args -> Just con
+ _ -> Nothing
-- -----------------------------------------------------------------------------
--- Generate code to build a constructor application,
+-- Generate code to build a constructor application,
-- leaving it on top of the stack
mkConAppCode :: Word16 -> Sequel -> BCEnv
- -> DataCon -- The data constructor
- -> [AnnExpr' Id VarSet] -- Args, in *reverse* order
- -> BcM BCInstrList
+ -> DataCon -- The data constructor
+ -> [AnnExpr' Id VarSet] -- Args, in *reverse* order
+ -> BcM BCInstrList
-mkConAppCode _ _ _ con [] -- Nullary constructor
+mkConAppCode _ _ _ con [] -- Nullary constructor
= ASSERT( isNullaryRepDataCon con )
return (unitOL (PUSH_G (getName (dataConWorkId con))))
- -- Instead of doing a PACK, which would allocate a fresh
- -- copy of this constructor, use the single shared version.
+ -- Instead of doing a PACK, which would allocate a fresh
+ -- copy of this constructor, use the single shared version.
-mkConAppCode orig_d _ p con args_r_to_l
+mkConAppCode orig_d _ p con args_r_to_l
= ASSERT( dataConRepArity con == length args_r_to_l )
do_pushery orig_d (non_ptr_args ++ ptr_args)
where
- -- The args are already in reverse order, which is the way PACK
- -- expects them to be. We must push the non-ptrs after the ptrs.
+ -- The args are already in reverse order, which is the way PACK
+ -- expects them to be. We must push the non-ptrs after the ptrs.
(ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l
do_pushery d (arg:args)
return (push `appOL` more_push_code)
do_pushery d []
= return (unitOL (PACK con n_arg_words))
- where
- n_arg_words = d - orig_d
+ where
+ n_arg_words = d - orig_d
-- -----------------------------------------------------------------------------
-- returned, even if it is a pointed type. We always just return.
unboxedTupleReturn
- :: Word16 -> Sequel -> BCEnv
- -> AnnExpr' Id VarSet -> BcM BCInstrList
+ :: Word16 -> Sequel -> BCEnv
+ -> AnnExpr' Id VarSet -> BcM BCInstrList
unboxedTupleReturn d s p arg = do
(push, sz) <- pushAtom d p arg
- return (push `appOL`
- mkSLIDE sz (d-s) `snocOL`
- RETURN_UBX (atomRep arg))
+ return (push `appOL`
+ mkSLIDE sz (d-s) `snocOL`
+ RETURN_UBX (atomRep arg))
-- -----------------------------------------------------------------------------
-- Generate code for a tail-call
doTailCall
- :: Word16 -> Sequel -> BCEnv
- -> Id -> [AnnExpr' Id VarSet]
- -> BcM BCInstrList
+ :: Word16 -> Sequel -> BCEnv
+ -> Id -> [AnnExpr' Id VarSet]
+ -> BcM BCInstrList
doTailCall init_d s p fn args
= do_pushes init_d args (map atomRep args)
where
do_pushes d [] reps = do
- ASSERT( null reps ) return ()
+ ASSERT( null reps ) return ()
(push_fn, sz) <- pushAtom d p (AnnVar fn)
- ASSERT( sz == 1 ) return ()
- return (push_fn `appOL` (
- mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
- unitOL ENTER))
+ ASSERT( sz == 1 ) return ()
+ return (push_fn `appOL` (
+ mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
+ unitOL ENTER))
do_pushes d args reps = do
let (push_apply, n, rest_of_reps) = findPushSeq reps
- (these_args, rest_of_args) = splitAt n args
+ (these_args, rest_of_args) = splitAt n args
(next_d, push_code) <- push_seq d these_args
- instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
- -- ^^^ for the PUSH_APPLY_ instruction
+ instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps
+ -- ^^^ for the PUSH_APPLY_ instruction
return (push_code `appOL` (push_apply `consOL` instrs))
push_seq d [] = return (d, nilOL)
push_seq d (arg:args) = do
- (push_code, sz) <- pushAtom d p arg
+ (push_code, sz) <- pushAtom d p arg
(final_d, more_push_code) <- push_seq (d+sz) args
return (final_d, push_code `appOL` more_push_code)
-- Case expressions
doCase :: Word16 -> Sequel -> BCEnv
- -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
- -> Bool -- True <=> is an unboxed tuple case, don't enter the result
- -> BcM BCInstrList
-doCase d s p (_,scrut) bndr alts is_unboxed_tuple
+ -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
+ -> Bool -- True <=> is an unboxed tuple case, don't enter the result
+ -> BcM BCInstrList
+doCase d s p (_,scrut) bndr alts is_unboxed_tuple
= let
-- Top of stack is the return itbl, as usual.
-- underneath it is the pointer to the alt_code BCO.
-- on top of the itbl.
ret_frame_sizeW = 2
- -- An unlifted value gets an extra info table pushed on top
- -- when it is returned.
- unlifted_itbl_sizeW | isAlgCase = 0
- | otherwise = 1
+ -- An unlifted value gets an extra info table pushed on top
+ -- when it is returned.
+ unlifted_itbl_sizeW | isAlgCase = 0
+ | otherwise = 1
- -- depth of stack after the return value has been pushed
- d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
+ -- depth of stack after the return value has been pushed
+ d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
- -- depth of stack after the extra info table for an unboxed return
- -- has been pushed, if any. This is the stack depth at the
- -- continuation.
+ -- depth of stack after the extra info table for an unboxed return
+ -- has been pushed, if any. This is the stack depth at the
+ -- continuation.
d_alts = d_bndr + unlifted_itbl_sizeW
-- Env in which to compile the alts, not including
-- any vars bound by the alts themselves
p_alts = Map.insert bndr (d_bndr - 1) p
- bndr_ty = idType bndr
+ bndr_ty = idType bndr
isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
-- given an alt, return a discr and code for it.
- codeAlt (DEFAULT, _, (_,rhs))
- = do rhs_code <- schemeE d_alts s p_alts rhs
- return (NoDiscr, rhs_code)
+ codeAlt (DEFAULT, _, (_,rhs))
+ = do rhs_code <- schemeE d_alts s p_alts rhs
+ return (NoDiscr, rhs_code)
codeAlt alt@(_, bndrs, (_,rhs))
- -- primitive or nullary constructor alt: no need to UNPACK
- | null real_bndrs = do
- rhs_code <- schemeE d_alts s p_alts rhs
+ -- primitive or nullary constructor alt: no need to UNPACK
+ | null real_bndrs = do
+ rhs_code <- schemeE d_alts s p_alts rhs
return (my_discr alt, rhs_code)
- -- algebraic alt with some binders
+ -- algebraic alt with some binders
| otherwise =
let
- (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
- ptr_sizes = map (fromIntegral . idSizeW) ptrs
- nptrs_sizes = map (fromIntegral . idSizeW) nptrs
- bind_sizes = ptr_sizes ++ nptrs_sizes
- size = sum ptr_sizes + sum nptrs_sizes
- -- the UNPACK instruction unpacks in reverse order...
- p' = Map.insertList
- (zip (reverse (ptrs ++ nptrs))
- (mkStackOffsets d_alts (reverse bind_sizes)))
- p_alts
- in do
+ (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
+ ptr_sizes = map (fromIntegral . idSizeW) ptrs
+ nptrs_sizes = map (fromIntegral . idSizeW) nptrs
+ bind_sizes = ptr_sizes ++ nptrs_sizes
+ size = sum ptr_sizes + sum nptrs_sizes
+ -- the UNPACK instruction unpacks in reverse order...
+ p' = Map.insertList
+ (zip (reverse (ptrs ++ nptrs))
+ (mkStackOffsets d_alts (reverse bind_sizes)))
+ p_alts
+ in do
MASSERT(isAlgCase)
- rhs_code <- schemeE (d_alts+size) s p' rhs
+ rhs_code <- schemeE (d_alts+size) s p' rhs
return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
where
- real_bndrs = filter (not.isTyCoVar) bndrs
+ real_bndrs = filterOut isTyVar bndrs
my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
- my_discr (DataAlt dc, _, _)
+ my_discr (DataAlt dc, _, _)
| isUnboxedTupleCon dc
= unboxedTupleException
| otherwise
MachChar i -> DiscrI (ord i)
_ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
- maybe_ncons
+ maybe_ncons
| not isAlgCase = Nothing
- | otherwise
+ | otherwise
= case [dc | (DataAlt dc, _, _) <- alts] of
[] -> Nothing
(dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
- -- the bitmap is relative to stack depth d, i.e. before the
- -- BCO, info table and return value are pushed on.
- -- This bit of code is v. similar to buildLivenessMask in CgBindery,
- -- except that here we build the bitmap from the known bindings of
- -- things that are pointers, whereas in CgBindery the code builds the
- -- bitmap from the free slots and unboxed bindings.
- -- (ToDo: merge?)
+ -- the bitmap is relative to stack depth d, i.e. before the
+ -- BCO, info table and return value are pushed on.
+ -- This bit of code is v. similar to buildLivenessMask in CgBindery,
+ -- except that here we build the bitmap from the known bindings of
+ -- things that are pointers, whereas in CgBindery the code builds the
+ -- bitmap from the free slots and unboxed bindings.
+ -- (ToDo: merge?)
--
-- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
-- The bitmap must cover the portion of the stack up to the sequel only.
bitmap_size = d-s
bitmap_size' :: Int
bitmap_size' = fromIntegral bitmap_size
- bitmap = intsToReverseBitmap bitmap_size'{-size-}
+ bitmap = intsToReverseBitmap bitmap_size'{-size-}
(sortLe (<=) (filter (< bitmap_size') rel_slots))
- where
- binds = Map.toList p
- rel_slots = map fromIntegral $ concat (map spread binds)
- spread (id, offset)
- | isFollowableArg (idCgRep id) = [ rel_offset ]
- | otherwise = []
- where rel_offset = d - offset - 1
+ where
+ binds = Map.toList p
+ rel_slots = map fromIntegral $ concat (map spread binds)
+ spread (id, offset)
+ | isFollowableArg (idCgRep id) = [ rel_offset ]
+ | otherwise = []
+ where rel_offset = d - offset - 1
in do
alt_stuff <- mapM codeAlt alts
alt_final <- mkMultiBranch maybe_ncons alt_stuff
- let
+ let
alt_bco_name = getName bndr
alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
- 0{-no arity-} bitmap_size bitmap True{-is alts-}
+ 0{-no arity-} bitmap_size bitmap True{-is alts-}
-- in
-- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
--- "\n bitmap = " ++ show bitmap) $ do
+-- "\n bitmap = " ++ show bitmap) $ do
scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut
alt_bco' <- emitBc alt_bco
let push_alts
- | isAlgCase = PUSH_ALTS alt_bco'
- | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
+ | isAlgCase = PUSH_ALTS alt_bco'
+ | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
return (push_alts `consOL` scrut_code)
-- deferencing ForeignObj#s and adjusting addrs to point to
-- payloads in Ptr/Byte arrays. Then, generate the marshalling
-- (machine) code for the ccall, and create bytecodes to call that and
--- then return in the right way.
+-- then return in the right way.
-generateCCall :: Word16 -> Sequel -- stack and sequel depths
+generateCCall :: Word16 -> Sequel -- stack and sequel depths
-> BCEnv
- -> CCallSpec -- where to call
- -> Id -- of target, for type info
- -> [AnnExpr' Id VarSet] -- args (atoms)
+ -> CCallSpec -- where to call
+ -> Id -- of target, for type info
+ -> [AnnExpr' Id VarSet] -- args (atoms)
-> BcM BCInstrList
generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
- = let
+ = let
-- useful constants
addr_sizeW :: Word16
addr_sizeW = fromIntegral (cgRepSizeW NonPtrArg)
-- CgRep of what was actually pushed.
pargs _ [] = return []
- pargs d (a:az)
+ pargs d (a:az)
= let arg_ty = repType (exprType (deAnnotate' a))
in case splitTyConApp_maybe arg_ty of
-- Don't push the FO; instead push the Addr# it
-- contains.
- Just (t, _)
- | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
+ Just (t, _)
+ | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
-> do rest <- pargs (d + addr_sizeW) az
code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
return ((code,AddrRep):rest)
- | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
+ | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
-> do rest <- pargs (d + addr_sizeW) az
code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a
return ((code,AddrRep):rest)
(returns_void, r_rep)
= case maybe_getCCallReturnRep (idType fn) of
Nothing -> (True, VoidRep)
- Just rr -> (False, rr)
+ Just rr -> (False, rr)
{-
- Because the Haskell stack grows down, the a_reps refer to
+ Because the Haskell stack grows down, the a_reps refer to
lowest to highest addresses in that order. The args for the call
are on the stack. Now push an unboxed Addr# indicating
- the C function to call. Then push a dummy placeholder for the
- result. Finally, emit a CCALL insn with an offset pointing to the
+ the C function to call. Then push a dummy placeholder for the
+ result. Finally, emit a CCALL insn with an offset pointing to the
Addr# just pushed, and a literal field holding the mallocville
address of the piece of marshalling code we generate.
- So, just prior to the CCALL insn, the stack looks like this
+ So, just prior to the CCALL insn, the stack looks like this
(growing down, as usual):
-
+
<arg_n>
...
<arg_1>
<placeholder-for-result#> (must be an unboxed type)
The interpreter then calls the marshall code mentioned
- in the CCALL insn, passing it (& <placeholder-for-result#>),
+ in the CCALL insn, passing it (& <placeholder-for-result#>),
that is, the addr of the topmost word in the stack.
When this returns, the placeholder will have been
filled in. The placeholder is slid down to the sequel
-- Get the arg reps, zapping the leading Addr# in the dynamic case
a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
| is_static = a_reps_pushed_RAW
- | otherwise = if null a_reps_pushed_RAW
+ | otherwise = if null a_reps_pushed_RAW
then panic "ByteCodeGen.generateCCall: dyn with no args"
else tail a_reps_pushed_RAW
| is_static
= (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
d_after_args + addr_sizeW)
- | otherwise -- is already on the stack
+ | otherwise -- is already on the stack
= (nilOL, d_after_args)
-- Push the return placeholder. For a call returning nothing,
r_sizeW = fromIntegral (primRepSizeW r_rep)
d_after_r = d_after_Addr + r_sizeW
r_lit = mkDummyLiteral r_rep
- push_r = (if returns_void
- then nilOL
+ push_r = (if returns_void
+ then nilOL
else unitOL (PUSH_UBX (Left r_lit) r_sizeW))
-- generate the marshalling code we're going to call
- -- Offset of the next stack frame down the stack. The CCALL
- -- instruction needs to describe the chunk of stack containing
- -- the ccall args to the GC, so it needs to know how large it
- -- is. See comment in Interpreter.c with the CCALL instruction.
- stk_offset = d_after_r - s
+ -- Offset of the next stack frame down the stack. The CCALL
+ -- instruction needs to describe the chunk of stack containing
+ -- the ccall args to the GC, so it needs to know how large it
+ -- is. See comment in Interpreter.c with the CCALL instruction.
+ stk_offset = d_after_r - s
-- in
-- the only difference in libffi mode is that we prepare a cif
_ -> panic "mkDummyLiteral"
--- Convert (eg)
+-- Convert (eg)
-- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
-- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
--
maybe_getCCallReturnRep :: Type -> Maybe PrimRep
maybe_getCCallReturnRep fn_ty
= let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
- maybe_r_rep_to_go
+ maybe_r_rep_to_go
= if isSingleton r_reps then Nothing else Just (r_reps !! 1)
- (r_tycon, r_reps)
+ (r_tycon, r_reps)
= case splitTyConApp_maybe (repType r_ty) of
(Just (tyc, tys)) -> (tyc, map typePrimRep tys)
Nothing -> blargh
&& case maybe_r_rep_to_go of
Nothing -> True
Just r_rep -> r_rep /= PtrRep
- -- if it was, it would be impossible
- -- to create a valid return value
+ -- if it was, it would be impossible
+ -- to create a valid return value
-- placeholder on the stack
blargh :: a -- Used at more than one type
- blargh = pprPanic "maybe_getCCallReturn: can't handle:"
+ blargh = pprPanic "maybe_getCCallReturn: can't handle:"
(pprType fn_ty)
- in
+ in
--trace (showSDoc (ppr (a_reps, r_reps))) $
if ok then maybe_r_rep_to_go else blargh
-- Compile code which expects an unboxed Int on the top of stack,
--- (call it i), and pushes the i'th closure in the supplied list
+-- (call it i), and pushes the i'th closure in the supplied list
-- as a consequence.
implement_tagToId :: [Name] -> BcM BCInstrList
implement_tagToId names
[0 ..] names
steps = map (mkStep label_exit) infos
return (concatOL steps
- `appOL`
+ `appOL`
toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
where
mkStep l_exit (my_label, next_label, n, name_for_n)
- = toOL [LABEL my_label,
- TESTEQ_I n next_label,
- PUSH_G name_for_n,
+ = toOL [LABEL my_label,
+ TESTEQ_I n next_label,
+ PUSH_G name_for_n,
JMP l_exit]
pushAtom :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
-pushAtom d p e
- | Just e' <- bcView e
+pushAtom d p e
+ | Just e' <- bcView e
= pushAtom d p e'
+pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things,
+ = return (nilOL, 0) -- treated just like a variable VoidArg
+
pushAtom d p (AnnVar v)
| idCgRep v == VoidArg
= return (nilOL, 0)
| Just d_v <- lookupBCEnv_maybe v p -- v is a local variable
= let l = d - d_v + sz - 2
in return (toOL (genericReplicate sz (PUSH_L l)), sz)
- -- d - d_v the number of words between the TOS
- -- and the 1st slot of the object
- --
- -- d - d_v - 1 the offset from the TOS of the 1st slot
- --
- -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot
- -- of the object.
- --
- -- Having found the last slot, we proceed to copy the right number of
- -- slots on to the top of the stack.
+ -- d - d_v the number of words between the TOS
+ -- and the 1st slot of the object
+ --
+ -- d - d_v - 1 the offset from the TOS of the 1st slot
+ --
+ -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot
+ -- of the object.
+ --
+ -- Having found the last slot, we proceed to copy the right number of
+ -- slots on to the top of the stack.
| otherwise -- v must be a global variable
- = ASSERT(sz == 1)
+ = ASSERT(sz == 1)
return (unitOL (PUSH_G (getName v)), sz)
where
MachFloat _ -> code FloatArg
MachDouble _ -> code DoubleArg
MachChar _ -> code NonPtrArg
- MachNullAddr -> code NonPtrArg
+ MachNullAddr -> code NonPtrArg
MachStr s -> pushStr s
l -> pprPanic "pushAtom" (ppr l)
where
code rep
= let size_host_words = fromIntegral (cgRepSizeW rep)
- in return (unitOL (PUSH_UBX (Left lit) size_host_words),
+ in return (unitOL (PUSH_UBX (Left lit) size_host_words),
size_host_words)
- pushStr s
+ pushStr s
= let getMallocvilleAddr
= case s of
- FastString _ n _ fp _ ->
- -- we could grab the Ptr from the ForeignPtr,
- -- but then we have no way to control its lifetime.
- -- In reality it'll probably stay alive long enoungh
- -- by virtue of the global FastString table, but
- -- to be on the safe side we copy the string into
- -- a malloc'd area of memory.
+ FastString _ n _ fp _ ->
+ -- we could grab the Ptr from the ForeignPtr,
+ -- but then we have no way to control its lifetime.
+ -- In reality it'll probably stay alive long enoungh
+ -- by virtue of the global FastString table, but
+ -- to be on the safe side we copy the string into
+ -- a malloc'd area of memory.
do ptr <- ioToBc (mallocBytes (n+1))
recordMallocBc ptr
ioToBc (
withForeignPtr fp $ \p -> do
- memcpy ptr p (fromIntegral n)
- pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
+ memcpy ptr p (fromIntegral n)
+ pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
return ptr
)
in do
-- Get the addr on the stack, untaggedly
return (unitOL (PUSH_UBX (Right addr) 1), 1)
-pushAtom d p (AnnCast e _)
- = pushAtom d p (snd e)
-
pushAtom _ _ expr
- = pprPanic "ByteCodeGen.pushAtom"
+ = pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate (undefined, expr)))
foreign import ccall unsafe "memcpy"
-- of making a multiway branch using a switch tree.
-- What a load of hassle!
-mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
- -- a hint; generates better code
- -- Nothing is always safe
- -> [(Discr, BCInstrList)]
+mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
+ -- a hint; generates better code
+ -- Nothing is always safe
+ -> [(Discr, BCInstrList)]
-> BcM BCInstrList
mkMultiBranch maybe_ncons raw_ways
= let d_way = filter (isNoDiscr.fst) raw_ways
- notd_ways = sortLe
+ notd_ways = sortLe
(\w1 w2 -> leAlt (fst w1) (fst w2))
(filter (not.isNoDiscr.fst) raw_ways)
mkTree [] _range_lo _range_hi = return the_default
mkTree [val] range_lo range_hi
- | range_lo `eqAlt` range_hi
+ | range_lo `eqAlt` range_hi
= return (snd val)
| otherwise
= do label_neq <- getLabelBc
- return (testEQ (fst val) label_neq
- `consOL` (snd val
- `appOL` unitOL (LABEL label_neq)
- `appOL` the_default))
+ return (testEQ (fst val) label_neq
+ `consOL` (snd val
+ `appOL` unitOL (LABEL label_neq)
+ `appOL` the_default))
mkTree vals range_lo range_hi
= let n = length vals `div` 2
code_lo <- mkTree vals_lo range_lo (dec v_mid)
code_hi <- mkTree vals_hi v_mid range_hi
return (testLT v_mid label_geq
- `consOL` (code_lo
- `appOL` unitOL (LABEL label_geq)
- `appOL` code_hi))
-
- the_default
+ `consOL` (code_lo
+ `appOL` unitOL (LABEL label_geq)
+ `appOL` code_hi))
+
+ the_default
= case d_way of [] -> unitOL CASEFAIL
[(_, def)] -> def
_ -> panic "mkMultiBranch/the_default"
= panic "mkMultiBranch: awesome foursome"
| otherwise
= case fst (head notd_ways) of
- DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
- DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
- DiscrF _ -> ( DiscrF minF, DiscrF maxF )
- DiscrD _ -> ( DiscrD minD, DiscrD maxD )
- DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
- NoDiscr -> panic "mkMultiBranch NoDiscr"
+ DiscrI _ -> ( DiscrI minBound, DiscrI maxBound )
+ DiscrW _ -> ( DiscrW minBound, DiscrW maxBound )
+ DiscrF _ -> ( DiscrF minF, DiscrF maxF )
+ DiscrD _ -> ( DiscrD minD, DiscrD maxD )
+ DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
+ NoDiscr -> panic "mkMultiBranch NoDiscr"
(algMinBound, algMaxBound)
= case maybe_ncons of
dec (DiscrI i) = DiscrI (i-1)
dec (DiscrW w) = DiscrW (w-1)
dec (DiscrP i) = DiscrP (i-1)
- dec other = other -- not really right, but if you
- -- do cases on floating values, you'll get what you deserve
+ dec other = other -- not really right, but if you
+ -- do cases on floating values, you'll get what you deserve
-- same snotty comment applies to the following
minF, maxF :: Float
-- Supporting junk for the compilation schemes
-- Describes case alts
-data Discr
+data Discr
= DiscrI Int
| DiscrW Word
| DiscrF Float
-- See bug #1257
unboxedTupleException :: a
-unboxedTupleException
- = ghcError
- (ProgramError
+unboxedTupleException
+ = ghcError
+ (ProgramError
("Error: bytecode compiler can't handle unboxed tuples.\n"++
" Possibly due to foreign import/export decls in source.\n"++
" Workaround: use -fobject-code, or compile this module to .o separately."))
mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
- -- The arguments are returned in *right-to-left* order
+ -- The arguments are returned in *right-to-left* order
splitApp e | Just e' <- bcView e = splitApp e'
-splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
- (f', as) -> (f', a:as)
-splitApp e = (e, [])
+splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
+ (f', as) -> (f', a:as)
+splitApp e = (e, [])
bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
-- b) type applications
-- c) casts
-- d) notes
--- Type lambdas *can* occur in random expressions,
+-- Type lambdas *can* occur in random expressions,
-- whereas value lambdas cannot; that is why they are nuked here
bcView (AnnNote _ (_,e)) = Just e
bcView (AnnCast (_,e) _) = Just e
-bcView (AnnLam v (_,e)) | isTyCoVar v = Just e
+bcView (AnnLam v (_,e)) | isTyVar v = Just e
bcView (AnnApp (_,e) (_, AnnType _)) = Just e
bcView _ = Nothing
isVoidArgAtom :: AnnExpr' Var ann -> Bool
isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e'
isVoidArgAtom (AnnVar v) = typePrimRep (idType v) == VoidRep
+isVoidArgAtom (AnnCoercion {}) = True
isVoidArgAtom _ = False
atomPrimRep :: AnnExpr' Id ann -> PrimRep
atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
atomPrimRep (AnnVar v) = typePrimRep (idType v)
atomPrimRep (AnnLit l) = typePrimRep (literalType l)
+atomPrimRep (AnnCoercion {}) = VoidRep
atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
atomRep :: AnnExpr' Id ann -> CgRep
type BcPtr = Either ItblPtr (Ptr ())
-data BcM_State
- = BcM_State {
+data BcM_State
+ = BcM_State {
uniqSupply :: UniqSupply, -- for generating fresh variable names
- nextlabel :: Word16, -- for generating local labels
- malloced :: [BcPtr], -- thunks malloced for current BCO
- -- Should be free()d when it is GCd
- breakArray :: BreakArray -- array of breakpoint flags
+ nextlabel :: Word16, -- for generating local labels
+ malloced :: [BcPtr], -- thunks malloced for current BCO
+ -- Should be free()d when it is GCd
+ breakArray :: BreakArray -- array of breakpoint flags
}
newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
ioToBc :: IO a -> BcM a
-ioToBc io = BcM $ \st -> do
- x <- io
+ioToBc io = BcM $ \st -> do
+ x <- io
return (st, x)
runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r)
-runBc us modBreaks (BcM m)
- = m (BcM_State us 0 [] breakArray)
+runBc us modBreaks (BcM m)
+ = m (BcM_State us 0 [] breakArray)
where
breakArray = modBreaks_flags modBreaks
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
(st1, q) <- expr st0
- let BcM k = cont q
+ let BcM k = cont q
(st2, r) <- k st1
return (st2, r)
getLabelsBc :: Word16 -> BcM [Word16]
getLabelsBc n
- = BcM $ \st -> let ctr = nextlabel st
- in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
+ = BcM $ \st -> let ctr = nextlabel st
+ in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
-getBreakArray :: BcM BreakArray
+getBreakArray :: BcM BreakArray
getBreakArray = BcM $ \st -> return (st, breakArray st)
newUnique :: BcM Unique
in return (newState, uniq)
newId :: Type -> BcM Id
-newId ty = do
+newId ty = do
uniq <- newUnique
return $ mkSysLocal tickFS uniq ty
| CASEFAIL
| JMP LocalLabel
- -- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi)
+ -- For doing calls to C (via glue code generated by libffi)
| CCALL Word16 -- stack frame size
(Ptr ()) -- addr of the glue code
Word16 -- whether or not the call is interruptible
import Foreign.C
import Foreign ( nullPtr )
import GHC.Exts ( Ptr(..) )
+import GHC.IO.Encoding ( fileSystemEncoding )
+import qualified GHC.Foreign as GHC
-- RTS Linker Interface
-- ---------------------------------------------------------------------------
+-- UNICODE FIXME: Unicode object/archive/DLL file names on Windows will only work in the right code page
+withFileCString :: FilePath -> (CString -> IO a) -> IO a
+withFileCString = GHC.withCString fileSystemEncoding
+
insertSymbol :: String -> String -> Ptr a -> IO ()
insertSymbol obj_name key symbol
= let str = prefixUnderscore key
- in withCString obj_name $ \c_obj_name ->
- withCString str $ \c_str ->
+ in withFileCString obj_name $ \c_obj_name ->
+ withCAString str $ \c_str ->
c_insertSymbol c_obj_name c_str symbol
lookupSymbol :: String -> IO (Maybe (Ptr a))
lookupSymbol str_in = do
let str = prefixUnderscore str_in
- withCString str $ \c_str -> do
+ withCAString str $ \c_str -> do
addr <- c_lookupSymbol c_str
if addr == nullPtr
then return Nothing
-- Nothing => success
-- Just err_msg => failure
loadDLL str = do
- maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
+ maybe_errmsg <- withFileCString str $ \dll -> c_addDLL dll
if maybe_errmsg == nullPtr
then return Nothing
else do str <- peekCString maybe_errmsg
loadArchive :: String -> IO ()
loadArchive str = do
- withCString str $ \c_str -> do
+ withFileCString str $ \c_str -> do
r <- c_loadArchive c_str
when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed"))
loadObj :: String -> IO ()
loadObj str = do
- withCString str $ \c_str -> do
+ withFileCString str $ \c_str -> do
r <- c_loadObj c_str
when (r == 0) (panic ("loadObj " ++ show str ++ ": failed"))
unloadObj :: String -> IO ()
unloadObj str =
- withCString str $ \c_str -> do
+ withFileCString str $ \c_str -> do
r <- c_unloadObj c_str
when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed"))
import Name
import VarEnv
import Util
-import ListSetOps
import VarSet
import TysPrim
import PrelNames
import TysWiredIn
import DynFlags
-import Outputable
+import Outputable as Ppr
import FastString
--- import Panic
-
import Constants ( wORD_SIZE )
-
import GHC.Arr ( Array(..) )
import GHC.Exts
import GHC.IO ( IO(..) )
+import StaticFlags( opt_PprStyle_Debug )
import Control.Monad
import Data.Maybe
import Data.Array.Base
elems = fromIntegral (BCI.ptrs itbl)
ptrsList = Array 0 (elems - 1) elems ptrs
nptrs_data = [W# (indexWordArray# nptrs i)
- | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
+ | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ]
ASSERT(elems >= 0) return ()
ptrsList `seq`
return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
= parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
<+> hsep (map (ppr_term1 True) tt)
-} -- TODO Printing infix constructors properly
- | null tt = return$ ppr dc
- | otherwise = do
- tt_docs <- mapM (y app_prec) tt
- return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
+ | null sub_terms_to_show
+ = return (ppr dc)
+ | otherwise
+ = do { tt_docs <- mapM (y app_prec) sub_terms_to_show
+ ; return $ cparen (p >= app_prec) $
+ sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] }
+ where
+ sub_terms_to_show -- Don't show the dictionary arguments to
+ -- constructors unless -dppr-debug is on
+ | opt_PprStyle_Debug = tt
+ | otherwise = dropList (dataConTheta dc) tt
ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
ppr_termM y p RefWrap{wrapped_term=t} = do
firstJustM [] = return Nothing
-- Default set of custom printers. Note that the recursion knot is explicit
-cPprTermBase :: Monad m => CustomTermPrinter m
+cPprTermBase :: forall m. Monad m => CustomTermPrinter m
cPprTermBase y =
[ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
. mapM (y (-1))
. subTerms)
, ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
- (\ p t -> doList p t)
- , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a)
- , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a)
- , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a)
- , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
- , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a)
+ ppr_list
+ , ifTerm (isTyCon intTyCon . ty) ppr_int
+ , ifTerm (isTyCon charTyCon . ty) ppr_char
+ , ifTerm (isTyCon floatTyCon . ty) ppr_float
+ , ifTerm (isTyCon doubleTyCon . ty) ppr_double
+ , ifTerm (isIntegerTy . ty) ppr_integer
]
- where ifTerm pred f prec t@Term{}
- | pred t = Just `liftM` f prec t
- ifTerm _ _ _ _ = return Nothing
-
- isTupleTy ty = fromMaybe False $ do
- (tc,_) <- tcSplitTyConApp_maybe ty
- return (isBoxedTupleTyCon tc)
-
- isTyCon a_tc ty = fromMaybe False $ do
- (tc,_) <- tcSplitTyConApp_maybe ty
- return (a_tc == tc)
-
- isIntegerTy ty = fromMaybe False $ do
- (tc,_) <- tcSplitTyConApp_maybe ty
- return (tyConName tc == integerTyConName)
-
- coerceShow f _p = return . text . show . f . unsafeCoerce# . val
-
- --Note pprinting of list terms is not lazy
- doList p (Term{subTerms=[h,t]}) = do
- let elems = h : getListTerms t
- isConsLast = not(termType(last elems) `coreEqType` termType h)
- print_elems <- mapM (y cons_prec) elems
- return$ if isConsLast
- then cparen (p >= cons_prec)
- . pprDeeperList fsep
- . punctuate (space<>colon)
- $ print_elems
- else brackets (pprDeeperList fcat$
- punctuate comma print_elems)
-
- where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
- getListTerms Term{subTerms=[]} = []
- getListTerms t@Suspension{} = [t]
- getListTerms t = pprPanic "getListTerms" (ppr t)
- doList _ _ = panic "doList"
+ where
+ ifTerm :: (Term -> Bool)
+ -> (Precedence -> Term -> m SDoc)
+ -> Precedence -> Term -> m (Maybe SDoc)
+ ifTerm pred f prec t@Term{}
+ | pred t = Just `liftM` f prec t
+ ifTerm _ _ _ _ = return Nothing
+
+ isTupleTy ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
+ return (isBoxedTupleTyCon tc)
+
+ isTyCon a_tc ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
+ return (a_tc == tc)
+
+ isIntegerTy ty = fromMaybe False $ do
+ (tc,_) <- tcSplitTyConApp_maybe ty
+ return (tyConName tc == integerTyConName)
+
+ ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
+ :: Precedence -> Term -> m SDoc
+ ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v)))
+ ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
+ ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v)))
+ ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v)))
+ ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))
+
+ --Note pprinting of list terms is not lazy
+ ppr_list :: Precedence -> Term -> m SDoc
+ ppr_list p (Term{subTerms=[h,t]}) = do
+ let elems = h : getListTerms t
+ isConsLast = not(termType(last elems) `eqType` termType h)
+ is_string = all (isCharTy . ty) elems
+
+ print_elems <- mapM (y cons_prec) elems
+ if is_string
+ then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
+ else if isConsLast
+ then return $ cparen (p >= cons_prec)
+ $ pprDeeperList fsep
+ $ punctuate (space<>colon) print_elems
+ else return $ brackets
+ $ pprDeeperList fcat
+ $ punctuate comma print_elems
+
+ where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
+ getListTerms Term{subTerms=[]} = []
+ getListTerms t@Suspension{} = [t]
+ getListTerms t = pprPanic "getListTerms" (ppr t)
+ ppr_list _ _ = panic "doList"
repPrim :: TyCon -> [Word] -> String
newVar :: Kind -> TR TcType
newVar = liftTcM . newFlexiTyVarTy
+instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst)
+-- Instantiate fresh mutable type variables from some TyVars
+-- This function preserves the print-name, which helps error messages
+instTyVars = liftTcM . tcInstTyVars
+
type RttiInstantiation = [(TcTyVar, TyVar)]
-- Associates the typechecker-world meta type variables
-- (which are mutable and may be refined), to their
text "Type obtained: " <> ppr (termType term))
return term
where
+
go :: Int -> Type -> Type -> HValue -> TcM Term
+ -- [SPJ May 11] I don't understand the difference between my_ty and old_ty
+
go max_depth _ _ _ | seq max_depth False = undefined
go 0 my_ty _old_ty a = do
traceTR (text "Gave up reconstructing a term after" <>
traceTR (text "entering a constructor " <>
if monomorphic
then parens (text "already monomorphic: " <> ppr my_ty)
- else Outputable.empty)
+ else Ppr.empty)
Right dcname <- dataConInfoPtrToName (infoPtr clos)
(_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
case mb_dc of
-- In such case, we return a best approximation:
-- ignore the unpointed args, and recover the pointeds
-- This preserves laziness, and should be safe.
+ traceTR (text "Nothing" <+> ppr dcname)
let tag = showSDoc (ppr dcname)
vars <- replicateM (length$ elems$ ptrs clos)
- (newVar (liftedTypeKind))
+ (newVar liftedTypeKind)
subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i
| (i, tv) <- zip [0..] vars]
return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do
- let subTtypes = matchSubTypes dc old_ty
- subTermTvs <- mapMif (not . isMonomorphic)
- (\t -> newVar (typeKind t))
- subTtypes
- let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty
- || isRefType ty)
- (zip subTtypes subTermTvs)
- (subTtypesP, subTermTvsP ) = unzip subTermsP
- (subTtypesNP, _subTermTvsNP) = unzip subTermsNP
-
- -- When we already have all the information, avoid solving
- -- unnecessary constraints. Propagation of type information
- -- to subterms is already being done via matching.
- when (not monomorphic) $ do
- let myType = mkFunTys subTermTvs my_ty
- (signatureType,_) <- instScheme (mydataConType dc)
- -- It is vital for newtype reconstruction that the unification step
- -- is done right here, _before_ the subterms are RTTI reconstructed
- addConstraint myType signatureType
+ traceTR (text "Just" <+> ppr dc)
+ subTtypes <- getDataConArgTys dc my_ty
+ let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes
subTermsP <- sequence
- [ appArr (go (pred max_depth) tv t) (ptrs clos) i
- | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP]
+ [ appArr (go (pred max_depth) ty ty) (ptrs clos) i
+ | (i,ty) <- zip [0..] subTtypesP]
let unboxeds = extractUnboxed subTtypesNP clos
- subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
+ subTermsNP = zipWith Prim subTtypesNP unboxeds
subTerms = reOrderTerms subTermsP subTermsNP subTtypes
return (Term my_ty (Right dc) a subTerms)
+
-- The otherwise case: can be a Thunk,AP,PAP,etc.
tipe_clos ->
return (Suspension tipe_clos my_ty a Nothing)
- matchSubTypes dc ty
- | ty' <- repType ty -- look through newtypes
- , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
- , dc `elem` tyConDataCons tc
- -- It is necessary to check that dc is actually a constructor for tycon tc,
- -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
- -- has not removed it. In that case, we happily give up and don't match
- = myDataConInstArgTys dc ty_args
- | otherwise = dataConRepArgTys dc
-
-- put together pointed and nonpointed subterms in the
-- correct order.
reOrderTerms _ _ [] = []
reOrderTerms pointed unpointed (ty:tys)
- | isLifted ty || isRefType ty
- = ASSERT2(not(null pointed)
+ | isPtrType ty = ASSERT2(not(null pointed)
, ptext (sLit "reOrderTerms") $$
(ppr pointed $$ ppr unpointed))
let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
-- returns unification tasks,since we are going to want a breadth-first search
go :: Type -> HValue -> TR [(Type, HValue)]
go my_ty a = do
+ traceTR (text "go" <+> ppr my_ty)
clos <- trIO $ getClosureData a
case tipe clos of
Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
return [(tv', contents)]
Constr -> do
Right dcname <- dataConInfoPtrToName (infoPtr clos)
+ traceTR (text "Constr1" <+> ppr dcname)
(_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
case mb_dc of
Nothing-> do
return$ appArr (\e->(tv,e)) (ptrs clos) i
Just dc -> do
- subTtypes <- mapMif (not . isMonomorphic)
- (\t -> newVar (typeKind t))
- (dataConRepArgTys dc)
-
- -- It is vital for newtype reconstruction that the unification step
- -- is done right here, _before_ the subterms are RTTI reconstructed
- let myType = mkFunTys subTtypes my_ty
- (signatureType,_) <- instScheme (mydataConType dc)
- addConstraint myType signatureType
- return $ [ appArr (\e->(t,e)) (ptrs clos) i
- | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
+ arg_tys <- getDataConArgTys dc my_ty
+ traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
+ return $ [ appArr (\e-> (ty,e)) (ptrs clos) i
+ | (i,ty) <- zip [0..] (filter isPtrType arg_tys)]
_ -> return []
-- Compute the difference between a base type and the type found by RTTI
improveRTTIType _ base_ty new_ty
= U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty]
-myDataConInstArgTys :: DataCon -> [Type] -> [Type]
-myDataConInstArgTys dc args
- | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
- | otherwise = dataConRepArgTys dc
-
-mydataConType :: DataCon -> QuantifiedType
--- ^ Custom version of DataCon.dataConUserType where we
--- - remove the equality constraints
--- - use the representation types for arguments, including dictionaries
--- - keep the original result type
-mydataConType dc
- = ( (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
- , mkFunTys arg_tys res_ty )
- where univ_tvs = dataConUnivTyVars dc
- ex_tvs = dataConExTyVars dc
- eq_spec = dataConEqSpec dc
- arg_tys = [case a of
- PredTy p -> predTypeRep p
- _ -> a
- | a <- dataConRepArgTys dc]
- res_ty = dataConOrigResTy dc
-
-isRefType :: Type -> Bool
-isRefType ty
- | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
- | otherwise = False
- where ty'= repType ty
-
-isRefTyCon :: TyCon -> Bool
-isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
+getDataConArgTys :: DataCon -> Type -> TR [Type]
+-- Given the result type ty of a constructor application (D a b c :: ty)
+-- return the types of the arguments. This is RTTI-land, so 'ty' might
+-- not be fully known. Moreover, the arg types might involve existentials;
+-- if so, make up fresh RTTI type variables for them
+getDataConArgTys dc con_app_ty
+ = do { (_, ex_tys, _) <- instTyVars ex_tvs
+ ; let rep_con_app_ty = repType con_app_ty
+ ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of
+ Just (tc, ty_args) | dataConTyCon dc == tc
+ -> ASSERT( univ_tvs `equalLength` ty_args)
+ return ty_args
+ _ -> do { (_, ty_args, subst) <- instTyVars univ_tvs
+ ; let res_ty = substTy subst (dataConOrigResTy dc)
+ ; addConstraint rep_con_app_ty res_ty
+ ; return ty_args }
+ -- It is necessary to check dataConTyCon dc == tc
+ -- because it may be the case that tc is a recursive
+ -- newtype and tcSplitTyConApp has not removed it. In
+ -- that case, we happily give up and don't match
+ ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys)
+ ; return (substTys subst (dataConRepArgTys dc)) }
+ where
+ univ_tvs = dataConUnivTyVars dc
+ ex_tvs = dataConExTyVars dc
+
+isPtrType :: Type -> Bool
+isPtrType ty = case typePrimRep ty of
+ PtrRep -> True
+ _ -> False
-- Soundness checks
--------------------
| otherwise = do
traceTR (text "(Upgrade) upgraded " <> ppr ty <>
text " in presence of newtype evidence " <> ppr new_tycon)
- vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
+ (_, vars, _) <- instTyVars (tyConTyVars new_tycon)
let ty' = mkTyConApp new_tycon vars
_ <- liftTcM (unifyType ty (repType ty'))
-- assumes that reptype doesn't ^^^^ touch tyconApp args
-- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
quantifyType ty = (varSetElems (tyVarsOfType ty), ty)
-mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
-mapMif pred f xx = sequence $ mapMif_ pred f xx
- where
- mapMif_ _ _ [] = []
- mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
-
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM condM acc = condM >>= \c -> unless c acc
where g (I# i#) = case indexArray# arr# i# of
(# e #) -> f e
-
-isLifted :: Type -> Bool
-isLifted = not . isUnLiftedType
-
extractUnboxed :: [Type] -> Closure -> [[Word]]
extractUnboxed tt clos = go tt (nonPtrs clos)
- where sizeofType t
- | Just (tycon,_) <- tcSplitTyConApp_maybe t
- = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
- | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
+ where sizeofType t = primRepSizeW (typePrimRep t)
go [] _ = []
go (t:tt) xx
| (x, rest) <- splitAt (sizeofType t) xx
= x : go tt rest
-
-sizeofTyCon :: TyCon -> Int -- in *words*
-sizeofTyCon = primRepSizeW . tyConPrimRep
-
-
-(|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
-(f |.| g) x = f x || g x
| null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
| otherwise
= do { stmts' <- cvtStmts stmts
- ; body <- case last stmts' of
- L _ (ExprStmt body _ _) -> return body
- stmt' -> failWith (bad_last stmt')
- ; return $ HsDo do_or_lc (init stmts') body void }
+ ; let Just (stmts'', last') = snocView stmts'
+
+ ; last'' <- case last' of
+ L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body))
+ _ -> failWith (bad_last last')
+
+ ; return $ HsDo do_or_lc (stmts'' ++ [last'']) void }
where
- bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon
+ bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
, nest 2 $ Outputable.ppr stmt
, ptext (sLit "(It should be an expression.)") ]
cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
; returnL $ LetStmt ds' }
-cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
+cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr noSyntaxExpr }
where
cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
cvtOverLit (IntegerL i)
= do { force i; return $ mkHsIntegral i placeHolderType}
cvtOverLit (RationalL r)
- = do { force r; return $ mkHsFractional r placeHolderType}
+ = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
cvtOverLit (StringL s)
= do { let { s' = mkFastString s }
; force s'
cvtLit :: Lit -> CvtM HsLit
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
-cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f }
-cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
+cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
+cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
cvtLit (CharL c) = do { force c; return $ HsChar c }
cvtLit (StringL s) = do { let { s' = mkFastString s }
; force s'
void :: Type.Type
void = placeHolderType
+cvtFractionalLit :: Rational -> FractionalLit
+cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
+
--------------------------------------------------------------------
-- Turning Name back into RdrName
--------------------------------------------------------------------
type HsValBinds id = HsValBindsLR id id
data HsValBindsLR idL idR -- Value bindings (not implicit parameters)
- = ValBindsIn -- Before renaming
+ = ValBindsIn -- Before renaming RHS; idR is always RdrName
(LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed
-- Recursive by default
- | ValBindsOut -- After renaming
+ | ValBindsOut -- After renaming RHS; idR can be Name or Id
[(RecFlag, LHsBinds idL)] -- Dependency analysed, later bindings
-- in the list may depend on earlier
-- ones.
[LSig Name]
deriving (Data, Typeable)
-type LHsBinds id = Bag (LHsBind id)
-type LHsBind id = Located (HsBind id)
-type HsBind id = HsBindLR id id
+type LHsBind id = LHsBindLR id id
+type LHsBinds id = LHsBindsLR id id
+type HsBind id = HsBindLR id id
-type LHsBindLR idL idR = Located (HsBindLR idL idR)
type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
+type LHsBindLR idL idR = Located (HsBindLR idL idR)
data HsBindLR idL idR
= -- | FunBind is used for both functions @f x = e@
instance (OutputableBndr id) => Outputable (HsIPBinds id) where
ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
- $$ ifPprDebug (ppr ds)
+ $$ ifPprDebug (ppr ds)
instance (OutputableBndr id) => Outputable (IPBind id) where
ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
deriving( Data, Typeable)
evVarTerm :: EvVar -> EvTerm
-evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v)
+evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v)
| otherwise = EvId v
\end{code}
help it WpHole = it
help it (WpCompose f1 f2) = help (help it f2) f1
help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>")
- <+> pprParendType co)]
+ <+> pprParendCo co)]
help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)]
help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
instance Outputable EvTerm where
ppr (EvId v) = ppr v
- ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co
- ppr (EvCoercion co) = ppr co
+ ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co
+ ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co
ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
\end{code}
-- f :: Num a => a -> a
TypeSig (Located name) (LHsType name)
+ -- A type signature for a default method inside a class
+ -- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
+ | GenericSig (Located name) (LHsType name)
+
-- A type signature in generated code, notably the code
-- generated for record selectors. We simply record
-- the desired Id itself, replete with its name, type
okBindSig _ = True
okHsBootSig :: Sig a -> Bool
-okHsBootSig (TypeSig _ _) = True
-okHsBootSig (FixSig _) = True
-okHsBootSig _ = False
+okHsBootSig (TypeSig _ _) = True
+okHsBootSig (GenericSig _ _) = False
+okHsBootSig (FixSig _) = True
+okHsBootSig _ = False
okClsDclSig :: Sig a -> Bool
okClsDclSig (SpecInstSig _) = False
okClsDclSig _ = True -- All others OK
okInstDclSig :: Sig a -> Bool
-okInstDclSig (TypeSig _ _) = False
-okInstDclSig (FixSig _) = False
-okInstDclSig _ = True
+okInstDclSig (TypeSig _ _) = False
+okInstDclSig (GenericSig _ _) = False
+okInstDclSig (FixSig _) = False
+okInstDclSig _ = True
sigName :: LSig name -> Maybe name
-- Used only in Haddock
isVanillaLSig _ = False
isTypeLSig :: LSig name -> Bool -- Type signatures
-isTypeLSig (L _(TypeSig {})) = True
-isTypeLSig (L _(IdSig {})) = True
-isTypeLSig _ = False
+isTypeLSig (L _(TypeSig {})) = True
+isTypeLSig (L _(GenericSig {})) = True
+isTypeLSig (L _(IdSig {})) = True
+isTypeLSig _ = False
isSpecLSig :: LSig name -> Bool
isSpecLSig (L _(SpecSig {})) = True
hsSigDoc :: Sig name -> SDoc
hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
+hsSigDoc (GenericSig {}) = ptext (sLit "default type signature")
hsSigDoc (IdSig {}) = ptext (sLit "id signature")
hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma")
hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma")
eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2
eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
+eqHsSig (L _ (GenericSig n1 _)) (L _ (GenericSig n2 _)) = unLoc n1 == unLoc n2
eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2
-- For specialisations, we don't have equality over
-- HsType, so it's not convenient to spot duplicate
ppr_sig :: OutputableBndr name => Sig name -> SDoc
ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty)
+ppr_sig (GenericSig var ty) = ptext (sLit "default") <+> pprVarSig (unLoc var) (ppr ty)
ppr_sig (IdSig id) = pprVarSig id (ppr (varType id))
ppr_sig (FixSig fix_sig) = ppr fix_sig
ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl)
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-
-
\begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
{-# LANGUAGE DeriveDataTypeable #-}
-- | Abstract syntax of global declarations.
(ppr new_or_data <+>
(if isJust typats then ptext (sLit "instance") else empty) <+>
pp_decl_head (unLoc context) ltycon tyvars typats <+>
- ppr_sig mb_sig)
+ ppr_sigx mb_sig)
(pp_condecls condecls)
derivings
where
- ppr_sig Nothing = empty
- ppr_sig (Just kind) = dcolon <+> pprKind kind
+ ppr_sigx Nothing = empty
+ ppr_sigx (Just kind) = dcolon <+> pprKind kind
ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,
- tcdFDs = fds,
+ tcdFDs = fds,
tcdSigs = sigs, tcdMeths = methods, tcdATs = ats})
| null sigs && null ats -- No "where" part
= top_matter
ppr = pprConDecl
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
-pprConDecl (ConDecl { con_name =con, con_explicit = expl, con_qvars = tvs
+pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = details
, con_res = ResTyH98, con_doc = doc })
- = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
+ = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
where
- ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
- ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
- ppr_details con (RecCon fields) = ppr con <+> pprConDeclFields fields
+ ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
+ ppr_details (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
+ ppr_details (RecCon fields) = ppr con <+> pprConDeclFields fields
pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
, con_cxt = cxt, con_details = PrefixCon arg_tys
%************************************************************************
%* *
-\subsection[InstDecl]{An instance declaration
+\subsection[InstDecl]{An instance declaration}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsection[DerivDecl]{A stand-alone instance deriving declaration
+\subsection[DerivDecl]{A stand-alone instance deriving declaration}
%* *
%************************************************************************
\begin{code}
type LDerivDecl name = Located (DerivDecl name)
-data DerivDecl name = DerivDecl (LHsType name)
+data DerivDecl name = DerivDecl { deriv_type :: LHsType name }
deriving (Data, Typeable)
instance (OutputableBndr name) => Outputable (DerivDecl name) where
import BasicTypes
import DataCon
import SrcLoc
+import Util( dropTail )
+import StaticFlags( opt_PprStyle_Debug )
import Outputable
import FastString
-- because in this context we never use
-- the PatGuard or ParStmt variant
[LStmt id] -- "do":one or more stmts
- (LHsExpr id) -- The body; the last expression in the
- -- 'do' of [ body | ... ] in a list comp
PostTcType -- Type of the whole expression
| ExplicitList -- syntactic list
= sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
hang (ptext (sLit "in")) 2 (ppr expr)]
-ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body
+ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList _ exprs)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
HsPar {} -> pp_as_was
HsBracket {} -> pp_as_was
HsBracketOut _ [] -> pp_as_was
- HsDo sc _ _ _
+ HsDo sc _ _
| isListCompExpr sc -> pp_as_was
_ -> parens pp_as_was
type Stmt id = StmtLR id id
--- The SyntaxExprs in here are used *only* for do-notation, which
--- has rebindable syntax. Otherwise they are unused.
+-- The SyntaxExprs in here are used *only* for do-notation and monad
+-- comprehensions, which have rebindable syntax. Otherwise they are unused.
data StmtLR idL idR
- = BindStmt (LPat idL)
+ = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp,
+ -- and (after the renamer) DoExpr, MDoExpr
+ -- Not used for GhciStmt, PatGuard, which scope over other stuff
+ (LHsExpr idR)
+ (SyntaxExpr idR) -- The return operator, used only for MonadComp
+ -- For ListComp, PArrComp, we use the baked-in 'return'
+ -- For DoExpr, MDoExpr, we don't appply a 'return' at all
+ -- See Note [Monad Comprehensions]
+ | BindStmt (LPat idL)
(LHsExpr idR)
- (SyntaxExpr idR) -- The (>>=) operator
+ (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind]
(SyntaxExpr idR) -- The fail operator
-- The fail operator is noSyntaxExpr
-- if the pattern match can't fail
| ExprStmt (LHsExpr idR) -- See Note [ExprStmt]
(SyntaxExpr idR) -- The (>>) operator
+ (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp
+ -- See notes [Monad Comprehensions]
PostTcType -- Element type of the RHS (used for arrows)
| LetStmt (HsLocalBindsLR idL idR)
- -- ParStmts only occur in a list comprehension
+ -- ParStmts only occur in a list/monad comprehension
| ParStmt [([LStmt idL], [idR])]
- -- After renaming, the ids are the binders bound by the stmts and used
- -- after them
-
- -- "qs, then f by e" ==> TransformStmt qs binders f (Just e)
- -- "qs, then f" ==> TransformStmt qs binders f Nothing
- | TransformStmt
- [LStmt idL] -- Stmts are the ones to the left of the 'then'
-
- [idR] -- After renaming, the IDs are the binders occurring
- -- within this transform statement that are used after it
-
- (LHsExpr idR) -- "then f"
-
- (Maybe (LHsExpr idR)) -- "by e" (optional)
-
- | GroupStmt
- [LStmt idL] -- Stmts to the *left* of the 'group'
- -- which generates the tuples to be grouped
-
- [(idR, idR)] -- See Note [GroupStmt binder map]
+ (SyntaxExpr idR) -- Polymorphic `mzip` for monad comprehensions
+ (SyntaxExpr idR) -- The `>>=` operator
+ (SyntaxExpr idR) -- Polymorphic `return` operator
+ -- with type (forall a. a -> m a)
+ -- See notes [Monad Comprehensions]
+ -- After renaming, the ids are the binders
+ -- bound by the stmts and used after themp
+
+ | TransStmt {
+ trS_form :: TransForm,
+ trS_stmts :: [LStmt idL], -- Stmts to the *left* of the 'group'
+ -- which generates the tuples to be grouped
+
+ trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map]
- (Maybe (LHsExpr idR)) -- "by e" (optional)
+ trS_using :: LHsExpr idR,
+ trS_by :: Maybe (LHsExpr idR), -- "by e" (optional)
+ -- Invariant: if trS_form = GroupBy, then grp_by = Just e
- (Either -- "using f"
- (LHsExpr idR) -- Left f => explicit "using f"
- (SyntaxExpr idR)) -- Right f => implicit; filled in with 'groupWith'
-
+ trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for
+ -- the inner monad comprehensions
+ trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator
+ trS_fmap :: SyntaxExpr idR -- The polymorphic 'fmap' function for desugaring
+ -- Only for 'group' forms
+ } -- See Note [Monad Comprehensions]
-- Recursive statement (see Note [How RecStmt works] below)
| RecStmt
-- because the Id may be *polymorphic*, but
-- the returned thing has to be *monomorphic*,
-- so they may be type applications
+
+ , recS_ret_ty :: PostTcType -- The type of of do { stmts; return (a,b,c) }
+ -- With rebindable syntax the type might not
+ -- be quite as simple as (m (tya, tyb, tyc)).
}
deriving (Data, Typeable)
+
+data TransForm -- The 'f' below is the 'using' function, 'e' is the by function
+ = ThenForm -- then f or then f by e
+ | GroupFormU -- group using f or group using f by e
+ | GroupFormB -- group by e
+ -- In the GroupByFormB, trS_using is filled in with
+ -- 'groupWith' (list comprehensions) or
+ -- 'groupM' (monad comprehensions)
+ deriving (Data, Typeable)
\end{code}
-Note [GroupStmt binder map]
+Note [The type of bind in Stmts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some Stmts, notably BindStmt, keep the (>>=) bind operator.
+We do NOT assume that it has type
+ (>>=) :: m a -> (a -> m b) -> m b
+In some cases (see Trac #303, #1537) it might have a more
+exotic type, such as
+ (>>=) :: m i j a -> (a -> m j k b) -> m i k b
+So we must be careful not to make assumptions about the type.
+In particular, the monad may not be uniform throughout.
+
+Note [TransStmt binder map]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The [(idR,idR)] in a GroupStmt behaves as follows:
+The [(idR,idR)] in a TransStmt behaves as follows:
* Before renaming: []
* After renaming:
[ (x27,x27), ..., (z35,z35) ]
These are the variables
- bound by the stmts to the left of the 'group'
+ bound by the stmts to the left of the 'group'
and used either in the 'by' clause,
or in the stmts following the 'group'
Each item is a pair of identical variables.
E :: Bool
Translation: if E then fail else ...
-Array comprehensions are handled like list comprehensions -=chak
+ A monad comprehension of type (m res_ty)
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ * ExprStmt E Bool: [ .. | .... E ]
+ E :: Bool
+ Translation: guard E >> ...
+
+Array comprehensions are handled like list comprehensions.
Note [How RecStmt works]
~~~~~~~~~~~~~~~~~~~~~~~~
where v1..vn are the later_ids
r1..rm are the rec_ids
+Note [Monad Comprehensions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Monad comprehensions require separate functions like 'return' and
+'>>=' for desugaring. These functions are stored in the statements
+used in monad comprehensions. For example, the 'return' of the 'LastStmt'
+expression is used to lift the body of the monad comprehension:
+
+ [ body | stmts ]
+ =>
+ stmts >>= \bndrs -> return body
+
+In transform and grouping statements ('then ..' and 'then group ..') the
+'return' function is required for nested monad comprehensions, for example:
+
+ [ body | stmts, then f, rest ]
+ =>
+ f [ env | stmts ] >>= \bndrs -> [ body | rest ]
+
+ExprStmts require the 'Control.Monad.guard' function for boolean
+expressions:
+
+ [ body | exp, stmts ]
+ =>
+ guard exp >> [ body | stmts ]
+
+Grouping/parallel statements require the 'Control.Monad.Group.groupM' and
+'Control.Monad.Zip.mzip' functions:
+
+ [ body | stmts, then group by e, rest]
+ =>
+ groupM [ body | stmts ] >>= \bndrs -> [ body | rest ]
+
+ [ body | stmts1 | stmts2 | .. ]
+ =>
+ mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body
+
+In any other context than 'MonadComp', the fields for most of these
+'SyntaxExpr's stay bottom.
+
\begin{code}
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where
ppr stmt = pprStmt stmt
pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc
+pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr
pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext (sLit "<-"), ppr expr]
pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds]
-pprStmt (ExprStmt expr _ _) = ppr expr
-pprStmt (ParStmt stmtss) = hsep (map doStmts stmtss)
+pprStmt (ExprStmt expr _ _ _) = ppr expr
+pprStmt (ParStmt stmtss _ _ _) = hsep (map doStmts stmtss)
where doStmts stmts = ptext (sLit "| ") <> ppr stmts
-pprStmt (TransformStmt stmts bndrs using by)
- = sep (ppr_lc_stmts stmts ++ [pprTransformStmt bndrs using by])
-
-pprStmt (GroupStmt stmts _ by using)
- = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using])
+pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form })
+ = sep (ppr_lc_stmts stmts ++ [pprTransStmt by using form])
pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
, recS_later_ids = later_ids })
, nest 2 (ppr using)
, nest 2 (pprBy by)]
-pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id)
- -> Either (LHsExpr id) (SyntaxExpr is)
+pprTransStmt :: OutputableBndr id => Maybe (LHsExpr id)
+ -> LHsExpr id -> TransForm
-> SDoc
-pprGroupStmt by using
- = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ppr_using using)]
- where
- ppr_using (Right _) = empty
- ppr_using (Left e) = ptext (sLit "using") <+> ppr e
+pprTransStmt by using ThenForm
+ = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)]
+pprTransStmt by _ GroupFormB
+ = sep [ ptext (sLit "then group"), nest 2 (pprBy by) ]
+pprTransStmt by using GroupFormU
+ = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)]
pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc
pprBy Nothing = empty
pprBy (Just e) = ptext (sLit "by") <+> ppr e
-pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
-pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body
-pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body
-pprDo MDoExpr stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body
-pprDo ListComp stmts body = brackets $ pprComp stmts body
-pprDo PArrComp stmts body = pa_brackets $ pprComp stmts body
-pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
-
-ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
+pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> SDoc
+pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
+pprDo GhciStmt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
+pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts
+pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts
+pprDo ListComp stmts = brackets $ pprComp stmts
+pprDo PArrComp stmts = pa_brackets $ pprComp stmts
+pprDo MonadComp stmts = brackets $ pprComp stmts
+pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
+
+ppr_do_stmts :: OutputableBndr id => [LStmt id] -> SDoc
-- Print a bunch of do stmts, with explicit braces and semicolons,
-- so that we are not vulnerable to layout bugs
-ppr_do_stmts stmts body
- = lbrace <+> pprDeeperList vcat ([ppr s <> semi | s <- stmts] ++ [ppr body])
+ppr_do_stmts stmts
+ = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts))
<+> rbrace
ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc]
ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts]
-pprComp :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
-pprComp quals body -- Prints: body | qual1, ..., qualn
- = hang (ppr body <+> char '|') 2 (interpp'SP quals)
+pprComp :: OutputableBndr id => [LStmt id] -> SDoc
+pprComp quals -- Prints: body | qual1, ..., qualn
+ | not (null quals)
+ , L _ (LastStmt body _) <- last quals
+ = hang (ppr body <+> char '|') 2 (interpp'SP (dropTail 1 quals))
+ | otherwise
+ = pprPanic "pprComp" (interpp'SP quals)
\end{code}
%************************************************************************
data HsStmtContext id
= ListComp
- | DoExpr
- | GhciStmt -- A command-line Stmt in GHCi pat <- rhs
- | MDoExpr -- Recursive do-expression
+ | MonadComp
| PArrComp -- Parallel array comprehension
+
+ | DoExpr -- do { ... }
+ | MDoExpr -- mdo { ... } ie recursive do-expression
+ | ArrowExpr -- do-notation in an arrow-command context
+
+ | GhciStmt -- A command-line Stmt in GHCi pat <- rhs
| PatGuard (HsMatchContext id) -- Pattern guard for specified thing
| ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt
- | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt
+ | TransStmtCtxt (HsStmtContext id) -- A branch of a transform stmt
deriving (Data, Typeable)
\end{code}
\begin{code}
-isDoExpr :: HsStmtContext id -> Bool
-isDoExpr DoExpr = True
-isDoExpr MDoExpr = True
-isDoExpr _ = False
-
isListCompExpr :: HsStmtContext id -> Bool
-isListCompExpr ListComp = True
-isListCompExpr PArrComp = True
-isListCompExpr _ = False
+-- Uses syntax [ e | quals ]
+isListCompExpr ListComp = True
+isListCompExpr PArrComp = True
+isListCompExpr MonadComp = True
+isListCompExpr (ParStmtCtxt c) = isListCompExpr c
+isListCompExpr (TransStmtCtxt c) = isListCompExpr c
+isListCompExpr _ = False
+
+isMonadCompExpr :: HsStmtContext id -> Bool
+isMonadCompExpr MonadComp = True
+isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt
+isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt
+isMonadCompExpr _ = False
\end{code}
\begin{code}
pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in")
$$ pprStmtContext ctxt
-pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
+-----------------
+pprAStmtContext, pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
+pprAStmtContext ctxt = article <+> pprStmtContext ctxt
+ where
+ pp_an = ptext (sLit "an")
+ pp_a = ptext (sLit "a")
+ article = case ctxt of
+ MDoExpr -> pp_an
+ PArrComp -> pp_an
+ GhciStmt -> pp_an
+ _ -> pp_a
+
+
+-----------------
+pprStmtContext GhciStmt = ptext (sLit "interactive GHCi command")
+pprStmtContext DoExpr = ptext (sLit "'do' block")
+pprStmtContext MDoExpr = ptext (sLit "'mdo' block")
+pprStmtContext ArrowExpr = ptext (sLit "'do' block in an arrow command")
+pprStmtContext ListComp = ptext (sLit "list comprehension")
+pprStmtContext MonadComp = ptext (sLit "monad comprehension")
+pprStmtContext PArrComp = ptext (sLit "array comprehension")
+pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchContext ctxt
+
+-- Drop the inner contexts when reporting errors, else we get
+-- Unexpected transform statement
+-- in a transformed branch of
+-- transformed branch of
+-- transformed branch of monad comprehension
pprStmtContext (ParStmtCtxt c)
- = sep [ptext (sLit "a parallel branch of"), pprStmtContext c]
-pprStmtContext (TransformStmtCtxt c)
- = sep [ptext (sLit "a transformed branch of"), pprStmtContext c]
-pprStmtContext (PatGuard ctxt)
- = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt
-pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command")
-pprStmtContext DoExpr = ptext (sLit "a 'do' expression")
-pprStmtContext MDoExpr = ptext (sLit "an 'mdo' expression")
-pprStmtContext ListComp = ptext (sLit "a list comprehension")
-pprStmtContext PArrComp = ptext (sLit "an array comprehension")
-
-{-
-pprMatchRhsContext (FunRhs fun) = ptext (sLit "a right-hand side of function") <+> quotes (ppr fun)
-pprMatchRhsContext CaseAlt = ptext (sLit "the body of a case alternative")
-pprMatchRhsContext PatBindRhs = ptext (sLit "the right-hand side of a pattern binding")
-pprMatchRhsContext LambdaExpr = ptext (sLit "the body of a lambda")
-pprMatchRhsContext ProcExpr = ptext (sLit "the body of a proc")
-pprMatchRhsContext other = panic "pprMatchRhsContext" -- RecUpd, StmtCtxt
-
--- Used for the result statement of comprehension
--- e.g. the 'e' in [ e | ... ]
--- or the 'r' in f x = r
-pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt
-pprStmtResultContext other = ptext (sLit "the result of") <+> pprStmtContext other
--}
+ | opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c]
+ | otherwise = pprStmtContext c
+pprStmtContext (TransStmtCtxt c)
+ | opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c]
+ | otherwise = pprStmtContext c
+
-- Used to generate the string for a *runtime* error message
matchContextErrString :: Outputable id => HsMatchContext id -> SDoc
matchContextErrString LambdaExpr = ptext (sLit "lambda")
matchContextErrString ProcExpr = ptext (sLit "proc")
matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime
-matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
-matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c)
-matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard")
-matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command")
-matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression")
-matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' expression")
-matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension")
-matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension")
+matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
+matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)
+matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard")
+matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command")
+matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' block")
+matchContextErrString (StmtCtxt ArrowExpr) = ptext (sLit "'do' block")
+matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' block")
+matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension")
+matchContextErrString (StmtCtxt MonadComp) = ptext (sLit "monad comprehension")
+matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension")
\end{code}
\begin{code}
pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR)
=> HsStmtContext idL -> StmtLR idL idR -> SDoc
-pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon)
- 4 (ppr_stmt stmt)
+pprStmtInCtxt ctxt (LastStmt e _)
+ | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts"
+ = hang (ptext (sLit "In the expression:")) 2 (ppr e)
+
+pprStmtInCtxt ctxt stmt
+ = hang (ptext (sLit "In a stmt of") <+> pprAStmtContext ctxt <> colon)
+ 2 (ppr_stmt stmt)
where
-- For Group and Transform Stmts, don't print the nested stmts!
- ppr_stmt (GroupStmt _ _ by using) = pprGroupStmt by using
- ppr_stmt (TransformStmt _ bndrs using by) = pprTransformStmt bndrs using by
- ppr_stmt stmt = pprStmt stmt
+ ppr_stmt (TransStmt { trS_by = by, trS_using = using
+ , trS_form = form }) = pprTransStmt by using form
+ ppr_stmt stmt = pprStmt stmt
\end{code}
HsImpExp: Abstract syntax: imports, exports, interfaces
\begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
{-# LANGUAGE DeriveDataTypeable #-}
module HsImpExp where
ieName (IEThingAbs n) = n
ieName (IEThingWith n _) = n
ieName (IEThingAll n) = n
+ieName _ = panic "ieName failed pattern match!"
ieNames :: IE a -> [a]
ieNames (IEVar n ) = [n]
ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"]
ppr (IEThingWith thing withs)
= ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs)))
- ppr (IEModuleContents mod)
- = ptext (sLit "module") <+> ppr mod
+ ppr (IEModuleContents mod')
+ = ptext (sLit "module") <+> ppr mod'
ppr (IEGroup n _) = text ("<IEGroup: " ++ (show n) ++ ">")
ppr (IEDoc doc) = ppr doc
ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">")
#include "HsVersions.h"
import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
-import HsTypes (PostTcType)
+import BasicTypes ( FractionalLit(..) )
+import HsTypes ( PostTcType )
import Type ( Type )
import Outputable
import FastString
| HsWordPrim Integer -- Unboxed Word
| HsInteger Integer Type -- Genuinely an integer; arises only from TRANSLATION
-- (overloaded literals are done with HsOverLit)
- | HsRat Rational Type -- Genuinely a rational; arises only from TRANSLATION
+ | HsRat FractionalLit Type -- Genuinely a rational; arises only from TRANSLATION
-- (overloaded literals are done with HsOverLit)
- | HsFloatPrim Rational -- Unboxed Float
- | HsDoublePrim Rational -- Unboxed Double
+ | HsFloatPrim FractionalLit -- Unboxed Float
+ | HsDoublePrim FractionalLit -- Unboxed Double
deriving (Data, Typeable)
instance Eq HsLit where
data HsOverLit id -- An overloaded literal
= OverLit {
ol_val :: OverLitVal,
- ol_rebindable :: Bool, -- True <=> rebindable syntax
- -- False <=> standard syntax
+ ol_rebindable :: Bool, -- Note [ol_rebindable]
ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses]
ol_type :: PostTcType }
deriving (Data, Typeable)
data OverLitVal
= HsIntegral !Integer -- Integer-looking literals;
- | HsFractional !Rational -- Frac-looking literals
+ | HsFractional !FractionalLit -- Frac-looking literals
| HsIsString !FastString -- String-looking literals
deriving (Data, Typeable)
overLitType = ol_type
\end{code}
+Note [ol_rebindable]
+~~~~~~~~~~~~~~~~~~~~
+The ol_rebindable field is True if this literal is actually
+using rebindable syntax. Specifically:
+
+ False iff ol_witness is the standard one
+ True iff ol_witness is non-standard
+
+Equivalently it's True if
+ a) RebindableSyntax is on
+ b) the witness for fromInteger/fromRational/fromString
+ that happens to be in scope isn't the standard one
+
Note [Overloaded literal witnesses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*Before* type checking, the SyntaxExpr in an HsOverLit is the
This dual role is unusual, because we're replacing 'fromInteger' with
a call to fromInteger. Reason: it allows commoning up of the fromInteger
-calls, which wouldn't be possible if the desguarar made the application
+calls, which wouldn't be possible if the desguarar made the application.
The PostTcType in each branch records the type the overload literal is
found to have.
ppr (HsStringPrim s) = pprHsString s <> char '#'
ppr (HsInt i) = integer i
ppr (HsInteger i _) = integer i
- ppr (HsRat f _) = rational f
- ppr (HsFloatPrim f) = rational f <> char '#'
- ppr (HsDoublePrim d) = rational d <> text "##"
+ ppr (HsRat f _) = ppr f
+ ppr (HsFloatPrim f) = ppr f <> char '#'
+ ppr (HsDoublePrim d) = ppr d <> text "##"
ppr (HsIntPrim i) = integer i <> char '#'
ppr (HsWordPrim w) = integer w <> text "##"
instance Outputable OverLitVal where
ppr (HsIntegral i) = integer i
- ppr (HsFractional f) = rational f
+ ppr (HsFractional f) = ppr f
ppr (HsIsString s) = pprHsString s
\end{code}
isBangHsBind, isLiftedPatBind,
isBangLPat, hsPatNeedsParens,
- isIrrefutableHsPat,
+ isIrrefutableHsPat,
pprParendLPat
) where
-- support hsPatType :: Pat Id -> Type
| VarPat id -- Variable
- | LazyPat (LPat id) -- Lazy pattern
+ | LazyPat (LPat id) -- Lazy pattern
| AsPat (Located id) (LPat id) -- As pattern
| ParPat (LPat id) -- Parenthesised pattern
| BangPat (LPat id) -- Bang pattern
| LitPat HsLit -- Used for *non-overloaded* literal patterns:
-- Int#, Char#, Int, Char, String, etc.
- | NPat (HsOverLit id) -- ALWAYS positive
+ | NPat -- Used for all overloaded literals,
+ -- including overloaded strings with -XOverloadedStrings
+ (HsOverLit id) -- ALWAYS positive
(Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative
-- patterns, Nothing otherwise
(SyntaxExpr id) -- Equality checker, of type t->t->Bool
(SyntaxExpr id) -- (>=) function, of type t->t->Bool
(SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName)
- ------------ Generics ---------------
- | TypePat (LHsType id) -- Type pattern for generic definitions
- -- e.g f{| a+b |} = ...
- -- These show up only in class declarations,
- -- and should be a top-level pattern
-
------------ Pattern type signatures ---------------
| SigPatIn (LPat id) -- Pattern with a type signature
(LHsType id)
pprPat (NPat l (Just _) _) = char '-' <> ppr l
pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k]
pprPat (QuasiQuotePat qq) = ppr qq
-pprPat (TypePat ty) = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}")
pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co
pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty
pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty
go1 (QuasiQuotePat {}) = urk pat -- Gotten rid of by renamer, before
-- isIrrefutablePat is called
- go1 (TypePat {}) = urk pat
urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
hsPatNeedsParens (NPat {}) = False
hsPatNeedsParens (NPlusKPat {}) = True
hsPatNeedsParens (QuasiQuotePat {}) = True
-hsPatNeedsParens (TypePat {}) = False
conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon args) = not (null args)
-- interface files smaller), so when printing a HsType we may need to
-- add parens.
- | HsNumTy Integer -- Generics only
-
| HsPredTy (HsPred name) -- Only used in the type of an instance
-- declaration, eg. Eq [a] -> Eq a
-- ^^^^
ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsModalBoxType ecn ty) = ppr_modalBoxType (ppr ecn) (ppr_mono_lty pREC_TOP ty)
ppr_mono_ty _ (HsPredTy pred) = ppr pred
-ppr_mono_ty _ (HsNumTy n) = integer n -- generics only
ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty
mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
- mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
- coiToHsWrapper, mkHsLams, mkHsDictLet,
- mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI,
+ mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo,
+ coToHsWrapper, mkHsDictLet, mkHsLams,
+ mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
- -- Bindigns
+ -- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind,
-- Literals
nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
-- Stmts
- mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt,
- mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
+ mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt,
+ emptyTransStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt,
emptyRecStmt, mkRecStmt,
-- Template Haskell
import RdrName
import Var
import Coercion
-import Type
+import TypeRep
import DataCon
import Name
import NameSet
import BasicTypes
import SrcLoc
import FastString
-import Outputable
import Util
import Bag
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
| otherwise = HsWrap co_fn e
-mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
-mkHsWrapCoI (IdCo _) e = e
-mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
+mkHsWrapCo :: Coercion -> HsExpr id -> HsExpr id
+mkHsWrapCo (Refl _) e = e
+mkHsWrapCo co e = mkHsWrap (WpCast co) e
-mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id
-mkLHsWrapCoI (IdCo _) e = e
-mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e)
+mkLHsWrapCo :: Coercion -> LHsExpr id -> LHsExpr id
+mkLHsWrapCo (Refl _) e = e
+mkLHsWrapCo co (L loc e) = L loc (mkHsWrap (WpCast co) e)
-coiToHsWrapper :: CoercionI -> HsWrapper
-coiToHsWrapper (IdCo _) = idHsWrapper
-coiToHsWrapper (ACo co) = WpCast co
+coToHsWrapper :: Coercion -> HsWrapper
+coToHsWrapper (Refl _) = idHsWrapper
+coToHsWrapper co = WpCast co
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
| otherwise = CoPat co_fn p ty
-mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id
-mkHsWrapPatCoI (IdCo _) pat _ = pat
-mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty
+mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id
+mkHsWrapPatCo (Refl _) pat _ = pat
+mkHsWrapPatCo co pat ty = CoPat (WpCast co) pat ty
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
-- See RnEnv.lookupSyntaxName
mkHsIntegral :: Integer -> PostTcType -> HsOverLit id
-mkHsFractional :: Rational -> PostTcType -> HsOverLit id
+mkHsFractional :: FractionalLit -> PostTcType -> HsOverLit id
mkHsIsString :: FastString -> PostTcType -> HsOverLit id
-mkHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
+mkHsDo :: HsStmtContext Name -> [LStmt id] -> HsExpr id
+mkHsComp :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id
mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id
mkNPlusKPat :: Located id -> HsOverLit id -> Pat id
-mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
-mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
-
+mkLastStmt :: LHsExpr idR -> StmtLR idL idR
mkExprStmt :: LHsExpr idR -> StmtLR idL idR
mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR
noRebindableInfo :: Bool
noRebindableInfo = error "noRebindableInfo" -- Just another placeholder;
-mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
+mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType
+mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
+ where
+ last_stmt = L (getLoc expr) $ mkLastStmt expr
mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
mkNPat lit neg = NPat lit neg noSyntaxExpr
mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
-mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing
-mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr)
-
+mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
+mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR
mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
-mkGroupUsingStmt stmts usingExpr = GroupStmt stmts [] Nothing (Left usingExpr)
-mkGroupByStmt stmts byExpr = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr)
-mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr)
-
-mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType
+emptyTransStmt :: StmtLR idL idR
+emptyTransStmt = TransStmt { trS_form = undefined, trS_stmts = [], trS_bndrs = []
+ , trS_by = Nothing, trS_using = noLoc noSyntaxExpr
+ , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
+ , trS_fmap = noSyntaxExpr }
+mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u }
+mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
+mkGroupByStmt ss b = emptyTransStmt { trS_form = GroupFormB, trS_stmts = ss, trS_by = Just b }
+mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss, trS_using = u }
+mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss
+ , trS_by = Just b, trS_using = u }
+
+mkLastStmt expr = LastStmt expr noSyntaxExpr
+mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType
mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
, recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
, recS_bind_fn = noSyntaxExpr
- , recS_rec_rets = [] }
+ , recS_rec_rets = [], recS_ret_ty = placeHolderType }
mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
nlWildPat :: LPat id
nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking
-nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id
-nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body)
+nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id
+nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
-- Id Binders for a Stmt... [but what about pattern-sig type vars]?
collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
collectStmtBinders (LetStmt binds) = collectLocalBinders binds
-collectStmtBinders (ExprStmt _ _ _) = []
-collectStmtBinders (ParStmt xs) = collectLStmtsBinders
+collectStmtBinders (ExprStmt {}) = []
+collectStmtBinders (LastStmt {}) = []
+collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
$ concatMap fst xs
-collectStmtBinders (TransformStmt stmts _ _ _) = collectLStmtsBinders stmts
-collectStmtBinders (GroupStmt stmts _ _ _) = collectLStmtsBinders stmts
-collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
+collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
+collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
----------------- Patterns --------------------------
go (SigPatIn pat _) = collect_lpat pat bndrs
go (SigPatOut pat _) = collect_lpat pat bndrs
go (QuasiQuotePat _) = bndrs
- go (TypePat _) = bndrs
go (CoPat _ pat _) = go pat
\end{code}
hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
hs_stmt (LetStmt binds) = hs_local_binds binds
- hs_stmt (ExprStmt _ _ _) = emptyNameSet
- hs_stmt (ParStmt xs) = hs_lstmts $ concatMap fst xs
+ hs_stmt (ExprStmt {}) = emptyNameSet
+ hs_stmt (LastStmt {}) = emptyNameSet
+ hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs
- hs_stmt (TransformStmt stmts _ _ _) = hs_lstmts stmts
- hs_stmt (GroupStmt stmts _ _ _) = hs_lstmts stmts
- hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
+ hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
+ hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds
hs_local_binds (HsIPBinds _) = emptyNameSet
hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
hsValBindsImplicits (ValBindsOut binds _)
- = unionManyNameSets [foldBag unionNameSets (hs_bind . unLoc) emptyNameSet hs_binds | (_rec, hs_binds) <- binds]
+ = foldr (unionNameSets . lhsBindsImplicits . snd) emptyNameSet binds
+hsValBindsImplicits (ValBindsIn binds _)
+ = lhsBindsImplicits binds
+
+lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
+lhsBindsImplicits = foldBag unionNameSets lhs_bind emptyNameSet
where
- hs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
- hs_bind _ = emptyNameSet
-hsValBindsImplicits (ValBindsIn {}) = pprPanic "hsValBindsImplicits: ValBindsIn" empty
+ lhs_bind (L _ (PatBind { pat_lhs = lpat })) = lPatImplicits lpat
+ lhs_bind _ = emptyNameSet
lPatImplicits :: LPat Name -> NameSet
lPatImplicits = hs_lpat
collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name]
collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc)
-collect_sig_pat (TypePat ty) acc = ty:acc
collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc
collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc
-
{-# OPTIONS_GHC -O #-}
-- We always optimise this, otherwise performance of a non-optimised
-- compiler is severely affected
put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k }
-- Generic cases
-
put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
+ put_ bh (IfaceCoConApp cc tys) = do { putByte bh 20; put_ bh cc; put_ bh tys }
+
get bh = do
h <- getByte bh
case h of
17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
- _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
+ 19 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
+ _ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) }
instance Binary IfaceTyCon where
-- Int,Char,Bool can't show up here because they can't not be saturated
-
put_ bh IfaceIntTc = putByte bh 1
put_ bh IfaceBoolTc = putByte bh 2
put_ bh IfaceCharTc = putByte bh 3
put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
put_ bh IfaceUbxTupleKindTc = putByte bh 9
put_ bh IfaceArgTypeKindTc = putByte bh 10
- put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
- put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
- put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k }
+ put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
+ put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
+ put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k }
get bh = do
h <- getByte bh
10 -> return IfaceArgTypeKindTc
11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
12 -> do { ext <- get bh; return (IfaceTc ext) }
- _ -> do { k <- get bh; return (IfaceAnyTc k) }
+ _ -> do { k <- get bh; return (IfaceAnyTc k) }
+
+instance Binary IfaceCoCon where
+ put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n }
+ put_ bh IfaceReflCo = putByte bh 1
+ put_ bh IfaceUnsafeCo = putByte bh 2
+ put_ bh IfaceSymCo = putByte bh 3
+ put_ bh IfaceTransCo = putByte bh 4
+ put_ bh IfaceInstCo = putByte bh 5
+ put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d }
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do { n <- get bh; return (IfaceCoAx n) }
+ 1 -> return IfaceReflCo
+ 2 -> return IfaceUnsafeCo
+ 3 -> return IfaceSymCo
+ 4 -> return IfaceTransCo
+ 5 -> return IfaceInstCo
+ _ -> do { d <- get bh; return (IfaceNthCo d) }
instance Binary IfacePredType where
put_ bh (IfaceClassP aa ab) = do
put_ bh (IfaceType ab) = do
putByte bh 1
put_ bh ab
- put_ bh (IfaceTuple ac ad) = do
+ put_ bh (IfaceCo ab) = do
putByte bh 2
+ put_ bh ab
+ put_ bh (IfaceTuple ac ad) = do
+ putByte bh 3
put_ bh ac
put_ bh ad
put_ bh (IfaceLam ae af) = do
- putByte bh 3
+ putByte bh 4
put_ bh ae
put_ bh af
put_ bh (IfaceApp ag ah) = do
- putByte bh 4
+ putByte bh 5
put_ bh ag
put_ bh ah
--- gaw 2004
- put_ bh (IfaceCase ai aj al ak) = do
- putByte bh 5
+ put_ bh (IfaceCase ai aj ak) = do
+ putByte bh 6
put_ bh ai
put_ bh aj
--- gaw 2004
- put_ bh al
put_ bh ak
put_ bh (IfaceLet al am) = do
- putByte bh 6
+ putByte bh 7
put_ bh al
put_ bh am
put_ bh (IfaceNote an ao) = do
- putByte bh 7
+ putByte bh 8
put_ bh an
put_ bh ao
put_ bh (IfaceLit ap) = do
- putByte bh 8
+ putByte bh 9
put_ bh ap
put_ bh (IfaceFCall as at) = do
- putByte bh 9
+ putByte bh 10
put_ bh as
put_ bh at
put_ bh (IfaceExt aa) = do
- putByte bh 10
+ putByte bh 11
put_ bh aa
put_ bh (IfaceCast ie ico) = do
- putByte bh 11
+ putByte bh 12
put_ bh ie
put_ bh ico
put_ bh (IfaceTick m ix) = do
- putByte bh 12
+ putByte bh 13
put_ bh m
put_ bh ix
get bh = do
return (IfaceLcl aa)
1 -> do ab <- get bh
return (IfaceType ab)
- 2 -> do ac <- get bh
+ 2 -> do ab <- get bh
+ return (IfaceCo ab)
+ 3 -> do ac <- get bh
ad <- get bh
return (IfaceTuple ac ad)
- 3 -> do ae <- get bh
+ 4 -> do ae <- get bh
af <- get bh
return (IfaceLam ae af)
- 4 -> do ag <- get bh
+ 5 -> do ag <- get bh
ah <- get bh
return (IfaceApp ag ah)
- 5 -> do ai <- get bh
+ 6 -> do ai <- get bh
aj <- get bh
--- gaw 2004
- al <- get bh
ak <- get bh
--- gaw 2004
- return (IfaceCase ai aj al ak)
- 6 -> do al <- get bh
+ return (IfaceCase ai aj ak)
+ 7 -> do al <- get bh
am <- get bh
return (IfaceLet al am)
- 7 -> do an <- get bh
+ 8 -> do an <- get bh
ao <- get bh
return (IfaceNote an ao)
- 8 -> do ap <- get bh
+ 9 -> do ap <- get bh
return (IfaceLit ap)
- 9 -> do as <- get bh
- at <- get bh
- return (IfaceFCall as at)
- 10 -> do aa <- get bh
+ 10 -> do as <- get bh
+ at <- get bh
+ return (IfaceFCall as at)
+ 11 -> do aa <- get bh
return (IfaceExt aa)
- 11 -> do ie <- get bh
+ 12 -> do ie <- get bh
ico <- get bh
return (IfaceCast ie ico)
- 12 -> do m <- get bh
+ 13 -> do m <- get bh
ix <- get bh
return (IfaceTick m ix)
_ -> panic ("get IfaceExpr " ++ show h)
put_ bh idinfo
put_ _ (IfaceForeign _ _) =
error "Binary.put_(IfaceDecl): IfaceForeign"
- put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
+ put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do
putByte bh 2
put_ bh (occNameFS a1)
put_ bh a2
put_ bh a5
put_ bh a6
put_ bh a7
- put_ bh a8
put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
putByte bh 3
put_ bh (occNameFS a1)
a5 <- get bh
a6 <- get bh
a7 <- get bh
- a8 <- get bh
occ <- return $! mkOccNameFS tcName a1
- return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
+ return (IfaceData occ a2 a3 a4 a5 a6 a7)
3 -> do
a1 <- get bh
a2 <- get bh
buildDataCon,
TcMethInfo, buildClass,
mkAbstractTyConRhs,
- mkNewTyConRhs, mkDataTyConRhs
+ mkNewTyConRhs, mkDataTyConRhs,
+ newImplicitBinder
) where
#include "HsVersions.h"
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
-> RecFlag
- -> Bool -- ^ True <=> want generics functions
-> Bool -- ^ True <=> was declared in GADT syntax
-> TyConParent
-> Maybe (TyCon, [Type]) -- ^ family instance if applicable
-> TcRnIf m n TyCon
-buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
+buildAlgTyCon tc_name tvs stupid_theta rhs is_rec gadt_syn
parent mb_family
| Just fam_inst_info <- mb_family
= -- We need to tie a knot as the coercion of a data instance depends
fixM $ \ tycon_rec -> do
{ fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
- fam_parent is_rec want_generics gadt_syn) }
+ fam_parent is_rec gadt_syn) }
| otherwise
= return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
- parent is_rec want_generics gadt_syn)
+ parent is_rec gadt_syn)
where
kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon
= do { -- Create the coercion
; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
- ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
- family instTys rep_tycon
+ ; let co_tycon = mkFamInstCo co_tycon_name tvs
+ family instTys rep_tycon
; return $ FamInstTyCon family instTys co_tycon }
------------------------------------------------------
-- because the latter is part of a knot, whereas the former is not.
mkNewTyConRhs tycon_name tycon con
= do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
- ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon etad_tvs etad_rhs
- cocon_maybe | all_coercions || isRecursiveTyCon tycon
- = Just co_tycon
- | otherwise
- = Nothing
- ; traceIf (text "mkNewTyConRhs" <+> ppr cocon_maybe)
+ ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_rhs
+ ; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon)
; return (NewTyCon { data_con = con,
nt_rhs = rhs_ty,
nt_etad_rhs = (etad_tvs, etad_rhs),
- nt_co = cocon_maybe } ) }
+ nt_co = co_tycon } ) }
-- Coreview looks through newtypes with a Nothing
-- for nt_co, or uses explicit coercions otherwise
where
- -- If all_coercions is True then we use coercions for all newtypes
- -- otherwise we use coercions for recursive newtypes and look through
- -- non-recursive newtypes
- all_coercions = True
tvs = tyConTyVars tycon
inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
-- has a single argument (Foo a) that is a *type class*, so
-- dataConInstOrigArgTys returns [].
- etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can
+ etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can
etad_rhs :: Type -- return a TyCon without pulling on rhs_ty
-- See Note [Tricky iface loop] in LoadIface
(etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty
------------------------------------------------------
\begin{code}
-type TcMethInfo = (Name, DefMethSpec, Type) -- A temporary intermediate, to communicate
- -- between tcClassSigs and buildClass
+type TcMethInfo = (Name, DefMethSpec, Type)
+ -- A temporary intermediate, to communicate between
+ -- tcClassSigs and buildClass.
buildClass :: Bool -- True <=> do not include unfoldings
-- on dict selectors
mk_op_item rec_clas (op_name, dm_spec, _)
= do { dm_info <- case dm_spec of
NoDM -> return NoDefMeth
- GenericDM -> return GenDefMeth
+ GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
+ ; return (GenDefMeth dm_name) }
VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
; return (DefMeth dm_name) }
; return (mkDictSelId no_unf op_name rec_clas, dm_info) }
\begin{code}
module IfaceSyn (
- module IfaceType, -- Re-export all this
+ module IfaceType,
- IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
- IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
- IfaceBinding(..), IfaceConAlt(..),
- IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
- IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
- IfaceInst(..), IfaceFamInst(..),
+ IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
+ IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
+ IfaceBinding(..), IfaceConAlt(..),
+ IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
+ IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
+ IfaceInst(..), IfaceFamInst(..),
- -- Misc
+ -- Misc
ifaceDeclSubBndrs, visibleIfConDecls,
-- Free Names
freeNamesIfDecl, freeNamesIfRule,
- -- Pretty printing
- pprIfaceExpr, pprIfaceDeclHead
+ -- Pretty printing
+ pprIfaceExpr, pprIfaceDeclHead
) where
#include "HsVersions.h"
import IfaceType
import CoreSyn( DFunArg, dfunArgExprs )
-import PprCore() -- Printing DFunArgs
+import PprCore() -- Printing DFunArgs
import Demand
import Annotations
import Class
-import NameSet
+import NameSet
import Name
import CostCentre
import Literal
%************************************************************************
-%* *
- Data type declarations
-%* *
+%* *
+ Data type declarations
+%* *
%************************************************************************
\begin{code}
-data IfaceDecl
- = IfaceId { ifName :: OccName,
- ifType :: IfaceType,
- ifIdDetails :: IfaceIdDetails,
- ifIdInfo :: IfaceIdInfo }
-
- | IfaceData { ifName :: OccName, -- Type constructor
- ifTyVars :: [IfaceTvBndr], -- Type variables
- ifCtxt :: IfaceContext, -- The "stupid theta"
- ifCons :: IfaceConDecls, -- Includes new/data info
- ifRec :: RecFlag, -- Recursive or not?
- ifGadtSyntax :: Bool, -- True <=> declared using
- -- GADT syntax
- ifGeneric :: Bool, -- True <=> generic converter
- -- functions available
- -- We need this for imported
- -- data decls, since the
- -- imported modules may have
- -- been compiled with
- -- different flags to the
- -- current compilation unit
+data IfaceDecl
+ = IfaceId { ifName :: OccName,
+ ifType :: IfaceType,
+ ifIdDetails :: IfaceIdDetails,
+ ifIdInfo :: IfaceIdInfo }
+
+ | IfaceData { ifName :: OccName, -- Type constructor
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifCtxt :: IfaceContext, -- The "stupid theta"
+ ifCons :: IfaceConDecls, -- Includes new/data info
+ ifRec :: RecFlag, -- Recursive or not?
+ ifGadtSyntax :: Bool, -- True <=> declared using
+ -- GADT syntax
ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
- -- Invariant:
+ -- Invariant:
-- ifCons /= IfOpenDataTyCon
-- for family instances
}
- | IfaceSyn { ifName :: OccName, -- Type constructor
- ifTyVars :: [IfaceTvBndr], -- Type variables
- ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon)
- ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn
- -- Nothing for an open family
+ | IfaceSyn { ifName :: OccName, -- Type constructor
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon)
+ ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn
+ -- Nothing for an open family
ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
-- Just <=> instance of family
-- Invariant: ifOpenSyn == False
-- for family instances
}
- | IfaceClass { ifCtxt :: IfaceContext, -- Context...
- ifName :: OccName, -- Name of the class
- ifTyVars :: [IfaceTvBndr], -- Type variables
- ifFDs :: [FunDep FastString], -- Functional dependencies
- ifATs :: [IfaceDecl], -- Associated type families
- ifSigs :: [IfaceClassOp], -- Method signatures
- ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive?
+ | IfaceClass { ifCtxt :: IfaceContext, -- Context...
+ ifName :: OccName, -- Name of the class
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifFDs :: [FunDep FastString], -- Functional dependencies
+ ifATs :: [IfaceDecl], -- Associated type families
+ ifSigs :: [IfaceClassOp], -- Method signatures
+ ifRec :: RecFlag -- Is newtype/datatype associated
+ -- with the class recursive?
}
| IfaceForeign { ifName :: OccName, -- Needs expanding when we move
-- beyond .NET
- ifExtName :: Maybe FastString }
+ ifExtName :: Maybe FastString }
data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType
- -- Nothing => no default method
- -- Just False => ordinary polymorphic default method
- -- Just True => generic default method
+ -- Nothing => no default method
+ -- Just False => ordinary polymorphic default method
+ -- Just True => generic default method
data IfaceConDecls
- = IfAbstractTyCon -- No info
- | IfOpenDataTyCon -- Open data family
- | IfDataTyCon [IfaceConDecl] -- data type decls
- | IfNewTyCon IfaceConDecl -- newtype decls
+ = IfAbstractTyCon -- No info
+ | IfOpenDataTyCon -- Open data family
+ | IfDataTyCon [IfaceConDecl] -- data type decls
+ | IfNewTyCon IfaceConDecl -- newtype decls
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls IfAbstractTyCon = []
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
-data IfaceConDecl
+data IfaceConDecl
= IfCon {
- ifConOcc :: OccName, -- Constructor name
- ifConWrapper :: Bool, -- True <=> has a wrapper
- ifConInfix :: Bool, -- True <=> declared infix
- ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars
- ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
- ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints
- ifConCtxt :: IfaceContext, -- Non-stupid context
- ifConArgTys :: [IfaceType], -- Arg types
- ifConFields :: [OccName], -- ...ditto... (field labels)
- ifConStricts :: [HsBang]} -- Empty (meaning all lazy),
- -- or 1-1 corresp with arg tys
-
-data IfaceInst
- = IfaceInst { ifInstCls :: IfExtName, -- See comments with
- ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
- ifDFun :: IfExtName, -- The dfun
- ifOFlag :: OverlapFlag, -- Overlap flag
- ifInstOrph :: Maybe OccName } -- See Note [Orphans]
- -- There's always a separate IfaceDecl for the DFun, which gives
- -- its IdInfo with its full type and version number.
- -- The instance declarations taken together have a version number,
- -- and we don't want that to wobble gratuitously
- -- If this instance decl is *used*, we'll record a usage on the dfun;
- -- and if the head does not change it won't be used if it wasn't before
+ ifConOcc :: OccName, -- Constructor name
+ ifConWrapper :: Bool, -- True <=> has a wrapper
+ ifConInfix :: Bool, -- True <=> declared infix
+ ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars
+ ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
+ ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints
+ ifConCtxt :: IfaceContext, -- Non-stupid context
+ ifConArgTys :: [IfaceType], -- Arg types
+ ifConFields :: [OccName], -- ...ditto... (field labels)
+ ifConStricts :: [HsBang]} -- Empty (meaning all lazy),
+ -- or 1-1 corresp with arg tys
+
+data IfaceInst
+ = IfaceInst { ifInstCls :: IfExtName, -- See comments with
+ ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
+ ifDFun :: IfExtName, -- The dfun
+ ifOFlag :: OverlapFlag, -- Overlap flag
+ ifInstOrph :: Maybe OccName } -- See Note [Orphans]
+ -- There's always a separate IfaceDecl for the DFun, which gives
+ -- its IdInfo with its full type and version number.
+ -- The instance declarations taken together have a version number,
+ -- and we don't want that to wobble gratuitously
+ -- If this instance decl is *used*, we'll record a usage on the dfun;
+ -- and if the head does not change it won't be used if it wasn't before
data IfaceFamInst
= IfaceFamInst { ifFamInstFam :: IfExtName -- Family tycon
- , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types
- , ifFamInstTyCon :: IfaceTyCon -- Instance decl
- }
+ , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types
+ , ifFamInstTyCon :: IfaceTyCon -- Instance decl
+ }
data IfaceRule
- = IfaceRule {
- ifRuleName :: RuleName,
- ifActivation :: Activation,
- ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
- ifRuleHead :: IfExtName, -- Head of lhs
- ifRuleArgs :: [IfaceExpr], -- Args of LHS
- ifRuleRhs :: IfaceExpr,
- ifRuleAuto :: Bool,
- ifRuleOrph :: Maybe OccName -- Just like IfaceInst
+ = IfaceRule {
+ ifRuleName :: RuleName,
+ ifActivation :: Activation,
+ ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
+ ifRuleHead :: IfExtName, -- Head of lhs
+ ifRuleArgs :: [IfaceExpr], -- Args of LHS
+ ifRuleRhs :: IfaceExpr,
+ ifRuleAuto :: Bool,
+ ifRuleOrph :: Maybe OccName -- Just like IfaceInst
}
data IfaceAnnotation
| IfDFunId Int -- Number of silent args
data IfaceIdInfo
- = NoInfo -- When writing interface file without -O
- | HasInfo [IfaceInfoItem] -- Has info, and here it is
+ = NoInfo -- When writing interface file without -O
+ | HasInfo [IfaceInfoItem] -- Has info, and here it is
-- Here's a tricky case:
-- * Compile with -O module A, and B which imports A.f
-- * Change function f in A, and recompile without -O
-- * When we read in old A.hi we read in its IdInfo (as a thunk)
--- (In earlier GHCs we used to drop IdInfo immediately on reading,
--- but we do not do that now. Instead it's discarded when the
--- ModIface is read into the various decl pools.)
+-- (In earlier GHCs we used to drop IdInfo immediately on reading,
+-- but we do not do that now. Instead it's discarded when the
+-- ModIface is read into the various decl pools.)
-- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
--- and so gives a new version.
+-- and so gives a new version.
data IfaceInfoItem
- = HsArity Arity
+ = HsArity Arity
| HsStrictness StrictSig
| HsInline InlinePragma
- | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true
- IfaceUnfolding -- See Note [Expose recursive functions]
+ | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true
+ IfaceUnfolding -- See Note [Expose recursive functions]
| HsNoCafRefs
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id. Partial reason: some are orphans.
-data IfaceUnfolding
+data IfaceUnfolding
= IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
-- Possibly could eliminate the Bool here, the information
-- is also in the InlinePragma.
- | IfCompulsory IfaceExpr -- Only used for default methods, in fact
+ | IfCompulsory IfaceExpr -- Only used for default methods, in fact
| IfInlineRule Arity -- INLINE pragmas
- Bool -- OK to inline even if *un*-saturated
- Bool -- OK to inline even if context is boring
- IfaceExpr
+ Bool -- OK to inline even if *un*-saturated
+ Bool -- OK to inline even if context is boring
+ IfaceExpr
- | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName)
- | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in
- -- another module.
+ | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName)
+ | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in
+ -- another module.
| IfDFunUnfold [DFunArg IfaceExpr]
--------------------------------
data IfaceExpr
- = IfaceLcl IfLclName
+ = IfaceLcl IfLclName
| IfaceExt IfExtName
| IfaceType IfaceType
- | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
+ | IfaceCo IfaceType -- We re-use IfaceType for coercions
+ | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
- | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt]
+ | IfaceCase IfaceExpr IfLclName [IfaceAlt]
| IfaceLet IfaceBinding IfaceExpr
| IfaceNote IfaceNote IfaceExpr
| IfaceCast IfaceExpr IfaceCoercion
- | IfaceLit Literal
- | IfaceFCall ForeignCall IfaceType
+ | IfaceLit Literal
+ | IfaceFCall ForeignCall IfaceType
| IfaceTick Module Int
data IfaceNote = IfaceSCC CostCentre
| IfaceCoreNote String
type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)
- -- Note: IfLclName, not IfaceBndr (and same with the case binder)
- -- We reconstruct the kind/type of the thing from the context
- -- thus saving bulk in interface files
+ -- Note: IfLclName, not IfaceBndr (and same with the case binder)
+ -- We reconstruct the kind/type of the thing from the context
+ -- thus saving bulk in interface files
data IfaceConAlt = IfaceDefault
- | IfaceDataAlt IfExtName
- | IfaceTupleAlt Boxity
- | IfaceLitAlt Literal
+ | IfaceDataAlt IfExtName
+ | IfaceTupleAlt Boxity
+ | IfaceLitAlt Literal
data IfaceBinding
- = IfaceNonRec IfaceLetBndr IfaceExpr
- | IfaceRec [(IfaceLetBndr, IfaceExpr)]
+ = IfaceNonRec IfaceLetBndr IfaceExpr
+ | IfaceRec [(IfaceLetBndr, IfaceExpr)]
-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
-- It's used for *non-top-level* let/rec binders
and suppose we are compiling module X:
module X where
- import M
- data T = ...
- instance C Int T where ...
+ import M
+ data T = ...
+ instance C Int T where ...
This instance is an orphan, because when compiling a third module Y we
might get a constraint (C Int v), and we'd want to improve v to T. So
If there are fundeps, then for every fundep, at least one of the
names free in a *non-determined* part of the instance head is
- defined in this module.
+ defined in this module.
(Note that these conditions hold trivially if the class is locally
defined.)
and suppose we are compiling module X:
module X where
- import M
- data S = ...
- data T = ...
- instance C S T where ...
+ import M
+ data S = ...
+ data T = ...
+ instance C S T where ...
If we base the instance verion on T, I'm worried that changing S to S'
would change T's version, but not S or S'. But an importing module might
Note [Versioning of rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~
-A rule that is not an orphan has an ifRuleOrph field of (Just n), where
-n appears on the LHS of the rule; any change in the rule changes the version of n.
+A rule that is not an orphan has an ifRuleOrph field of (Just n), where n
+appears on the LHS of the rule; any change in the rule changes the version of n.
\begin{code}
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
ifCons = IfNewTyCon (
IfCon { ifConOcc = con_occ }),
- ifFamInst = famInst})
+ ifFamInst = famInst})
= -- implicit coerion and (possibly) family instance coercion
(mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++
-- data constructor and worker (newtypes don't have a wrapper)
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
- ifCons = IfDataTyCon cons,
- ifFamInst = famInst})
+ ifCons = IfDataTyCon cons,
+ ifFamInst = famInst})
= -- (possibly) family instance coercion;
-- there is no implicit coercion for non-newtypes
famInstCo famInst tc_occ
++ concatMap dc_occs cons
where
dc_occs con_decl
- | has_wrapper = [con_occ, work_occ, wrap_occ]
- | otherwise = [con_occ, work_occ]
- where
- con_occ = ifConOcc con_decl -- DataCon namespace
- wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace
- work_occ = mkDataConWorkerOcc con_occ -- Id namespace
- has_wrapper = ifConWrapper con_decl -- This is the reason for
- -- having the ifConWrapper field!
-
-ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
- ifSigs = sigs, ifATs = ats })
+ | has_wrapper = [con_occ, work_occ, wrap_occ]
+ | otherwise = [con_occ, work_occ]
+ where
+ con_occ = ifConOcc con_decl -- DataCon namespace
+ wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace
+ work_occ = mkDataConWorkerOcc con_occ -- Id namespace
+ has_wrapper = ifConWrapper con_decl -- This is the reason for
+ -- having the ifConWrapper field!
+
+ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
+ ifSigs = sigs, ifATs = ats })
= -- dictionary datatype:
-- type constructor
- tc_occ :
+ tc_occ :
-- (possibly) newtype coercion
co_occs ++
-- data constructor (DataCon namespace)
n_ctxt = length sc_ctxt
n_sigs = length sigs
tc_occ = mkClassTyConOcc cls_occ
- dc_occ = mkClassDataConOcc cls_occ
+ dc_occ = mkClassDataConOcc cls_occ
co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
- | otherwise = []
+ | otherwise = []
dcww_occ = mkDataConWorkerOcc dc_occ
- is_newtype = n_sigs + n_ctxt == 1 -- Sigh
+ is_newtype = n_sigs + n_ctxt == 1 -- Sigh
ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ,
- ifFamInst = famInst})
+ ifFamInst = famInst})
= famInstCo famInst tc_occ
ifaceDeclSubBndrs _ = []
ppr = pprIfaceDecl
pprIfaceDecl :: IfaceDecl -> SDoc
-pprIfaceDecl (IfaceId {ifName = var, ifType = ty,
+pprIfaceDecl (IfaceId {ifName = var, ifType = ty,
ifIdDetails = details, ifIdInfo = info})
- = sep [ ppr var <+> dcolon <+> ppr ty,
- nest 2 (ppr details),
- nest 2 (ppr info) ]
+ = sep [ ppr var <+> dcolon <+> ppr ty,
+ nest 2 (ppr details),
+ nest 2 (ppr info) ]
pprIfaceDecl (IfaceForeign {ifName = tycon})
= hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
- ifSynRhs = Just mono_ty,
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+ ifSynRhs = Just mono_ty,
ifFamInst = mbFamInst})
= hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
- ifSynRhs = Nothing, ifSynKind = kind })
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+ ifSynRhs = Nothing, ifSynKind = kind })
= hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
4 (dcolon <+> ppr kind)
-pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
- ifTyVars = tyvars, ifCons = condecls,
- ifRec = isrec, ifFamInst = mbFamInst})
+pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context,
+ ifTyVars = tyvars, ifCons = condecls,
+ ifRec = isrec, ifFamInst = mbFamInst})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
- 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
- pprFamily mbFamInst])
+ 4 (vcat [pprRec isrec, pp_condecls tycon condecls,
+ pprFamily mbFamInst])
where
pp_nd = case condecls of
- IfAbstractTyCon -> ptext (sLit "data")
- IfOpenDataTyCon -> ptext (sLit "data family")
- IfDataTyCon _ -> ptext (sLit "data")
- IfNewTyCon _ -> ptext (sLit "newtype")
-
-pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
- ifFDs = fds, ifATs = ats, ifSigs = sigs,
- ifRec = isrec})
+ IfAbstractTyCon -> ptext (sLit "data")
+ IfOpenDataTyCon -> ptext (sLit "data family")
+ IfDataTyCon _ -> ptext (sLit "data")
+ IfNewTyCon _ -> ptext (sLit "newtype")
+
+pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
+ ifFDs = fds, ifATs = ats, ifSigs = sigs,
+ ifRec = isrec})
= hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
4 (vcat [pprRec isrec,
- sep (map ppr ats),
- sep (map ppr sigs)])
+ sep (map ppr ats),
+ sep (map ppr sigs)])
pprRec :: RecFlag -> SDoc
pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
-pprGen :: Bool -> SDoc
-pprGen True = ptext (sLit "Generics: yes")
-pprGen False = ptext (sLit "Generics: no")
-
pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc
pprFamily Nothing = ptext (sLit "FamilyInstance: none")
pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst
pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
pprIfaceDeclHead context thing tyvars
- = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
- pprIfaceTvBndrs tyvars]
+ = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
+ pprIfaceTvBndrs tyvars]
pp_condecls :: OccName -> IfaceConDecls -> SDoc
pp_condecls _ IfAbstractTyCon = ptext (sLit "{- abstract -}")
pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
pp_condecls _ IfOpenDataTyCon = empty
pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
- (map (pprIfaceConDecl tc) cs))
+ (map (pprIfaceConDecl tc) cs))
pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
pprIfaceConDecl tc
- (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap,
- ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
- ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
- ifConStricts = strs, ifConFields = fields })
+ (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap,
+ ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
+ ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
+ ifConStricts = strs, ifConFields = fields })
= sep [main_payload,
- if is_infix then ptext (sLit "Infix") else empty,
- if has_wrap then ptext (sLit "HasWrapper") else empty,
- ppUnless (null strs) $
- nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)),
- ppUnless (null fields) $
- nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
+ if is_infix then ptext (sLit "Infix") else empty,
+ if has_wrap then ptext (sLit "HasWrapper") else empty,
+ ppUnless (null strs) $
+ nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)),
+ ppUnless (null fields) $
+ nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
where
- ppr_bang HsNoBang = char '_' -- Want to see these
+ ppr_bang HsNoBang = char '_' -- Want to see these
ppr_bang bang = ppr bang
-
- main_payload = ppr name <+> dcolon <+>
- pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
- eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
- | (tv,ty) <- eq_spec]
+ main_payload = ppr name <+> dcolon <+>
+ pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
+
+ eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
+ | (tv,ty) <- eq_spec]
- -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
- -- because we don't have a Name for the tycon, only an OccName
+ -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
+ -- because we don't have a Name for the tycon, only an OccName
pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
- (t:ts) -> fsep (t : map (arrow <+>) ts)
- [] -> panic "pp_con_taus"
+ (t:ts) -> fsep (t : map (arrow <+>) ts)
+ [] -> panic "pp_con_taus"
pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs]
instance Outputable IfaceRule where
ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
- ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
+ ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
= sep [hsep [doubleQuotes (ftext name), ppr act,
- ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
- nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
- ptext (sLit "=") <+> ppr rhs])
+ ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
+ nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
+ ptext (sLit "=") <+> ppr rhs])
]
instance Outputable IfaceInst where
- ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
- ifInstCls = cls, ifInstTys = mb_tcs})
- = hang (ptext (sLit "instance") <+> ppr flag
- <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
+ ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
+ ifInstCls = cls, ifInstTys = mb_tcs})
+ = hang (ptext (sLit "instance") <+> ppr flag
+ <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr dfun_id)
instance Outputable IfaceFamInst where
ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
- ifFamInstTyCon = tycon_id})
- = hang (ptext (sLit "family instance") <+>
- ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
+ ifFamInstTyCon = tycon_id})
+ = hang (ptext (sLit "family instance") <+>
+ ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr tycon_id)
ppr_rough :: Maybe IfaceTyCon -> SDoc
pprParendIfaceExpr :: IfaceExpr -> SDoc
pprParendIfaceExpr = pprIfaceExpr parens
+-- | Pretty Print an IfaceExpre
+--
+-- The first argument should be a function that adds parens in context that need
+-- an atomic value (e.g. function args)
pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
- -- The function adds parens in context that need
- -- an atomic value (e.g. function args)
pprIfaceExpr _ (IfaceLcl v) = ppr v
pprIfaceExpr _ (IfaceExt v) = ppr v
pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
pprIfaceExpr _ (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix)
pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty
+pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceType co
pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as)
-pprIfaceExpr add_par e@(IfaceLam _ _)
+pprIfaceExpr add_par i@(IfaceLam _ _)
= add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
- pprIfaceExpr noParens body])
- where
- (bndrs,body) = collect [] e
+ pprIfaceExpr noParens body])
+ where
+ (bndrs,body) = collect [] i
collect bs (IfaceLam b e) = collect (b:bs) e
collect bs e = (reverse bs, e)
-pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
- = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
+pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
+ = add_par (sep [ptext (sLit "case")
<+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
<+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
pprIfaceExpr noParens rhs <+> char '}'])
-pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
- = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
+pprIfaceExpr add_par (IfaceCase scrut bndr alts)
+ = add_par (sep [ptext (sLit "case")
<+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
<+> ppr bndr <+> char '{',
nest 2 (sep (map ppr_alt alts)) <+> char '}'])
pprIfaceExpr _ (IfaceCast expr co)
= sep [pprParendIfaceExpr expr,
- nest 2 (ptext (sLit "`cast`")),
- pprParendIfaceType co]
+ nest 2 (ptext (sLit "`cast`")),
+ pprParendIfaceType co]
pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
- = add_par (sep [ptext (sLit "let {"),
- nest 2 (ppr_bind (b, rhs)),
- ptext (sLit "} in"),
- pprIfaceExpr noParens body])
+ = add_par (sep [ptext (sLit "let {"),
+ nest 2 (ppr_bind (b, rhs)),
+ ptext (sLit "} in"),
+ pprIfaceExpr noParens body])
pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
= add_par (sep [ptext (sLit "letrec {"),
- nest 2 (sep (map ppr_bind pairs)),
- ptext (sLit "} in"),
- pprIfaceExpr noParens body])
+ nest 2 (sep (map ppr_bind pairs)),
+ ptext (sLit "} in"),
+ pprIfaceExpr noParens body])
-pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprParendIfaceExpr body)
+pprIfaceExpr add_par (IfaceNote note body) = add_par $ ppr note
+ <+> pprParendIfaceExpr body
ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc
-ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
- arrow <+> pprIfaceExpr noParens rhs]
+ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
+ arrow <+> pprIfaceExpr noParens rhs]
ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc
ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
-ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
-
+ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
+
ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc
-ppr_bind (IfLetBndr b ty info, rhs)
+ppr_bind (IfLetBndr b ty info, rhs)
= sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info),
- equals <+> pprIfaceExpr noParens rhs]
+ equals <+> pprIfaceExpr noParens rhs]
------------------
pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
-pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprParendIfaceExpr arg) : args)
-pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
+pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $
+ nest 2 (pprParendIfaceExpr arg) : args
+pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
------------------
instance Outputable IfaceNote where
ppr (IfaceSCC cc) = pprCostCentreCore cc
- ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s)
+ ppr (IfaceCoreNote s) = ptext (sLit "__core_note")
+ <+> pprHsString (mkFastString s)
instance Outputable IfaceConAlt where
ppr IfaceDefault = text "DEFAULT"
ppr (IfaceLitAlt l) = ppr l
ppr (IfaceDataAlt d) = ppr d
- ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt"
+ ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt"
-- IfaceTupleAlt is handled by the case-alternative printer
------------------
instance Outputable IfaceIdDetails where
- ppr IfVanillaId = empty
+ ppr IfVanillaId = empty
ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc
- <+> if b then ptext (sLit "<naughty>") else empty
+ <+> if b then ptext (sLit "<naughty>") else empty
ppr (IfDFunId ns) = ptext (sLit "DFunId") <> brackets (int ns)
instance Outputable IfaceIdInfo where
ppr NoInfo = empty
- ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}")
+ ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is
+ <+> ptext (sLit "-}")
instance Outputable IfaceInfoItem where
- ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") <> ppWhen lb (ptext (sLit "(loop-breaker)"))
+ ppr (HsUnfold lb unf) = ptext (sLit "Unfolding")
+ <> ppWhen lb (ptext (sLit "(loop-breaker)"))
<> colon <+> ppr unf
ppr (HsInline prag) = ptext (sLit "Inline:") <+> ppr prag
ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity
ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
- ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs")
+ ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs")
instance Outputable IfaceUnfolding where
ppr (IfCompulsory e) = ptext (sLit "<compulsory>") <+> parens (ppr e)
- ppr (IfCoreUnfold s e) = (if s then ptext (sLit "<stable>") else empty) <+> parens (ppr e)
- ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok),
- pprParendIfaceExpr e]
+ ppr (IfCoreUnfold s e) = (if s then ptext (sLit "<stable>") else empty)
+ <+> parens (ppr e)
+ ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule")
+ <+> ppr (a,uok,bok),
+ pprParendIfaceExpr e]
ppr (IfLclWrapper a wkr) = ptext (sLit "Worker(lcl):") <+> ppr wkr
<+> parens (ptext (sLit "arity") <+> int a)
ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext0:") <+> ppr wkr
<+> brackets (pprWithCommas ppr ns)
-- -----------------------------------------------------------------------------
--- Finding the Names in IfaceSyn
+-- | Finding the Names in IfaceSyn
-- This is used for dependency analysis in MkIface, so that we
-- fingerprint a declaration before the things that depend on it. It
-- fingerprinting the instance, so DFuns are not dependencies.
freeNamesIfDecl :: IfaceDecl -> NameSet
-freeNamesIfDecl (IfaceId _s t d i) =
+freeNamesIfDecl (IfaceId _s t d i) =
freeNamesIfType t &&&
freeNamesIfIdInfo i &&&
freeNamesIfIdDetails d
-freeNamesIfDecl IfaceForeign{} =
+freeNamesIfDecl IfaceForeign{} =
emptyNameSet
freeNamesIfDecl d@IfaceData{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfSynRhs Nothing = emptyNameSet
freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet
-freeNamesIfTcFam (Just (tc,tys)) =
+freeNamesIfTcFam (Just (tc,tys)) =
freeNamesIfTc tc &&& fnList freeNamesIfType tys
freeNamesIfTcFam Nothing =
emptyNameSet
freeNamesIfConDecls _ = emptyNameSet
freeNamesIfConDecl :: IfaceConDecl -> NameSet
-freeNamesIfConDecl c =
+freeNamesIfConDecl c =
freeNamesIfTvBndrs (ifConUnivTvs c) &&&
freeNamesIfTvBndrs (ifConExTvs c) &&&
- freeNamesIfContext (ifConCtxt c) &&&
+ freeNamesIfContext (ifConCtxt c) &&&
fnList freeNamesIfType (ifConArgTys c) &&&
fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
freeNamesIfPredType :: IfacePredType -> NameSet
-freeNamesIfPredType (IfaceClassP cl tys) =
+freeNamesIfPredType (IfaceClassP cl tys) =
unitNameSet cl &&& fnList freeNamesIfType tys
freeNamesIfPredType (IfaceIParam _n ty) =
freeNamesIfType ty
freeNamesIfType (IfaceTyVar _) = emptyNameSet
freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfType (IfacePredTy st) = freeNamesIfPredType st
-freeNamesIfType (IfaceTyConApp tc ts) =
+freeNamesIfType (IfaceTyConApp tc ts) =
freeNamesIfTc tc &&& fnList freeNamesIfType ts
freeNamesIfType (IfaceForAllTy tv t) =
freeNamesIfTvBndr tv &&& freeNamesIfType t
freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfaceCoConApp tc ts) =
+ freeNamesIfCo tc &&& fnList freeNamesIfType ts
freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet
freeNamesIfTvBndrs = fnList freeNamesIfTvBndr
freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
-- Remember IfaceLetBndr is used only for *nested* bindings
--- The IdInfo can contain an unfolding (in the case of
+-- The IdInfo can contain an unfolding (in the case of
-- local INLINE pragmas), so look there too
freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty
&&& freeNamesIfIdInfo info
freeNamesIfIdBndr = freeNamesIfTvBndr
freeNamesIfIdInfo :: IfaceIdInfo -> NameSet
-freeNamesIfIdInfo NoInfo = emptyNameSet
+freeNamesIfIdInfo NoInfo = emptyNameSet
freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
freeNamesItem :: IfaceInfoItem -> NameSet
freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs)
freeNamesIfExpr :: IfaceExpr -> NameSet
-freeNamesIfExpr (IfaceExt v) = unitNameSet v
+freeNamesIfExpr (IfaceExt v) = unitNameSet v
freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty
+freeNamesIfExpr (IfaceCo co) = freeNamesIfType co
freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body
freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co
-freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r
+freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r
-freeNamesIfExpr (IfaceCase s _ ty alts)
+freeNamesIfExpr (IfaceCase s _ alts)
= freeNamesIfExpr s
&&& fnList fn_alt alts &&& fn_cons alts
- &&& freeNamesIfType ty
where
fn_alt (_con,_bs,r) = freeNamesIfExpr r
-- Depend on the data constructors. Just one will do!
-- Note [Tracking data constructors]
- fn_cons [] = emptyNameSet
- fn_cons ((IfaceDefault ,_,_) : alts) = fn_cons alts
- fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con
- fn_cons (_ : _ ) = emptyNameSet
+ fn_cons [] = emptyNameSet
+ fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs
+ fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con
+ fn_cons (_ : _ ) = emptyNameSet
freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body)
= freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body
-- ToDo: shouldn't we include IfaceIntTc & co.?
freeNamesIfTc _ = emptyNameSet
+freeNamesIfCo :: IfaceCoCon -> NameSet
+freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc
+freeNamesIfCo _ = emptyNameSet
+
freeNamesIfRule :: IfaceRule -> NameSet
freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
, ifRuleArgs = es, ifRuleRhs = rhs })
Note [Tracking data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In a case expression
+In a case expression
case e of { C a -> ...; ... }
You might think that we don't need to include the datacon C
-in the free names, because its type will probably show up in
+in the free names, because its type will probably show up in
the free names of 'e'. But in rare circumstances this may
not happen. Here's the one that bit me:
- module DynFlags where
+ module DynFlags where
import {-# SOURCE #-} Packages( PackageState )
data DynFlags = DF ... PackageState ...
- module Packages where
+ module Packages where
import DynFlags
data PackageState = PS ...
lookupModule (df :: DynFlags)
Now, lookupModule depends on DynFlags, but the transitive dependency
on the *locally-defined* type PackageState is not visible. We need
to take account of the use of the data constructor PS in the pattern match.
+
module IfaceType (
IfExtName, IfLclName,
- IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
+ IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), IfaceCoCon(..),
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
ifaceTyConName,
-- Conversion from Type -> IfaceType
- toIfaceType, toIfacePred, toIfaceContext,
+ toIfaceType, toIfaceContext,
toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs,
toIfaceTyCon, toIfaceTyCon_name,
+ -- Conversion from Coercion -> IfaceType
+ coToIfaceType,
+
-- Printing
pprIfaceType, pprParendIfaceType, pprIfaceContext,
pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs,
) where
-import TypeRep
+import Coercion
+import TypeRep hiding( maybeParen )
import TyCon
import Id
import Var
import TysWiredIn
+import TysPrim
import Name
import BasicTypes
import Outputable
type IfaceKind = IfaceType
type IfaceCoercion = IfaceType
-data IfaceType
- = IfaceTyVar IfLclName -- Type variable only, not tycon
+data IfaceType -- A kind of universal type, used for types, kinds, and coercions
+ = IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
| IfaceAppTy IfaceType IfaceType
+ | IfaceFunTy IfaceType IfaceType
| IfaceForAllTy IfaceTvBndr IfaceType
| IfacePredTy IfacePredType
- | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated
- -- Includes newtypes, synonyms, tuples
- | IfaceFunTy IfaceType IfaceType
+ | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated
+ -- Includes newtypes, synonyms, tuples
+ | IfaceCoConApp IfaceCoCon [IfaceType] -- Always saturated
data IfacePredType -- NewTypes are handled as ordinary TyConApps
= IfaceClassP IfExtName [IfaceType]
type IfaceContext = [IfacePredType]
-data IfaceTyCon -- Abbreviations for common tycons with known names
+data IfaceTyCon -- Encodes type consructors, kind constructors
+ -- coercion constructors, the lot
= IfaceTc IfExtName -- The common case
| IfaceIntTc | IfaceBoolTc | IfaceCharTc
| IfaceListTc | IfacePArrTc
| IfaceTupTc Boxity Arity
| IfaceAnyTc IfaceKind -- Used for AnyTyCon (see Note [Any Types] in TysPrim)
-- other than 'Any :: *' itself
+
+ -- Kind constructors
| IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
| IfaceUbxTupleKindTc | IfaceArgTypeKindTc
-ifaceTyConName :: IfaceTyCon -> IfExtName
-ifaceTyConName IfaceIntTc = intTyConName
+ -- Coercion constructors
+data IfaceCoCon
+ = IfaceCoAx IfExtName
+ | IfaceReflCo | IfaceUnsafeCo | IfaceSymCo
+ | IfaceTransCo | IfaceInstCo
+ | IfaceNthCo Int
+
+ifaceTyConName :: IfaceTyCon -> Name
+ifaceTyConName IfaceIntTc = intTyConName
ifaceTyConName IfaceBoolTc = boolTyConName
ifaceTyConName IfaceCharTc = charTyConName
ifaceTyConName IfaceListTc = listTyConName
ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
ppr_ty _ (IfacePredTy st) = ppr st
+ppr_ty ctxt_prec (IfaceCoConApp tc tys)
+ = maybeParen ctxt_prec tYCON_PREC
+ (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))])
+
-- Function types
ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
= -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
-- so we fake it. It's only for debug printing!
ppr other_tc = ppr (ifaceTyConName other_tc)
+instance Outputable IfaceCoCon where
+ ppr (IfaceCoAx n) = ppr n
+ ppr IfaceReflCo = ptext (sLit "Refl")
+ ppr IfaceUnsafeCo = ptext (sLit "Unsafe")
+ ppr IfaceSymCo = ptext (sLit "Sym")
+ ppr IfaceTransCo = ptext (sLit "Trans")
+ ppr IfaceInstCo = ptext (sLit "Inst")
+ ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d
+
-------------------
pprIfaceContext :: IfaceContext -> SDoc
-- Prints "(C a, D b) =>", including the arrow
---------------------
toIfaceType :: Type -> IfaceType
-- Synonyms are retained in the interface type
-toIfaceType (TyVarTy tv) =
- IfaceTyVar (occNameFS (getOccName tv))
-toIfaceType (AppTy t1 t2) =
- IfaceAppTy (toIfaceType t1) (toIfaceType t2)
-toIfaceType (FunTy t1 t2) =
- IfaceFunTy (toIfaceType t1) (toIfaceType t2)
-toIfaceType (TyConApp tc tys) =
- IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys)
-toIfaceType (ForAllTy tv t) =
- IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
-toIfaceType (PredTy st) =
- IfacePredTy (toIfacePred st)
+toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyCoVar tv)
+toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2)
+toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2)
+toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys)
+toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
+toIfaceType (PredTy st) = IfacePredTy (toIfacePred toIfaceType st)
+
+toIfaceTyCoVar :: TyCoVar -> FastString
+toIfaceTyCoVar = occNameFS . getOccName
----------------
-- A little bit of (perhaps optional) trickiness here. When
toIfaceTypes ts = map toIfaceType ts
----------------
-toIfacePred :: PredType -> IfacePredType
-toIfacePred (ClassP cls ts) =
- IfaceClassP (getName cls) (toIfaceTypes ts)
-toIfacePred (IParam ip t) =
- IfaceIParam (mapIPName getOccName ip) (toIfaceType t)
-toIfacePred (EqPred ty1 ty2) =
- IfaceEqPred (toIfaceType ty1) (toIfaceType ty2)
+toIfacePred :: (a -> IfaceType) -> Pred a -> IfacePredType
+toIfacePred to (ClassP cls ts) = IfaceClassP (getName cls) (map to ts)
+toIfacePred to (IParam ip t) = IfaceIParam (mapIPName getOccName ip) (to t)
+toIfacePred to (EqPred ty1 ty2) = IfaceEqPred (to ty1) (to ty2)
----------------
toIfaceContext :: ThetaType -> IfaceContext
-toIfaceContext cs = map toIfacePred cs
+toIfaceContext cs = map (toIfacePred toIfaceType) cs
+
+----------------
+coToIfaceType :: Coercion -> IfaceType
+coToIfaceType (Refl ty) = IfaceCoConApp IfaceReflCo [toIfaceType ty]
+coToIfaceType (TyConAppCo tc cos) = IfaceTyConApp (toIfaceTyCon tc)
+ (map coToIfaceType cos)
+coToIfaceType (AppCo co1 co2) = IfaceAppTy (coToIfaceType co1)
+ (coToIfaceType co2)
+coToIfaceType (ForAllCo v co) = IfaceForAllTy (toIfaceTvBndr v)
+ (coToIfaceType co)
+coToIfaceType (CoVarCo cv) = IfaceTyVar (toIfaceTyCoVar cv)
+coToIfaceType (AxiomInstCo con cos) = IfaceCoConApp (IfaceCoAx (coAxiomName con))
+ (map coToIfaceType cos)
+coToIfaceType (UnsafeCo ty1 ty2) = IfaceCoConApp IfaceUnsafeCo
+ [ toIfaceType ty1
+ , toIfaceType ty2 ]
+coToIfaceType (SymCo co) = IfaceCoConApp IfaceSymCo
+ [ coToIfaceType co ]
+coToIfaceType (TransCo co1 co2) = IfaceCoConApp IfaceTransCo
+ [ coToIfaceType co1
+ , coToIfaceType co2 ]
+coToIfaceType (NthCo d co) = IfaceCoConApp (IfaceNthCo d)
+ [ coToIfaceType co ]
+coToIfaceType (InstCo co ty) = IfaceCoConApp IfaceInstCo
+ [ coToIfaceType co
+ , toIfaceType ty ]
\end{code}
import CoreSyn
import CoreFVs
import Class
+import Kind
import TyCon
import DataCon
import Type
-import Coercion
import TcType
import InstEnv
import FamInstEnv
finsts_mod = mi_finsts iface
hash_env = mi_hash_fn iface
mod_hash = mi_mod_hash iface
- export_hash | depend_on_exports mod = Just (mi_exp_hash iface)
- | otherwise = Nothing
+ export_hash | depend_on_exports = Just (mi_exp_hash iface)
+ | otherwise = Nothing
used_occs = lookupModuleEnv ent_map mod `orElse` []
Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
Just r -> r
- depend_on_exports mod =
- case lookupModuleEnv direct_imports mod of
- Just _ -> True
- -- Even if we used 'import M ()', we have to register a
- -- usage on the export list because we are sensitive to
- -- changes in orphan instances/rules.
- Nothing -> False
- -- In GHC 6.8.x the above line read "True", and in
- -- fact it recorded a dependency on *all* the
- -- modules underneath in the dependency tree. This
- -- happens to make orphans work right, but is too
- -- expensive: it'll read too many interface files.
- -- The 'isNothing maybe_iface' check above saved us
- -- from generating many of these usages (at least in
- -- one-shot mode), but that's even more bogus!
+ depend_on_exports = is_direct_import
+ {- True
+ Even if we used 'import M ()', we have to register a
+ usage on the export list because we are sensitive to
+ changes in orphan instances/rules.
+ False
+ In GHC 6.8.x we always returned true, and in
+ fact it recorded a dependency on *all* the
+ modules underneath in the dependency tree. This
+ happens to make orphans work right, but is too
+ expensive: it'll read too many interface files.
+ The 'isNothing maybe_iface' check above saved us
+ from generating many of these usages (at least in
+ one-shot mode), but that's even more bogus!
+ -}
\end{code}
\begin{code}
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty
- toDmSpec NoDefMeth = NoDM
- toDmSpec GenDefMeth = GenericDM
- toDmSpec (DefMeth _) = VanillaDM
+ toDmSpec NoDefMeth = NoDM
+ toDmSpec (GenDefMeth _) = GenericDM
+ toDmSpec (DefMeth _) = VanillaDM
toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
- ifGeneric = tyConHasGenerics tycon,
ifFamInst = famInstToIface (tyConFamInst_maybe tycon)}
| isForeignTyCon tycon
= IfCon { ifConOcc = getOccName (dataConName data_con),
ifConInfix = dataConIsInfix data_con,
ifConWrapper = isJust (dataConWrapId_maybe data_con),
- ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
- ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con),
- ifConEqSpec = to_eq_spec (dataConEqSpec data_con),
- ifConCtxt = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
- ifConArgTys = map toIfaceType (dataConOrigArgTys data_con),
+ ifConUnivTvs = toIfaceTvBndrs univ_tvs,
+ ifConExTvs = toIfaceTvBndrs ex_tvs,
+ ifConEqSpec = to_eq_spec eq_spec,
+ ifConCtxt = toIfaceContext theta,
+ ifConArgTys = map toIfaceType arg_tys,
ifConFields = map getOccName
(dataConFieldLabels data_con),
ifConStricts = dataConStrictMarks data_con }
+ where
+ (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
famInstToIface (Just (famTyCon, instTys)) =
Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
+tyThingToIfaceDecl c@(ACoAxiom _) = pprPanic "tyThingToIfaceDecl (ACoCon _)" (ppr c)
+
tyThingToIfaceDecl (ADataCon dc)
= pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
-- construct the same ru_rough field as we have right now;
-- see tcIfaceRule
do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
+ do_arg (Coercion co) = IfaceType (coToIfaceType co)
+
do_arg arg = toIfaceExpr arg
-- Compute orphanhood. See Note [Orphans] in IfaceSyn
---------------------
toIfaceExpr :: CoreExpr -> IfaceExpr
-toIfaceExpr (Var v) = toIfaceVar v
-toIfaceExpr (Lit l) = IfaceLit l
-toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
-toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
-toIfaceExpr (App f a) = toIfaceApp f [a]
-toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as)
-toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
-toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceType co)
-toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e)
+toIfaceExpr (Var v) = toIfaceVar v
+toIfaceExpr (Lit l) = IfaceLit l
+toIfaceExpr (Type ty) = IfaceType (toIfaceType ty)
+toIfaceExpr (Coercion co) = IfaceCo (coToIfaceType co)
+toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
+toIfaceExpr (App f a) = toIfaceApp f [a]
+toIfaceExpr (Case s x _ as) = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
+toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e)
+toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (coToIfaceType co)
+toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e)
---------------------
toIfaceNote :: Note -> IfaceNote
import TcRnMonad
import TcType
import Type
+import Coercion
import TypeRep
import HscTypes
import Annotations
import DataCon
import TysWiredIn
import TysPrim ( anyTyConOfKind )
-import Var ( Var, TyVar )
import BasicTypes ( Arity, nonRuleLoopBreaker )
import qualified Var
import VarEnv
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec,
- ifGeneric = want_generic,
ifFamInst = mb_family })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; mb_fam_inst <- tcFamInst mb_family
; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
- want_generic gadt_syn parent mb_fam_inst
+ gadt_syn parent mb_fam_inst
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') }
tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
-tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') }
+tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePred tcIfaceType st; return (PredTy st') }
+tcIfaceType t@(IfaceCoConApp {}) = pprPanic "tcIfaceType" (ppr t)
tcIfaceTypes :: [IfaceType] -> IfL [Type]
tcIfaceTypes tys = mapM tcIfaceType tys
-----------------------------------------
-tcIfacePredType :: IfacePredType -> IfL PredType
-tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
-tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
-tcIfacePredType (IfaceEqPred t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') }
+tcIfacePred :: (IfaceType -> IfL a) -> IfacePredType -> IfL (Pred a)
+tcIfacePred tc (IfaceClassP cls ts)
+ = do { cls' <- tcIfaceClass cls; ts' <- mapM tc ts; return (ClassP cls' ts') }
+tcIfacePred tc (IfaceIParam ip t)
+ = do { ip' <- newIPName ip; t' <- tc t; return (IParam ip' t') }
+tcIfacePred tc (IfaceEqPred t1 t2)
+ = do { t1' <- tc t1; t2' <- tc t2; return (EqPred t1' t2') }
-----------------------------------------
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
-tcIfaceCtxt sts = mapM tcIfacePredType sts
+tcIfaceCtxt sts = mapM (tcIfacePred tcIfaceType) sts
+\end{code}
+
+%************************************************************************
+%* *
+ Coercions
+%* *
+%************************************************************************
+
+\begin{code}
+tcIfaceCo :: IfaceType -> IfL Coercion
+tcIfaceCo (IfaceTyVar n) = mkCoVarCo <$> tcIfaceCoVar n
+tcIfaceCo (IfaceAppTy t1 t2) = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCo (IfaceFunTy t1 t2) = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts
+tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts
+tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' ->
+ mkForAllCo tv' <$> tcIfaceCo t
+-- tcIfaceCo (IfacePredTy co) = mkPredCo <$> tcIfacePred tcIfaceCo co
+tcIfaceCo (IfacePredTy _) = panic "tcIfaceCo"
+
+tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion
+tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t
+tcIfaceCoApp (IfaceCoAx n) ts = AxiomInstCo <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts
+tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2
+tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t
+tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2
+tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t
+tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts)
+
+tcIfaceCoVar :: FastString -> IfL CoVar
+tcIfaceCoVar = tcIfaceLclId
\end{code}
tcIfaceExpr (IfaceType ty)
= Type <$> tcIfaceType ty
+tcIfaceExpr (IfaceCo co)
+ = Coercion <$> tcIfaceCo co
+
+tcIfaceExpr (IfaceCast expr co)
+ = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
+
tcIfaceExpr (IfaceLcl name)
= Var <$> tcIfaceLclId name
tcIfaceExpr (IfaceApp fun arg)
= App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
-tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = do
+tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
scrut' <- tcIfaceExpr scrut
case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
let
extendIfaceIdEnv [case_bndr'] $ do
alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
- ty' <- tcIfaceType ty
- return (Case scrut' case_bndr' ty' alts')
+ return (Case scrut' case_bndr' (coreAltsType alts') alts')
tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
= do { name <- newIfaceName (mkVarOccFS fs)
(idName id) (idType id) info
; return (setIdInfo id id_info, rhs') }
-tcIfaceExpr (IfaceCast expr co) = do
- expr' <- tcIfaceExpr expr
- co' <- tcIfaceType co
- return (Cast expr' co')
-
tcIfaceExpr (IfaceNote note expr) = do
expr' <- tcIfaceExpr expr
case note of
tcIfaceDataAlt con inst_tys arg_strs rhs
= do { us <- newUniqueSupply
; let uniqs = uniqsFromSupply us
- ; let (ex_tvs, co_tvs, arg_ids)
+ ; let (ex_tvs, arg_ids)
= dataConRepFSInstPat arg_strs uniqs con inst_tys
- all_tvs = ex_tvs ++ co_tvs
- ; rhs' <- extendIfaceTyVarEnv all_tvs $
+ ; rhs' <- extendIfaceTyVarEnv ex_tvs $
extendIfaceIdEnv arg_ids $
tcIfaceExpr rhs
- ; return (DataAlt con, all_tvs ++ arg_ids, rhs') }
+ ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
\end{code}
tcIfaceClass name = do { thing <- tcIfaceGlobal name
; return (tyThingClass thing) }
+tcIfaceCoAxiom :: Name -> IfL CoAxiom
+tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
+ ; return (tyThingCoAxiom thing) }
+
tcIfaceDataCon :: Name -> IfL DataCon
tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
; case thing of
then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!"
else (pprLlvmData ([ldata'], ltypes), llvmUsed)
+
-- | We generate labels for info tables by converting them to the same label
-- as for the entry code but adding this string as a suffix.
iTableSuf :: String
iTableSuf = "_itable"
--- | Create an appropriate section declaration for subsection <n> of text
--- WARNING: This technique could fail as gas documentation says it only
--- supports up to 8192 subsections per section. Inspection of the source
--- code and some test programs seem to suggest it supports more than this
--- so we are hoping it does.
+-- | Create a specially crafted section declaration that encodes the order this
+-- section should be in the final object code.
+--
+-- The LlvmMangler.llvmFixupAsm pass over the assembly produced by LLVM uses
+-- this section declaration to do its processing.
mkLayoutSection :: Int -> LMSection
mkLayoutSection n
- -- On OSX we can't use the GNU Assembler, we must use the OSX assembler, which
- -- doesn't support subsections. So we post process the assembly code, this
- -- section specifier will be replaced with '.text' by the mangler.
- = Just (fsLit $ infoSection ++ show n
-#if darwin_TARGET_OS
- )
-#else
- ++ "#")
-#endif
+ = Just (fsLit $ infoSection ++ show n)
--- | The section we are putting info tables and their entry code into
+
+-- | The section we are putting info tables and their entry code into, should
+-- be unique since we process the assembly pattern matching this.
infoSection :: String
-#if darwin_TARGET_OS
-infoSection = "__STRIP,__me"
-#else
-infoSection = ".text; .text "
-#endif
+infoSection = "X98A__STRIP,__me"
+{-# OPTIONS -fno-warn-unused-binds #-}
-- -----------------------------------------------------------------------------
-- | GHC LLVM Mangler
--
-- This script processes the assembly produced by LLVM, rearranging the code
--- so that an info table appears before its corresponding function. We also
--- use it to fix up the stack alignment, which needs to be 16 byte aligned
--- but always ends up off by 4 bytes because GHC sets it to the 'wrong'
--- starting value in the RTS.
+-- so that an info table appears before its corresponding function.
--
--- We only need this for Mac OS X, other targets don't use it.
+-- On OSX we also use it to fix up the stack alignment, which needs to be 16
+-- byte aligned but always ends up off by word bytes because GHC sets it to
+-- the 'wrong' starting value in the RTS.
--
module LlvmMangler ( llvmFixupAsm ) where
+#include "HsVersions.h"
+
+import LlvmCodeGen.Ppr ( infoSection )
+
import Control.Exception
import qualified Data.ByteString.Char8 as B
import Data.Char
import System.IO
-- Magic Strings
-infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString
-infoSec = B.pack "\t.section\t__STRIP,__me"
+secStmt, infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString
+secStmt = B.pack "\t.section\t"
+infoSec = B.pack infoSection
newInfoSec = B.pack "\n\t.text"
newLine = B.pack "\n"
-spInst = B.pack ", %esp\n"
jmpInst = B.pack "\n\tjmp"
-infoLen, spFix, labelStart :: Int
-infoLen = B.length infoSec
-spFix = 4
-labelStart = B.length jmpInst + 1
+infoLen, labelStart, spFix :: Int
+infoLen = B.length infoSec
+labelStart = B.length jmpInst
+
+#if x86_64_TARGET_ARCH
+spInst = B.pack ", %rsp\n"
+spFix = 8
+#else
+spInst = B.pack ", %esp\n"
+spFix = 4
+#endif
-- Search Predicates
eolPred, dollarPred, commaPred :: Char -> Bool
{- |
Here we process the assembly file one function and data
- defenition at a time. When a function is encountered that
+ definition at a time. When a function is encountered that
should have a info table we store it in a map. Otherwise
we print it. When an info table is found we retrieve its
function from the map and print them both.
For all functions we fix up the stack alignment. We also
- fix up the section defenition for functions and info tables.
+ fix up the section definition for functions and info tables.
-}
fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO ()
fixTables r w m = do
f <- getFun r B.empty
if B.null f
then return ()
- else let fun = fixupStack f B.empty
- (a,b) = B.breakSubstring infoSec fun
- (x,c) = B.break eolPred b
- fun' = a `B.append` newInfoSec `B.append` c
- n = readInt $ B.drop infoLen x
- (bs, m') | B.null b = ([fun], m)
+ else let fun = fixupStack f B.empty
+ (a,b) = B.breakSubstring infoSec fun
+ (a',s) = B.breakEnd eolPred a
+ -- We search for the section header in two parts as it makes
+ -- us portable across OS types and LLVM version types since
+ -- section names are wrapped differently.
+ secHdr = secStmt `B.isPrefixOf` s
+ (x,c) = B.break eolPred b
+ fun' = a' `B.append` newInfoSec `B.append` c
+ n = readInt $ B.takeWhile isDigit $ B.drop infoLen x
+ (bs, m') | B.null b || not secHdr = ([fun], m)
| even n = ([], I.insert n fun' m)
| otherwise = case I.lookup (n+1) m of
Just xf' -> ([fun',xf'], m)
Mac OS X requires that the stack be 16 byte aligned when making a function
call (only really required though when making a call that will pass through
the dynamic linker). The alignment isn't correctly generated by LLVM as
- LLVM rightly assumes that the stack wil be aligned to 16n + 12 on entry
+ LLVM rightly assumes that the stack will be aligned to 16n + 12 on entry
(since the function call was 16 byte aligned and the return address should
have been pushed, so sub 4). GHC though since it always uses jumps keeps
the stack 16 byte aligned on both function calls and function entry.
We correct the alignment here.
-}
fixupStack :: B.ByteString -> B.ByteString -> B.ByteString
+
+#if !darwin_TARGET_OS
+fixupStack = const
+
+#else
fixupStack f f' | B.null f' =
let -- fixup sub op
(a, c) = B.breakSubstring spInst f
(a', n) = B.breakEnd dollarPred a
(n', x) = B.break commaPred n
num = B.pack $ show $ readInt n' + spFix
+ -- We need to avoid processing jumps to labels, they are of the form:
+ -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax..., jmpl *L...
+ targ = B.dropWhile ((==)'*') $ B.drop 1 $ B.dropWhile ((/=)'\t') $
+ B.drop labelStart c
in if B.null c
then f' `B.append` f
- -- We need to avoid processing jumps to labels, they are of the form:
- -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax...
- else if B.index c labelStart == 'L'
+ else if B.head targ == 'L'
then fixupStack b $ f' `B.append` a `B.append` l
else fixupStack b $ f' `B.append` a' `B.append` num `B.append`
x `B.append` l
+#endif
--- | read an int or error
+-- | Read an int or error
readInt :: B.ByteString -> Int
readInt str | B.all isDigit str = (read . B.unpack) str
- | otherwise = error $ "LLvmMangler Cannot read" ++ show str
- ++ "as it's not an Int"
+ | otherwise = error $ "LLvmMangler Cannot read " ++ show str
+ ++ " as it's not an Int"
errorsToGhcException :: [Located String] -> GhcException
errorsToGhcException errs =
let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ]
- in UsageError (showSDoc $ withPprStyle cmdlineParserStyle errors)
+ in UsageError (renderWithStyle errors cmdlineParserStyle)
#include "HsVersions.h"
-#ifndef OMIT_NATIVE_CODEGEN
-import AsmCodeGen ( nativeCodeGen )
-#endif
+import AsmCodeGen ( nativeCodeGen )
import LlvmCodeGen ( llvmCodeGen )
import UniqSupply ( mkSplitUniqSupply )
\begin{code}
outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO ()
-
-#ifndef OMIT_NATIVE_CODEGEN
-
outputAsm dflags filenm flat_absC
+ | cGhcWithNativeCodeGen == "YES"
= do ncg_uniqs <- mkSplitUniqSupply 'n'
{-# SCC "OutputAsm" #-} doOutput filenm $
- \f -> {-# SCC "NativeCodeGen" #-}
- nativeCodeGen dflags f ncg_uniqs flat_absC
- where
+ \f -> {-# SCC "NativeCodeGen" #-}
+ nativeCodeGen dflags f ncg_uniqs flat_absC
-#else /* OMIT_NATIVE_CODEGEN */
-
-outputAsm _ _ _
- = pprPanic "This compiler was built without a native code generator"
- (text "Use -fvia-C instead")
-
-#endif
+ | otherwise
+ = panic "This compiler was built without a native code generator"
\end{code}
#include "HsVersions.h"
import qualified GHC
--- import GHC ( ModSummary(..), GhcMonad )
import GhcMonad
import HsSyn ( ImportDecl(..) )
import DynFlags
import Exception
import ErrUtils
--- import MonadUtils ( liftIO )
import System.Directory
import System.FilePath
nextPhase SplitMangle = As
nextPhase As = SplitAs
nextPhase LlvmOpt = LlvmLlc
-#if darwin_TARGET_OS
nextPhase LlvmLlc = LlvmMangle
-#else
-nextPhase LlvmLlc = As
-#endif
nextPhase LlvmMangle = As
nextPhase SplitAs = MergeStub
nextPhase Ccpp = As
import FastString
import LlvmCodeGen ( llvmFixupAsm )
import MonadUtils
+import Platform
--- import Data.Either
import Exception
import Data.IORef ( readIORef )
--- import GHC.Exts ( Int(..) )
import System.Directory
import System.FilePath
import System.IO
-- exports main, i.e., we have good reason to believe that linking
-- will succeed.
-#ifdef GHCI
link LinkInMemory _ _ _
- = do -- Not Linking...(demand linker will do the job)
- return Succeeded
-#endif
+ = if cGhcWithInterpreter == "YES"
+ then -- Not Linking...(demand linker will do the job)
+ return Succeeded
+ else panicBadLink LinkInMemory
link NoLink _ _ _
= return Succeeded
link LinkDynLib dflags batch_attempt_linking hpt
= link' dflags batch_attempt_linking hpt
-#ifndef GHCI
--- warning suppression
-link other _ _ _ = panicBadLink other
-#endif
-
panicBadLink :: GhcLink -> a
panicBadLink other = panic ("link: GHC not built to link this way: " ++
show other)
src_opts <- io $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, warns)
<- io $ parseDynamicNoPackageFlags dflags0 src_opts
+ io $ checkProcessArgsResult unhandled_flags
unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns
-- the HsPp pass below will emit warnings
- io $ checkProcessArgsResult unhandled_flags
setDynFlags dflags2
(dflags1, unhandled_flags, warns)
<- io $ parseDynamicNoPackageFlags dflags src_opts
setDynFlags dflags1
- io $ handleFlagWarnings dflags1 warns
io $ checkProcessArgsResult unhandled_flags
+ io $ handleFlagWarnings dflags1 warns
return (Hsc sf, output_fn)
let include_paths = foldr (\ x xs -> "-I" : x : xs) []
(cmdline_include_paths ++ pkg_include_dirs)
- let md_c_flags = machdepCCOpts dflags
let gcc_extra_viac_flags = extraGccViaCFlags dflags
let pic_c_flags = picCCOpts dflags
let
more_hcc_opts =
-#if i386_TARGET_ARCH
-- on x86 the floating point regs have greater precision
-- than a double, which leads to unpredictable results.
-- By default, we turn this off with -ffloat-store unless
-- the user specified -fexcess-precision.
- (if dopt Opt_ExcessPrecision dflags
- then []
- else [ "-ffloat-store" ]) ++
-#endif
+ (if platformArch (targetPlatform dflags) == ArchX86 &&
+ not (dopt Opt_ExcessPrecision dflags)
+ then [ "-ffloat-store" ]
+ else []) ++
-- gcc's -fstrict-aliasing allows two accesses to memory
-- to be considered non-aliasing if they have different types.
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
- md_c_flags
- ++ pic_c_flags
+ pic_c_flags
-#if defined(mingw32_TARGET_OS)
-- Stub files generated for foreign exports references the runIO_closure
-- and runNonIO_closure symbols, which are defined in the base package.
-- These symbols are imported into the stub.c file via RtsAPI.h, and the
-- way we do the import depends on whether we're currently compiling
-- the base package or not.
- ++ (if thisPackage dflags == basePackageId
+ ++ (if platformOS (targetPlatform dflags) == OSMinGW32 &&
+ thisPackage dflags == basePackageId
then [ "-DCOMPILING_BASE_PACKAGE" ]
else [])
-#endif
-#ifdef sparc_TARGET_ARCH
-- We only support SparcV9 and better because V8 lacks an atomic CAS
-- instruction. Note that the user can still override this
-- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
-- regardless of the ordering.
--
-- This is a temporary hack.
- ++ ["-mcpu=v9"]
-#endif
+ ++ (if platformArch (targetPlatform dflags) == ArchSPARC
+ then ["-mcpu=v9"]
+ else [])
+
++ (if hcc
then gcc_extra_viac_flags ++ more_hcc_opts
else [])
-- might be a hierarchical module.
io $ createDirectoryHierarchy (takeDirectory output_fn)
- let md_c_flags = machdepCCOpts dflags
io $ SysTools.runAs dflags
(map SysTools.Option as_opts
++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
-#ifdef sparc_TARGET_ARCH
+
-- We only support SparcV9 and better because V8 lacks an atomic CAS
-- instruction so we have to make sure that the assembler accepts the
-- instruction set. Note that the user can still override this
-- regardless of the ordering.
--
-- This is a temporary hack.
- ++ [ SysTools.Option "-mcpu=v9" ]
-#endif
+ ++ (if platformArch (targetPlatform dflags) == ArchSPARC
+ then [SysTools.Option "-mcpu=v9"]
+ else [])
+
++ [ SysTools.Option "-c"
, SysTools.FileOption "" input_fn
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
- ]
- ++ map SysTools.Option md_c_flags)
+ ])
return (next_phase, output_fn)
split_obj n = split_odir </>
takeFileName base_o ++ "__" ++ show n <.> osuf
- let md_c_flags = machdepCCOpts dflags
let assemble_file n
= SysTools.runAs dflags
(map SysTools.Option as_opts ++
-#ifdef sparc_TARGET_ARCH
+
-- We only support SparcV9 and better because V8 lacks an atomic CAS
-- instruction so we have to make sure that the assembler accepts the
-- instruction set. Note that the user can still override this
-- regardless of the ordering.
--
-- This is a temporary hack.
- [ SysTools.Option "-mcpu=v9" ] ++
-#endif
+ (if platformArch (targetPlatform dflags) == ArchSPARC
+ then [SysTools.Option "-mcpu=v9"]
+ else []) ++
+
[ SysTools.Option "-c"
, SysTools.Option "-o"
, SysTools.FileOption "" (split_obj n)
, SysTools.FileOption "" (split_s n)
- ]
- ++ map SysTools.Option md_c_flags)
+ ])
io $ mapM_ assemble_file [1..n]
-- fix up some pretty big deficiencies in the code we generate
llvmOpts = ["-mem2reg", "-O1", "-O2"]
-
-----------------------------------------------------------------------------
-- LlvmLlc phase
runPhase LlvmLlc input_fn dflags
= do
let lc_opts = getOpts dflags opt_lc
- let opt_lvl = max 0 (min 2 $ optLevel dflags)
-#if darwin_TARGET_OS
- let nphase = LlvmMangle
-#else
- let nphase = As
-#endif
- let rmodel | opt_PIC = "pic"
+ opt_lvl = max 0 (min 2 $ optLevel dflags)
+ rmodel | opt_PIC = "pic"
| not opt_Static = "dynamic-no-pic"
| otherwise = "static"
- output_fn <- phaseOutputFilename nphase
+ output_fn <- phaseOutputFilename LlvmMangle
io $ SysTools.runLlvmLlc dflags
([ SysTools.Option (llvmOpts !! opt_lvl),
SysTools.Option "-o", SysTools.FileOption "" output_fn]
++ map SysTools.Option lc_opts)
- return (nphase, output_fn)
+ return (LlvmMangle, output_fn)
where
-#if darwin_TARGET_OS
- llvmOpts = ["-O1", "-O2", "-O2"]
-#else
- llvmOpts = ["-O1", "-O2", "-O3"]
-#endif
-
+ -- Bug in LLVM at O3 on OSX.
+ llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin
+ then ["-O1", "-O2", "-O2"]
+ else ["-O1", "-O2", "-O3"]
-----------------------------------------------------------------------------
-- LlvmMangle phase
oFile <- newTempName dflags "o"
writeFile cFile xs
let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
- md_c_flags = machdepCCOpts dflags
SysTools.runCc dflags
([Option "-c",
FileOption "" cFile,
Option "-o",
FileOption "" oFile] ++
- map (FileOption "-I") (includeDirs rtsDetails) ++
- map Option md_c_flags)
+ map (FileOption "-I") (includeDirs rtsDetails))
return oFile
mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath
rc_objs <- maybeCreateManifest dflags output_fn
- let md_c_flags = machdepCCOpts dflags
SysTools.runLink dflags (
map SysTools.Option verbFlags
++ [ SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
- md_c_flags
+ []
-#ifdef mingw32_TARGET_OS
-- Permit the linker to auto link _symbol to _imp_symbol.
-- This lets us link against DLLs without needing an "import library".
- ++ ["-Wl,--enable-auto-import"]
-#endif
+ ++ (if platformOS (targetPlatform dflags) == OSMinGW32
+ then ["-Wl,--enable-auto-import"]
+ else [])
+
++ o_files
++ extra_ld_inputs
++ lib_path_opts
exeFileName :: DynFlags -> FilePath
exeFileName dflags
| Just s <- outputFile dflags =
-#if defined(mingw32_HOST_OS)
- if null (takeExtension s)
- then s <.> "exe"
- else s
-#else
- s
-#endif
+ if platformOS (targetPlatform dflags) == OSMinGW32
+ then if null (takeExtension s)
+ then s <.> "exe"
+ else s
+ else s
| otherwise =
-#if defined(mingw32_HOST_OS)
- "main.exe"
-#else
- "a.out"
-#endif
+ if platformOS (targetPlatform dflags) == OSMinGW32
+ then "main.exe"
+ else "a.out"
maybeCreateManifest
:: DynFlags
-- probably _stub.o files
extra_ld_inputs <- readIORef v_Ld_inputs
- let md_c_flags = machdepCCOpts dflags
let extra_ld_opts = getOpts dflags opt_l
extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages
]
++ map (SysTools.FileOption "") o_files
++ map SysTools.Option (
- md_c_flags
-- Permit the linker to auto link _symbol to _imp_symbol
-- This lets us link against DLLs without needing an "import library"
- ++ ["-Wl,--enable-auto-import"]
+ ["-Wl,--enable-auto-import"]
++ extra_ld_inputs
++ lib_path_opts
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
- md_c_flags
- ++ o_files
+ o_files
++ [ "-undefined", "dynamic_lookup", "-single_module",
#if !defined(x86_64_TARGET_ARCH)
"-Wl,-read_only_relocs,suppress",
, SysTools.FileOption "" output_fn
]
++ map SysTools.Option (
- md_c_flags
- ++ o_files
+ o_files
++ [ "-shared" ]
++ bsymbolicFlag
-- Set the library soname. We use -h rather than -soname as
let verbFlags = getVerbFlags dflags
let cc_opts
- | not include_cc_opts = []
- | otherwise = (optc ++ md_c_flags)
- where
- optc = getOpts dflags opt_c
- md_c_flags = machdepCCOpts dflags
+ | include_cc_opts = getOpts dflags opt_c
+ | otherwise = []
let cpp_prog args | raw = SysTools.runCpp dflags args
| otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
SysTools.Option ld_x_flag,
SysTools.Option "-o",
SysTools.FileOption "" output_fn ]
- ++ map SysTools.Option md_c_flags
++ args)
ld_x_flag | null cLD_X = ""
ld_build_id | cLdHasBuildId == "YES" = "-Wl,--build-id=none"
| otherwise = ""
- md_c_flags = machdepCCOpts dflags
-
if cLdIsGNULd == "YES"
then do
script <- newTempName dflags "ldscript"
supportedLanguagesAndExtensions,
-- ** DynFlag C compiler options
- machdepCCOpts, picCCOpts,
+ picCCOpts,
-- * Configuration of the stg-to-stg passes
StgToDo(..),
#include "HsVersions.h"
-#ifndef OMIT_NATIVE_CODEGEN
import Platform
-#endif
import Module
import PackageConfig
import PrelNames ( mAIN )
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
--- import Data.Maybe
+import Data.Set (Set)
+import qualified Data.Set as Set
import System.FilePath
import System.IO ( stderr, hPutChar )
| Opt_D_dump_raw_cmm
| Opt_D_dump_cmmz
| Opt_D_dump_cmmz_pretty
+ -- All of the cmmz subflags (there are a lot!) Automatically
+ -- enabled if you run -ddump-cmmz
+ | Opt_D_dump_cmmz_cbe
+ | Opt_D_dump_cmmz_proc
+ | Opt_D_dump_cmmz_spills
+ | Opt_D_dump_cmmz_rewrite
+ | Opt_D_dump_cmmz_dead
+ | Opt_D_dump_cmmz_stub
+ | Opt_D_dump_cmmz_sp
+ | Opt_D_dump_cmmz_procmap
+ | Opt_D_dump_cmmz_split
+ | Opt_D_dump_cmmz_lower
+ | Opt_D_dump_cmmz_info
+ | Opt_D_dump_cmmz_cafs
+ -- end cmmz subflags
| Opt_D_dump_cps_cmm
| Opt_D_dump_cvt_cmm
| Opt_D_dump_asm
-- misc opts
| Opt_Pp
| Opt_ForceRecomp
- | Opt_DryRun
| Opt_ExcessPrecision
| Opt_EagerBlackHoling
| Opt_ReadUserPackageConf
| Opt_TemplateHaskell
| Opt_QuasiQuotes
| Opt_ImplicitParams
- | Opt_Generics -- "Derivable type classes"
| Opt_ImplicitPrelude
| Opt_ScopedTypeVariables
| Opt_UnboxedTuples
| Opt_DeriveFunctor
| Opt_DeriveTraversable
| Opt_DeriveFoldable
+ | Opt_DeriveGeneric -- Allow deriving Generic/1
+ | Opt_DefaultSignatures -- Allow extra signatures for defmeths
+ | Opt_Generics -- Old generic classes, now deprecated
| Opt_TypeSynonymInstances
| Opt_FlexibleContexts
| Opt_KindSignatures
| Opt_ParallelListComp
| Opt_TransformListComp
+ | Opt_MonadComprehensions
| Opt_GeneralizedNewtypeDeriving
| Opt_RecursiveDo
| Opt_DoRec
floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating
-- See CoreMonad.FloatOutSwitches
-#ifndef OMIT_NATIVE_CODEGEN
- targetPlatform :: Platform, -- ^ The platform we're compiling for. Used by the NCG.
-#endif
+ targetPlatform :: Platform.Platform, -- ^ The platform we're compiling for. Used by the NCG.
cmdlineHcIncludes :: [String], -- ^ @\-\#includes@
importPaths :: [FilePath],
mainModIs :: Module,
filesToClean :: IORef [FilePath],
dirsToClean :: IORef (Map FilePath FilePath),
+ -- Names of files which were generated from -ddump-to-file; used to
+ -- track which ones we need to truncate because it's our first run
+ -- through
+ generatedDumps :: IORef (Set FilePath),
+
-- hsc dynamic flags
flags :: [DynFlag],
-- Don't change this without updating extensionFlags:
| HscNothing -- ^ Don't generate any code. See notes above.
deriving (Eq, Show)
+showHscTargetFlag :: HscTarget -> String
+showHscTargetFlag HscC = "-fvia-c"
+showHscTargetFlag HscAsm = "-fasm"
+showHscTargetFlag HscLlvm = "-fllvm"
+showHscTargetFlag HscJava = panic "No flag for HscJava"
+showHscTargetFlag HscInterpreted = "-fbyte-code"
+showHscTargetFlag HscNothing = "-fno-code"
+
-- | Will this target result in an object file on the disk?
isObjectTarget :: HscTarget -> Bool
isObjectTarget HscC = True
-- object files on the current platform.
defaultObjectTarget :: HscTarget
defaultObjectTarget
+ | cGhcUnregisterised == "YES" = HscC
| cGhcWithNativeCodeGen == "YES" = HscAsm
- | otherwise = HscC
+ | otherwise = HscLlvm
data DynLibLoader
= Deployable
ways <- readIORef v_Ways
refFilesToClean <- newIORef []
refDirsToClean <- newIORef Map.empty
+ refGeneratedDumps <- newIORef Set.empty
return dflags{
ways = ways,
buildTag = mkBuildTag (filter (not . wayRTSOnly) ways),
rtsBuildTag = mkBuildTag ways,
filesToClean = refFilesToClean,
- dirsToClean = refDirsToClean
+ dirsToClean = refDirsToClean,
+ generatedDumps = refGeneratedDumps
}
-- | The normal 'DynFlags'. Note that they is not suitable for use in this form
maxSimplIterations = 4,
shouldDumpSimplPhase = Nothing,
ruleCheck = Nothing,
- specConstrThreshold = Just 200,
+ specConstrThreshold = Just 2000,
specConstrCount = Just 3,
- liberateCaseThreshold = Just 200,
+ liberateCaseThreshold = Just 2000,
floatLamArgs = Just 0, -- Default: float only if no fvs
strictnessBefore = [],
-#ifndef OMIT_NATIVE_CODEGEN
targetPlatform = defaultTargetPlatform,
-#endif
cmdlineHcIncludes = [],
importPaths = ["."],
mainModIs = mAIN,
-- end of ghc -M values
filesToClean = panic "defaultDynFlags: No filesToClean",
dirsToClean = panic "defaultDynFlags: No dirsToClean",
+ generatedDumps = panic "defaultDynFlags: No generatedDumps",
haddockOptions = Nothing,
flags = defaultFlags,
language = Nothing,
log_action = \severity srcSpan style msg ->
case severity of
- SevOutput -> printOutput (msg style)
- SevInfo -> printErrs (msg style)
- SevFatal -> printErrs (msg style)
+ SevOutput -> printSDoc msg style
+ SevInfo -> printErrs msg style
+ SevFatal -> printErrs msg style
_ -> do
hPutChar stderr '\n'
- printErrs ((mkLocMessage srcSpan msg) style)
+ printErrs (mkLocMessage srcSpan msg) style
-- careful (#2302): printErrs prints in UTF-8, whereas
-- converting to string first and using hPutStr would
-- just emit the low 8 bits of each unicode char.
-- But NB it's implied by GADTs etc
-- SLPJ September 2010
: Opt_NondecreasingIndentation -- This has been on by default for some time
- : languageExtensions (Just Haskell2010)
+ : delete Opt_DatatypeContexts -- The Haskell' committee decided to
+ -- remove datatype contexts from the
+ -- language:
+ -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html
+ (languageExtensions (Just Haskell2010))
languageExtensions (Just Haskell98)
= [Opt_ImplicitPrelude,
= runCmdLine (processArgs flag_spec args') dflags0
when (not (null errs)) $ ghcError $ errorsToGhcException errs
- let (pic_warns, dflags2)
-#if !(x86_64_TARGET_ARCH && linux_TARGET_OS)
- | (not opt_Static || opt_PIC) && hscTarget dflags1 == HscLlvm
- = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and -"
- ++ "dynamic on this platform;\n ignoring -fllvm"],
- dflags1{ hscTarget = HscAsm })
-#endif
- | otherwise = ([], dflags1)
-
- return (dflags2, leftover, pic_warns ++ warns)
+ return (dflags1, leftover, warns)
{- **********************************************************************
--------------- The main flags themselves ------------------
dynamic_flags :: [Flag (CmdLineP DynFlags)]
dynamic_flags = [
- Flag "n" (NoArg (setDynFlag Opt_DryRun))
+ Flag "n" (NoArg (addWarn "The -n flag is deprecated and no longer has any effect"))
, Flag "cpp" (NoArg (setExtensionFlag Opt_Cpp))
, Flag "F" (NoArg (setDynFlag Opt_Pp))
, Flag "#include"
, Flag "dylib-install-name" (hasArg setDylibInstallName)
------- Libraries ---------------------------------------------------
- , Flag "L" (Prefix addLibraryPath)
- , Flag "l" (AnySuffix (upd . addOptl))
+ , Flag "L" (Prefix addLibraryPath)
+ , Flag "l" (hasArg (addOptl . ("-l" ++)))
------- Frameworks --------------------------------------------------
-- -framework-path should really be -F ...
, Flag "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm)
, Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz)
, Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty)
+ , Flag "ddump-cmmz-cbe" (setDumpFlag Opt_D_dump_cmmz_cbe)
+ , Flag "ddump-cmmz-spills" (setDumpFlag Opt_D_dump_cmmz_spills)
+ , Flag "ddump-cmmz-proc" (setDumpFlag Opt_D_dump_cmmz_proc)
+ , Flag "ddump-cmmz-rewrite" (setDumpFlag Opt_D_dump_cmmz_rewrite)
+ , Flag "ddump-cmmz-dead" (setDumpFlag Opt_D_dump_cmmz_dead)
+ , Flag "ddump-cmmz-stub" (setDumpFlag Opt_D_dump_cmmz_stub)
+ , Flag "ddump-cmmz-sp" (setDumpFlag Opt_D_dump_cmmz_sp)
+ , Flag "ddump-cmmz-procmap" (setDumpFlag Opt_D_dump_cmmz_procmap)
+ , Flag "ddump-cmmz-split" (setDumpFlag Opt_D_dump_cmmz_split)
+ , Flag "ddump-cmmz-lower" (setDumpFlag Opt_D_dump_cmmz_lower)
+ , Flag "ddump-cmmz-info" (setDumpFlag Opt_D_dump_cmmz_info)
+ , Flag "ddump-cmmz-cafs" (setDumpFlag Opt_D_dump_cmmz_cafs)
, Flag "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats)
, Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm)
, Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm)
, Flag "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts))
------ Optimisation flags ------------------------------------------
- , Flag "O" (noArg (setOptLevel 1))
- , Flag "Onot" (noArgDF (setOptLevel 0) "Use -O0 instead")
- , Flag "Odph" (noArg setDPHOpt)
- , Flag "O" (OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1))))
+ , Flag "O" (noArgM (setOptLevel 1))
+ , Flag "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead"
+ setOptLevel 0 dflags))
+ , Flag "Odph" (noArgM setDPHOpt)
+ , Flag "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1)))
-- If the number is missing, use 1
, Flag "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n }))
( "EmptyDataDecls", Opt_EmptyDataDecls, nop ),
( "ParallelListComp", Opt_ParallelListComp, nop ),
( "TransformListComp", Opt_TransformListComp, nop ),
+ ( "MonadComprehensions", Opt_MonadComprehensions, nop),
( "ForeignFunctionInterface", Opt_ForeignFunctionInterface, nop ),
( "UnliftedFFITypes", Opt_UnliftedFFITypes, nop ),
( "GHCForeignImportPrim", Opt_GHCForeignImportPrim, nop ),
( "RankNTypes", Opt_RankNTypes, nop ),
( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop),
( "TypeOperators", Opt_TypeOperators, nop ),
- ( "RecursiveDo", Opt_RecursiveDo,
+ ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo'
deprecatedForExtension "DoRec"),
- ( "DoRec", Opt_DoRec, nop ),
+ ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword
( "Arrows", Opt_Arrows, nop ),
( "ModalTypes", Opt_ModalTypes, nop ),
( "ParallelArrays", Opt_ParallelArrays, nop ),
( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ),
( "QuasiQuotes", Opt_QuasiQuotes, nop ),
- ( "Generics", Opt_Generics, nop ),
+ ( "Generics", Opt_Generics,
+ \ _ -> deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support." ),
( "ImplicitPrelude", Opt_ImplicitPrelude, nop ),
( "RecordWildCards", Opt_RecordWildCards, nop ),
( "NamedFieldPuns", Opt_RecordPuns, nop ),
( "DeriveFunctor", Opt_DeriveFunctor, nop ),
( "DeriveTraversable", Opt_DeriveTraversable, nop ),
( "DeriveFoldable", Opt_DeriveFoldable, nop ),
+ ( "DeriveGeneric", Opt_DeriveGeneric, nop ),
+ ( "DefaultSignatures", Opt_DefaultSignatures, nop ),
( "TypeSynonymInstances", Opt_TypeSynonymInstances, nop ),
( "FlexibleContexts", Opt_FlexibleContexts, nop ),
( "FlexibleInstances", Opt_FlexibleInstances, nop ),
, Opt_DeriveFunctor
, Opt_DeriveFoldable
, Opt_DeriveTraversable
+ , Opt_DeriveGeneric
, Opt_FlexibleContexts
, Opt_FlexibleInstances
, Opt_ConstrainedClassMethods
type DynP = EwM (CmdLineP DynFlags)
upd :: (DynFlags -> DynFlags) -> DynP ()
-upd f = liftEwM (do { dfs <- getCmdLineState
- ; putCmdLineState $! (f dfs) })
+upd f = liftEwM (do dflags <- getCmdLineState
+ putCmdLineState $! f dflags)
+
+updM :: (DynFlags -> DynP DynFlags) -> DynP ()
+updM f = do dflags <- liftEwM getCmdLineState
+ dflags' <- f dflags
+ liftEwM $ putCmdLineState $! dflags'
--------------- Constructor functions for OptKind -----------------
noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
noArg fn = NoArg (upd fn)
+noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)
+noArgM fn = NoArg (updM fn)
+
noArgDF :: (DynFlags -> DynFlags) -> String -> OptKind (CmdLineP DynFlags)
noArgDF fn deprec = NoArg (upd fn >> deprecate deprec)
intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
intSuffix fn = IntSuffix (\n -> upd (fn n))
+optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags)
+ -> OptKind (CmdLineP DynFlags)
+optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi))
+
setDumpFlag :: DynFlag -> OptKind (CmdLineP DynFlags)
setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)
-- recompiled which probably isn't what you want
forceRecompile = do { dfs <- liftEwM getCmdLineState
; when (force_recomp dfs) (setDynFlag Opt_ForceRecomp) }
- where
+ where
force_recomp dfs = isOneShot (ghcMode dfs)
setVerboseCore2Core :: DynP ()
setVerboseCore2Core = do forceRecompile
setDynFlag Opt_D_verbose_core2core
upd (\dfs -> dfs { shouldDumpSimplPhase = Nothing })
-
setDumpSimplPhases :: String -> DynP ()
setDumpSimplPhases s = do forceRecompile
-- not from bytecode to object-code. The idea is that -fasm/-fllvm
-- can be safely used in an OPTIONS_GHC pragma.
setObjTarget :: HscTarget -> DynP ()
-setObjTarget l = upd set
+setObjTarget l = updM set
where
- set dfs
- | isObjectTarget (hscTarget dfs) = dfs { hscTarget = l }
- | otherwise = dfs
-
-setOptLevel :: Int -> DynFlags -> DynFlags
+ set dflags
+ | isObjectTarget (hscTarget dflags)
+ = case l of
+ HscC
+ | cGhcUnregisterised /= "YES" ->
+ do addWarn ("Compiler not unregisterised, so ignoring " ++ flag)
+ return dflags
+ HscAsm
+ | cGhcWithNativeCodeGen /= "YES" ->
+ do addWarn ("Compiler has no native codegen, so ignoring " ++
+ flag)
+ return dflags
+ HscLlvm
+ | cGhcUnregisterised == "YES" ->
+ do addWarn ("Compiler unregisterised, so ignoring " ++ flag)
+ return dflags
+ | not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin)) &&
+ (not opt_Static || opt_PIC)
+ ->
+ do addWarn ("Ignoring " ++ flag ++ " as it is incompatible with -fPIC and -dynamic on this platform")
+ return dflags
+ _ -> return $ dflags { hscTarget = l }
+ | otherwise = return dflags
+ where platform = targetPlatform dflags
+ arch = platformArch platform
+ os = platformOS platform
+ flag = showHscTargetFlag l
+
+setOptLevel :: Int -> DynFlags -> DynP DynFlags
setOptLevel n dflags
| hscTarget dflags == HscInterpreted && n > 0
- = dflags
- -- not in IO any more, oh well:
- -- putStr "warning: -O conflicts with --interactive; -O ignored.\n"
+ = do addWarn "-O conflicts with --interactive; -O ignored."
+ return dflags
| otherwise
- = updOptLevel n dflags
+ = return (updOptLevel n dflags)
-- -Odph is equivalent to
-- -fmax-simplifier-iterations20 this is necessary sometimes
-- -fsimplifier-phases=3 we use an additional simplifier phase for fusion
--
-setDPHOpt :: DynFlags -> DynFlags
+setDPHOpt :: DynFlags -> DynP DynFlags
setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20
, simplPhases = 3
})
addImportPath "" = upd (\s -> s{importPaths = []})
addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})
-
addLibraryPath p =
upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})
-- The options below are not dependent on the version of gcc, only the
-- platform.
-machdepCCOpts :: DynFlags -> [String] -- flags for all C compilations
-machdepCCOpts _ = cCcOpts ++ machdepCCOpts'
-
-machdepCCOpts' :: [String] -- flags for all C compilations
-machdepCCOpts'
-#if alpha_TARGET_ARCH
- = ["-w", "-mieee"
-#ifdef HAVE_THREADED_RTS_SUPPORT
- , "-D_REENTRANT"
-#endif
- ]
- -- For now, to suppress the gcc warning "call-clobbered
- -- register used for global register variable", we simply
- -- disable all warnings altogether using the -w flag. Oh well.
-
-#elif hppa_TARGET_ARCH
- -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
- -- (very nice, but too bad the HP /usr/include files don't agree.)
- = ["-D_HPUX_SOURCE"]
-
-#elif i386_TARGET_ARCH
- -- -fno-defer-pop : basically the same game as for m68k
- --
- -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
- -- the fp (%ebp) for our register maps.
- = if opt_Static then ["-DDONT_WANT_WIN32_DLL_SUPPORT"] else []
-
-#else
- = []
-#endif
-
picCCOpts :: DynFlags -> [String]
picCCOpts _dflags
#if darwin_TARGET_OS
("Debug on", show debugIsOn),
("LibDir", topDir dflags),
("Global Package DB", systemPackageConfig dflags),
- ("C compiler flags", show cCcOpts),
("Gcc Linker flags", show cGccLinkerOpts),
("Ld Linker flags", show cLdLinkerOpts)
]
import System.Exit ( ExitCode(..), exitWith )
import Data.List
+import qualified Data.Set as Set
+import Data.IORef
+import Control.Monad
import System.IO
-- -----------------------------------------------------------------------------
-- would look strange. Better to say explicitly "<no location info>".
printError :: SrcSpan -> Message -> IO ()
-printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle)
+printError span msg =
+ printErrs (mkLocMessage span msg) defaultErrStyle
-- -----------------------------------------------------------------------------
-- otherwise emit to stdout.
dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpSDoc dflags dflag hdr doc
- = do let mFile = chooseDumpFile dflags dflag
- case mFile of
- -- write the dump to a file
- -- don't add the header in this case, we can see what kind
- -- of dump it is from the filename.
- Just fileName
- -> do handle <- openFile fileName AppendMode
- hPrintDump handle doc
- hClose handle
-
- -- write the dump to stdout
- Nothing
- -> do printDump (mkDumpDoc hdr doc)
+ = do let mFile = chooseDumpFile dflags dflag
+ case mFile of
+ -- write the dump to a file
+ -- don't add the header in this case, we can see what kind
+ -- of dump it is from the filename.
+ Just fileName
+ -> do
+ let gdref = generatedDumps dflags
+ gd <- readIORef gdref
+ let append = Set.member fileName gd
+ mode = if append then AppendMode else WriteMode
+ when (not append) $
+ writeIORef gdref (Set.insert fileName gd)
+ handle <- openFile fileName mode
+ hPrintDump handle doc
+ hClose handle
+
+ -- write the dump to stdout
+ Nothing
+ -> printDump (mkDumpDoc hdr doc)
-- | Choose where to put a dump file based on DynFlags
pprParendType, pprTypeApp,
Kind,
PredType,
- ThetaType, pprForAll, pprThetaArrow,
+ ThetaType, pprForAll, pprThetaArrow, pprThetaArrowTy,
-- ** Entities
TyThing(..),
import Coercion ( synTyConResKind )
import TcType hiding( typeKind )
import Id
-import Var
import TysPrim ( alphaTyVars )
import TyCon
import Class
-> Ghc a -- ^ The action to perform.
-> IO a
runGhc mb_top_dir ghc = do
- ref <- newIORef undefined
+ ref <- newIORef (panic "empty session")
let session = Session ref
flip unGhc session $ do
initGhcMonad mb_top_dir
-> GhcT m a -- ^ The action to perform.
-> m a
runGhcT mb_top_dir ghct = do
- ref <- liftIO $ newIORef undefined
+ ref <- liftIO $ newIORef (panic "empty session")
let session = Session ref
flip unGhcT session $ do
initGhcMonad mb_top_dir
preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
= do
let dflags = hsc_dflags hsc_env
- -- case we bypass the preprocessing stage?
- let
- local_opts = getOptions dflags buf src_fn
- --
+ let local_opts = getOptions dflags buf src_fn
+
(dflags', leftovers, warns)
<- parseDynamicNoPackageFlags dflags local_opts
checkProcessArgsResult leftovers
handleFlagWarnings dflags' warns
- let
- needs_preprocessing
+ let needs_preprocessing
| Just (Unlit _) <- mb_phase = True
| Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
-- note: local_opts is only required if there's no Unlit phase
reflectGhc, reifyGhc,
getSessionDynFlags,
liftIO,
- Session(..), withSession, modifySession, withTempSession,
+ Session(..), withSession, modifySession, withTempSession,
-- ** Warnings
logWarnings, printException, printExceptionAndWarnings,
- WarnErrLogger, defaultWarnErrLogger
+ WarnErrLogger, defaultWarnErrLogger
) where
import MonadUtils
hscTcExpr hsc_env expr = runHsc hsc_env $ do
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
- Just (L _ (ExprStmt expr _ _)) ->
- ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
- _ ->
- liftIO $ throwIO $ mkSrcErr $ unitBag $
- mkPlainErrMsg noSrcSpan
- (text "not an expression:" <+> quotes (text expr))
+ Just (L _ (ExprStmt expr _ _ _)) ->
+ ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
+ _ ->
+ liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg noSrcSpan
+ (text "not an expression:" <+> quotes (text expr))
-- | Find the kind of a type
hscKcType
("InstType ", inst_type_ds),
("InstData ", inst_data_ds),
("TypeSigs ", bind_tys),
+ ("GenericSigs ", generic_sigs),
("ValBinds ", val_bind_ds),
("FunBinds ", fn_bind_ds),
("InlineMeths ", method_inlines),
trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls)
- (fixity_sigs, bind_tys, bind_specs, bind_inlines)
+ (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs)
= count_sigs [d | SigD d <- decls]
-- NB: this omits fixity decls on local bindings and
-- in class decls. ToDo
count_bind (FunBind {}) = (0,1)
count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)
- count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
+ count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs)
- sig_info (FixSig _) = (1,0,0,0)
- sig_info (TypeSig _ _) = (0,1,0,0)
- sig_info (SpecSig _ _ _) = (0,0,1,0)
- sig_info (InlineSig _ _) = (0,0,0,1)
- sig_info _ = (0,0,0,0)
+ sig_info (FixSig _) = (1,0,0,0,0)
+ sig_info (TypeSig _ _) = (0,1,0,0,0)
+ sig_info (SpecSig _ _ _) = (0,0,1,0,0)
+ sig_info (InlineSig _ _) = (0,0,0,1,0)
+ sig_info (GenericSig _ _) = (0,0,0,0,1)
+ sig_info _ = (0,0,0,0,0)
import_info (L _ (ImportDecl _ _ _ qual as spec))
= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
class_info decl@(ClassDecl {})
= case count_sigs (map unLoc (tcdSigs decl)) of
- (_,classops,_,_) ->
+ (_,classops,_,_,_) ->
(classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl)))))
class_info _ = (0,0)
inst_info (InstDecl _ inst_meths inst_sigs ats)
= case count_sigs (map unLoc inst_sigs) of
- (_,_,ss,is) ->
+ (_,_,ss,is,_) ->
case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of
(tyDecl, dtDecl) ->
(addpr (foldr add2 (0,0)
addpr :: (Int,Int) -> Int
add2 :: (Int,Int) -> (Int,Int) -> (Int, Int)
- add4 :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int)
add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int)
add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int)
addpr (x,y) = x+y
add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
- add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)
add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6)
\end{code}
-- * TyThings and type environments
TyThing(..),
- tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId,
- implicitTyThings, isImplicitTyThing,
+ tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, tyThingCoAxiom,
+ implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing,
TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds,
- typeEnvDataCons,
+ typeEnvDataCons, typeEnvCoAxioms,
-- * MonadThings
MonadThings(..),
-- | A ModGuts is carried through the compiler, accumulating stuff as it goes
-- There is only one ModGuts at any time, the one for the module
-- being compiled right now. Once it is compiled, a 'ModIface' and
--- 'ModDetails' are extracted and the ModGuts is dicarded.
+-- 'ModDetails' are extracted and the ModGuts is discarded.
data ModGuts
= ModGuts {
mg_module :: !Module, -- ^ Module being compiled
-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
-- The order of the list does not matter.
implicitTyThings :: TyThing -> [TyThing]
-
--- For data and newtype declarations:
-implicitTyThings (ATyCon tc)
- = -- fields (names of selectors)
- -- (possibly) implicit coercion and family coercion
- -- depending on whether it's a newtype or a family instance or both
- implicitCoTyCon tc ++
- -- for each data constructor in order,
- -- the contructor, worker, and (possibly) wrapper
- concatMap (extras_plus . ADataCon) (tyConDataCons tc)
-
-implicitTyThings (AClass cl)
- = -- dictionary datatype:
+implicitTyThings (AnId _) = []
+implicitTyThings (ACoAxiom _cc) = []
+implicitTyThings (ATyCon tc) = implicitTyConThings tc
+implicitTyThings (AClass cl) = implicitClassThings cl
+implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc)
+ -- For data cons add the worker and (possibly) wrapper
+
+implicitClassThings :: Class -> [TyThing]
+implicitClassThings cl
+ = -- Does not include default methods, because those Ids may have
+ -- their own pragmas, unfoldings etc, not derived from the Class object
+ -- Dictionary datatype:
-- [extras_plus:]
-- type constructor
-- [recursive call:]
-- superclass and operation selectors
map AnId (classAllSelIds cl)
-implicitTyThings (ADataCon dc) =
- -- For data cons add the worker and (possibly) wrapper
- map AnId (dataConImplicitIds dc)
+implicitTyConThings :: TyCon -> [TyThing]
+implicitTyConThings tc
+ = -- fields (names of selectors)
+ -- (possibly) implicit coercion and family coercion
+ -- depending on whether it's a newtype or a family instance or both
+ implicitCoTyCon tc ++
+ -- for each data constructor in order,
+ -- the contructor, worker, and (possibly) wrapper
+ concatMap (extras_plus . ADataCon) (tyConDataCons tc)
-implicitTyThings (AnId _) = []
-- add a thing and recursive call
extras_plus :: TyThing -> [TyThing]
-- add the implicit coercion tycon
implicitCoTyCon :: TyCon -> [TyThing]
implicitCoTyCon tc
- = map ATyCon . catMaybes $ [-- Just if newtype, Nothing if not
- newTyConCo_maybe tc,
+ = map ACoAxiom . catMaybes $ [-- Just if newtype, Nothing if not
+ newTyConCo_maybe tc,
-- Just if family instance, Nothing if not
- tyConFamilyCoercion_maybe tc]
+ tyConFamilyCoercion_maybe tc]
-- sortByOcc = sortBy (\ x -> \ y -> getOccName x < getOccName y)
-- of some other declaration, or it is generated implicitly by some
-- other declaration.
isImplicitTyThing :: TyThing -> Bool
-isImplicitTyThing (ADataCon _) = True
-isImplicitTyThing (AnId id) = isImplicitId id
-isImplicitTyThing (AClass _) = False
-isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc
+isImplicitTyThing (ADataCon {}) = True
+isImplicitTyThing (AnId id) = isImplicitId id
+isImplicitTyThing (AClass {}) = False
+isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc
+isImplicitTyThing (ACoAxiom {}) = True
extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds env ids
typeEnvElts :: TypeEnv -> [TyThing]
typeEnvClasses :: TypeEnv -> [Class]
typeEnvTyCons :: TypeEnv -> [TyCon]
+typeEnvCoAxioms :: TypeEnv -> [CoAxiom]
typeEnvIds :: TypeEnv -> [Id]
typeEnvDataCons :: TypeEnv -> [DataCon]
lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing
typeEnvElts env = nameEnvElts env
typeEnvClasses env = [cl | AClass cl <- typeEnvElts env]
typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env]
+typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env]
typeEnvIds env = [id | AnId id <- typeEnvElts env]
typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env]
tyThingTyCon (ATyCon tc) = tc
tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other)
+-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise
+tyThingCoAxiom :: TyThing -> CoAxiom
+tyThingCoAxiom (ACoAxiom ax) = ax
+tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other)
+
-- | Get the 'Class' from a 'TyThing' if it is a class thing. Panics otherwise
tyThingClass :: TyThing -> Class
tyThingClass (AClass cls) = cls
import Exception
import System.Directory
-import System.FilePath
+import System.FilePath as FilePath
+import qualified System.FilePath.Posix as FilePath.Posix
import Control.Monad
import Data.List as List
import Data.Map (Map)
let
top_dir = topDir dflags
- pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs
+ pkgroot = takeDirectory conf_file
+ pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
pkg_configs2 = maybeHidePackages dflags pkg_configs1
--
return pkg_configs2
where
hide pkg = pkg{ exposed = False }
-mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig]
--- Replace the string "$topdir" at the beginning of a path
--- with the current topdir (obtained from the -B option).
-mungePackagePaths top_dir ps = map munge_pkg ps
- where
- munge_pkg p = p{ importDirs = munge_paths (importDirs p),
- includeDirs = munge_paths (includeDirs p),
- libraryDirs = munge_paths (libraryDirs p),
- frameworkDirs = munge_paths (frameworkDirs p),
- haddockInterfaces = munge_paths (haddockInterfaces p),
- haddockHTMLs = munge_paths (haddockHTMLs p)
- }
-
- munge_paths = map munge_path
-
- munge_path p
- | Just p' <- stripPrefix "$topdir" p = top_dir ++ p'
- | Just p' <- stripPrefix "$httptopdir" p = toHttpPath top_dir ++ p'
- | otherwise = p
-
- toHttpPath p = "file:///" ++ p
+mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
+-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
+-- The "pkgroot" is the directory containing the package database.
+--
+-- Also perform a similar substitution for the older GHC-specific
+-- "$topdir" variable. The "topdir" is the location of the ghc
+-- installation (obtained from the -B option).
+mungePackagePaths top_dir pkgroot pkg =
+ pkg {
+ importDirs = munge_paths (importDirs pkg),
+ includeDirs = munge_paths (includeDirs pkg),
+ libraryDirs = munge_paths (libraryDirs pkg),
+ frameworkDirs = munge_paths (frameworkDirs pkg),
+ haddockInterfaces = munge_paths (haddockInterfaces pkg),
+ haddockHTMLs = munge_urls (haddockHTMLs pkg)
+ }
+ where
+ munge_paths = map munge_path
+ munge_urls = map munge_url
+
+ munge_path p
+ | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
+ | Just p' <- stripVarPrefix "$topdir" sp = top_dir </> p'
+ | otherwise = p
+ where
+ sp = splitPath p
+
+ munge_url p
+ | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
+ | Just p' <- stripVarPrefix "$httptopdir" sp = toUrlPath top_dir p'
+ | otherwise = p
+ where
+ sp = splitPath p
+
+ toUrlPath r p = "file:///"
+ -- URLs always use posix style '/' separators:
+ ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
+
+ stripVarPrefix var (root:path')
+ | Just [sep] <- stripPrefix var root
+ , isPathSeparator sep
+ = Just (joinPath path')
+
+ stripVarPrefix _ _ = Nothing
-- -----------------------------------------------------------------------------
import Id
import IdInfo
import TyCon
+import Coercion( pprCoAxiom )
import TcType
-import Var
import Name
import Outputable
import FastString
----------------------------
-- | Pretty-prints a 'TyThing' with its defining location.
pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingLoc pefas tyThing
+pprTyThingLoc pefas tyThing
= showWithLoc loc (pprTyThing pefas tyThing)
where loc = pprNameLoc (GHC.getName tyThing)
ppr_ty_thing pefas _ (AnId id) = pprId pefas id
ppr_ty_thing pefas _ (ADataCon dataCon) = pprDataConSig pefas dataCon
ppr_ty_thing pefas show_me (ATyCon tyCon) = pprTyCon pefas show_me tyCon
+ppr_ty_thing _ _ (ACoAxiom ax) = pprCoAxiom ax
ppr_ty_thing pefas show_me (AClass cls) = pprClass pefas show_me cls
-- | Pretty-prints a 'TyThing' in context: that is, if the entity
--- is a data constructor, record selector, or class method, then
+-- is a data constructor, record selector, or class method, then
-- the entity's parent declaration is pretty-printed with irrelevant
-- parts omitted.
pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc
(pprTyThingInContext pefas tyThing)
pprTyThingParent_maybe :: TyThing -> Maybe TyThing
--- (pprTyThingParent_maybe x) returns (Just p)
+-- (pprTyThingParent_maybe x) returns (Just p)
-- when pprTyThingInContext sould print a declaration for p
-- (albeit with some "..." in it) when asked to show x
pprTyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
pprTyThingHdr pefas (AnId id) = pprId pefas id
pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
pprTyThingHdr pefas (ATyCon tyCon) = pprTyConHdr pefas tyCon
+pprTyThingHdr _ (ACoAxiom ax) = pprCoAxiom ax
pprTyThingHdr pefas (AClass cls) = pprClassHdr pefas cls
pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
| otherwise
= ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars)
where
- vars | GHC.isPrimTyCon tyCon ||
+ vars | GHC.isPrimTyCon tyCon ||
GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
| otherwise = GHC.tyConTyVars tyCon
| otherwise = empty
opt_stupid -- The "stupid theta" part of the declaration
- | isAlgTyCon tyCon = GHC.pprThetaArrow (tyConStupidTheta tyCon)
+ | isAlgTyCon tyCon = GHC.pprThetaArrowTy (tyConStupidTheta tyCon)
| otherwise = empty -- Returns 'empty' if null theta
pprDataConSig :: PrintExplicitForalls -> GHC.DataCon -> SDoc
pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc
pprClassHdr _ cls
- = ptext (sLit "class") <+>
- GHC.pprThetaArrow (GHC.classSCTheta cls) <+>
+ = ptext (sLit "class") <+>
+ GHC.pprThetaArrowTy (GHC.classSCTheta cls) <+>
ppr_bndr cls <+>
hsep (map ppr tyVars) <+>
GHC.pprFundeps funDeps
where
(tyVars, funDeps) = GHC.classTvsFds cls
-
+
pprId :: PrintExplicitForalls -> Var -> SDoc
pprId pefas ident
= hang (ppr_bndr ident <+> dcolon)
-- forall a. C a => forall b. Ord b => stuff
-- Then we want to display
-- (C a, Ord b) => stuff
-pprTypeForUser print_foralls ty
+pprTypeForUser print_foralls ty
| print_foralls = ppr tidy_ty
| otherwise = ppr (mkPhiTy ctxt ty')
where
= if GHC.isFamilyTyCon tyCon
then pprTyConHdr pefas tyCon <+> dcolon <+>
pprTypeForUser pefas (GHC.synTyConResKind tyCon)
- else
+ else
let rhs_type = GHC.synTyConType tyCon
in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type)
| otherwise
pprAlgTyCon :: PrintExplicitForalls -> ShowMe -> TyCon -> SDoc
pprAlgTyCon pefas show_me tyCon
- | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$
+ | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$
nest 2 (vcat (ppr_trim show_con datacons))
| otherwise = hang (pprTyConHdr pefas tyCon)
2 (add_bars (ppr_trim show_con datacons))
pprDataConDecl :: PrintExplicitForalls -> ShowMe -> Bool -> GHC.DataCon -> SDoc
pprDataConDecl pefas show_me gadt_style dataCon
| not gadt_style = ppr_fields tys_w_strs
- | otherwise = ppr_bndr dataCon <+> dcolon <+>
- sep [ pp_foralls, GHC.pprThetaArrow theta, pp_tau ]
+ | otherwise = ppr_bndr dataCon <+> dcolon <+>
+ sep [ pp_foralls, GHC.pprThetaArrowTy theta, pp_tau ]
-- Printing out the dataCon as a type signature, in GADT style
where
(forall_tvs, theta, tau) = tcSplitSigmaTy (GHC.dataConUserType dataCon)
| null labels
= ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
| otherwise
- = ppr_bndr dataCon <+>
- braces (sep (punctuate comma (ppr_trim maybe_show_label
+ = ppr_bndr dataCon <+>
+ braces (sep (punctuate comma (ppr_trim maybe_show_label
(zip labels fields))))
pprClass :: PrintExplicitForalls -> ShowMe -> GHC.Class -> SDoc
pprClass pefas show_me cls
| null methods
= pprClassHdr pefas cls
- | otherwise
+ | otherwise
= hang (pprClassHdr pefas cls <+> ptext (sLit "where"))
2 (vcat (ppr_trim show_meth methods))
where
-- Here's the magic incantation to strip off the dictionary
-- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl.
--
- -- It's important to tidy it *before* splitting it up, so that if
+ -- It's important to tidy it *before* splitting it up, so that if
-- we have class C a b where
-- op :: forall a. a -> b
-- then the inner forall on op gets renamed to a1, and we print
ppr_bndr a = GHC.pprParenSymName a
showWithLoc :: SDoc -> SDoc -> SDoc
-showWithLoc loc doc
+showWithLoc loc doc
= hang doc 2 (char '\t' <> comment <+> loc)
-- The tab tries to make them line up a bit
where
-- debugging options
-- | Suppress all that is suppressable in core dumps.
+-- Except for uniques, as some simplifier phases introduce new varibles that
+-- have otherwise identical names.
opt_SuppressAll :: Bool
opt_SuppressAll
= lookUp (fsLit "-dsuppress-all")
--- | Suppress unique ids on variables.
-opt_SuppressUniques :: Bool
-opt_SuppressUniques
- = lookUp (fsLit "-dsuppress-all")
- || lookUp (fsLit "-dsuppress-uniques")
-
-- | Suppress all coercions, them replacing with '...'
opt_SuppressCoercions :: Bool
opt_SuppressCoercions
= lookUp (fsLit "-dsuppress-all")
|| lookUp (fsLit "-dsuppress-type-signatures")
+-- | Suppress unique ids on variables.
+-- Except for uniques, as some simplifier phases introduce new variables that
+-- have otherwise identical names.
+opt_SuppressUniques :: Bool
+opt_SuppressUniques
+ = lookUp (fsLit "-dsuppress-uniques")
-- | Display case expressions with a single alternative as strict let bindings
opt_PprCaseAsLet :: Bool
-opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let")
+opt_PprCaseAsLet = lookUp (fsLit "-dppr-case-as-let")
-- | Set the maximum width of the dumps
-- If GHC's command line options are bad then the options parser uses the
opt_UF_DearOp, opt_UF_FunAppDiscount, opt_UF_DictDiscount :: Int
opt_UF_KeenessFactor :: Float
-opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int)
-opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (6::Int)
-opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int)
+opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (450::Int)
+opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (60::Int)
+opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (60::Int)
-opt_UF_DictDiscount = lookup_def_int "-funfolding-dict-discount" (3::Int)
+opt_UF_DictDiscount = lookup_def_int "-funfolding-dict-discount" (30::Int)
-- Be fairly keen to inline a fuction if that means
-- we'll be able to pick the right method from a dictionary
opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float)
-opt_UF_DearOp = ( 4 :: Int)
+opt_UF_DearOp = ( 40 :: Int)
-- Related to linking
-- to make that possible, so for now you can't.
; gcc_prog <- if isWindowsHost then return $ installed_mingw_bin "gcc"
else getSetting "C compiler command"
+ ; gcc_args_str <- if isWindowsHost then return []
+ else getSetting "C compiler flags"
+ ; let gcc_args = map Option (words gcc_args_str)
; perl_path <- if isWindowsHost
then return $ installed_perl_bin "perl"
else getSetting "perl command"
-- cpp is derived from gcc on all platforms
-- HACK, see setPgmP below. We keep 'words' here to remember to fix
-- Config.hs one day.
- ; let cpp_path = (gcc_prog,
- (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
+ ; let cpp_prog = gcc_prog
+ cpp_args = Option "-E"
+ : map Option (words cRAWCPP_FLAGS)
+ ++ gcc_args
-- Other things being equal, as and ld are simply gcc
; let as_prog = gcc_prog
+ as_args = gcc_args
ld_prog = gcc_prog
+ ld_args = gcc_args
- -- figure out llvm location. (TODO: Acutally implement).
+ -- We just assume on command line
; let lc_prog = "llc"
lo_prog = "opt"
sExtraGccViaCFlags = words myExtraGccViaCFlags,
sSystemPackageConfig = pkgconfig_path,
sPgm_L = unlit_path,
- sPgm_P = cpp_path,
+ sPgm_P = (cpp_prog, cpp_args),
sPgm_F = "",
- sPgm_c = (gcc_prog,[]),
+ sPgm_c = (gcc_prog, gcc_args),
sPgm_s = (split_prog,split_args),
- sPgm_a = (as_prog,[]),
- sPgm_l = (ld_prog,[]),
+ sPgm_a = (as_prog, as_args),
+ sPgm_l = (ld_prog, ld_args),
sPgm_dll = (mkdll_prog,mkdll_args),
sPgm_T = touch_path,
sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
| EOF
traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
--- a) trace the command (at two levels of verbosity)
--- b) don't do it at all if dry-run is set
+-- trace the command (at two levels of verbosity)
traceCmd dflags phase_name cmd_line action
= do { let verb = verbosity dflags
; showPass dflags phase_name
; debugTraceMsg dflags 3 (text cmd_line)
; hFlush stderr
- -- Test for -n flag
- ; unless (dopt Opt_DryRun dflags) $ do {
-
-- And run it!
; action `catchIO` handle_exn verb
- }}
+ }
where
handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
#if defined(mingw32_HOST_OS)
-- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe,
-- return the path $(stuff)/lib.
-getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
- buf <- mallocArray len
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then free buf >> return Nothing
- else do s <- peekCString buf
- free buf
- return (Just (rootDir s))
+getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
where
+ try_size size = allocaArray (fromIntegral size) $ \buf -> do
+ ret <- c_GetModuleFileName nullPtr buf size
+ case ret of
+ 0 -> return Nothing
+ _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
+ | otherwise -> try_size (size * 2)
+
rootDir s = case splitFileName $ normalise s of
(d, ghc_exe)
| lower ghc_exe `elem` ["ghc.exe",
where fail = panic ("can't decompose ghc.exe path: " ++ show s)
lower = map toLower
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getBaseDir = return Nothing
#endif
cafRefs p (Note _n e) = cafRefs p e
cafRefs p (Cast e _co) = cafRefs p e
cafRefs _ (Type _) = fastBool False
+cafRefs _ (Coercion _) = fastBool False
cafRefss :: VarEnv Id -> [Expr a] -> FastBool
cafRefss _ [] = fastBool False
+++ /dev/null
-module Alpha.CodeGen ()
-
-where
-
-{-
-
-getRegister :: CmmExpr -> NatM Register
-
-#if !x86_64_TARGET_ARCH
- -- on x86_64, we have %rip for PicBaseReg, but it's not a full-featured
- -- register, it can only be used for rip-relative addressing.
-getRegister (CmmReg (CmmGlobal PicBaseReg))
- = do
- reg <- getPicBaseNat wordSize
- return (Fixed wordSize reg nilOL)
-#endif
-
-getRegister (CmmReg reg)
- = return (Fixed (cmmTypeSize (cmmRegType reg))
- (getRegisterReg reg) nilOL)
-
-getRegister tree@(CmmRegOff _ _)
- = getRegister (mangleIndexTree tree)
-
-
-#if WORD_SIZE_IN_BITS==32
- -- for 32-bit architectuers, support some 64 -> 32 bit conversions:
- -- TO_W_(x), TO_W_(x >> 32)
-
-getRegister (CmmMachOp (MO_UU_Conv W64 W32)
- [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
- ChildCode64 code rlo <- iselExpr64 x
- return $ Fixed II32 (getHiVRegFromLo rlo) code
-
-getRegister (CmmMachOp (MO_SS_Conv W64 W32)
- [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
- ChildCode64 code rlo <- iselExpr64 x
- return $ Fixed II32 (getHiVRegFromLo rlo) code
-
-getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
- ChildCode64 code rlo <- iselExpr64 x
- return $ Fixed II32 rlo code
-
-getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
- ChildCode64 code rlo <- iselExpr64 x
- return $ Fixed II32 rlo code
-
-#endif
-
--- end of machine-"independent" bit; here we go on the rest...
-
-
-getRegister (StDouble d)
- = getBlockIdNat `thenNat` \ lbl ->
- getNewRegNat PtrRep `thenNat` \ tmp ->
- let code dst = mkSeqInstrs [
- LDATA RoDataSegment lbl [
- DATA TF [ImmLab (rational d)]
- ],
- LDA tmp (AddrImm (ImmCLbl lbl)),
- LD TF dst (AddrReg tmp)]
- in
- return (Any FF64 code)
-
-getRegister (StPrim primop [x]) -- unary PrimOps
- = case primop of
- IntNegOp -> trivialUCode (NEG Q False) x
-
- NotOp -> trivialUCode NOT x
-
- FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x
- DoubleNegOp -> trivialUFCode FF64 (FNEG TF) x
-
- OrdOp -> coerceIntCode IntRep x
- ChrOp -> chrCode x
-
- Float2IntOp -> coerceFP2Int x
- Int2FloatOp -> coerceInt2FP pr x
- Double2IntOp -> coerceFP2Int x
- Int2DoubleOp -> coerceInt2FP pr x
-
- Double2FloatOp -> coerceFltCode x
- Float2DoubleOp -> coerceFltCode x
-
- other_op -> getRegister (StCall fn CCallConv FF64 [x])
- where
- fn = case other_op of
- FloatExpOp -> fsLit "exp"
- FloatLogOp -> fsLit "log"
- FloatSqrtOp -> fsLit "sqrt"
- FloatSinOp -> fsLit "sin"
- FloatCosOp -> fsLit "cos"
- FloatTanOp -> fsLit "tan"
- FloatAsinOp -> fsLit "asin"
- FloatAcosOp -> fsLit "acos"
- FloatAtanOp -> fsLit "atan"
- FloatSinhOp -> fsLit "sinh"
- FloatCoshOp -> fsLit "cosh"
- FloatTanhOp -> fsLit "tanh"
- DoubleExpOp -> fsLit "exp"
- DoubleLogOp -> fsLit "log"
- DoubleSqrtOp -> fsLit "sqrt"
- DoubleSinOp -> fsLit "sin"
- DoubleCosOp -> fsLit "cos"
- DoubleTanOp -> fsLit "tan"
- DoubleAsinOp -> fsLit "asin"
- DoubleAcosOp -> fsLit "acos"
- DoubleAtanOp -> fsLit "atan"
- DoubleSinhOp -> fsLit "sinh"
- DoubleCoshOp -> fsLit "cosh"
- DoubleTanhOp -> fsLit "tanh"
- where
- pr = panic "MachCode.getRegister: no primrep needed for Alpha"
-
-getRegister (StPrim primop [x, y]) -- dyadic PrimOps
- = case primop of
- CharGtOp -> trivialCode (CMP LTT) y x
- CharGeOp -> trivialCode (CMP LE) y x
- CharEqOp -> trivialCode (CMP EQQ) x y
- CharNeOp -> int_NE_code x y
- CharLtOp -> trivialCode (CMP LTT) x y
- CharLeOp -> trivialCode (CMP LE) x y
-
- IntGtOp -> trivialCode (CMP LTT) y x
- IntGeOp -> trivialCode (CMP LE) y x
- IntEqOp -> trivialCode (CMP EQQ) x y
- IntNeOp -> int_NE_code x y
- IntLtOp -> trivialCode (CMP LTT) x y
- IntLeOp -> trivialCode (CMP LE) x y
-
- WordGtOp -> trivialCode (CMP ULT) y x
- WordGeOp -> trivialCode (CMP ULE) x y
- WordEqOp -> trivialCode (CMP EQQ) x y
- WordNeOp -> int_NE_code x y
- WordLtOp -> trivialCode (CMP ULT) x y
- WordLeOp -> trivialCode (CMP ULE) x y
-
- AddrGtOp -> trivialCode (CMP ULT) y x
- AddrGeOp -> trivialCode (CMP ULE) y x
- AddrEqOp -> trivialCode (CMP EQQ) x y
- AddrNeOp -> int_NE_code x y
- AddrLtOp -> trivialCode (CMP ULT) x y
- AddrLeOp -> trivialCode (CMP ULE) x y
-
- FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y
- FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
- FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y
- FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
- FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y
- FloatLeOp -> cmpF_code (FCMP TF LE) NE x y
-
- DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y
- DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y
- DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y
- DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y
- DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y
- DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y
-
- IntAddOp -> trivialCode (ADD Q False) x y
- IntSubOp -> trivialCode (SUB Q False) x y
- IntMulOp -> trivialCode (MUL Q False) x y
- IntQuotOp -> trivialCode (DIV Q False) x y
- IntRemOp -> trivialCode (REM Q False) x y
-
- WordAddOp -> trivialCode (ADD Q False) x y
- WordSubOp -> trivialCode (SUB Q False) x y
- WordMulOp -> trivialCode (MUL Q False) x y
- WordQuotOp -> trivialCode (DIV Q True) x y
- WordRemOp -> trivialCode (REM Q True) x y
-
- FloatAddOp -> trivialFCode W32 (FADD TF) x y
- FloatSubOp -> trivialFCode W32 (FSUB TF) x y
- FloatMulOp -> trivialFCode W32 (FMUL TF) x y
- FloatDivOp -> trivialFCode W32 (FDIV TF) x y
-
- DoubleAddOp -> trivialFCode W64 (FADD TF) x y
- DoubleSubOp -> trivialFCode W64 (FSUB TF) x y
- DoubleMulOp -> trivialFCode W64 (FMUL TF) x y
- DoubleDivOp -> trivialFCode W64 (FDIV TF) x y
-
- AddrAddOp -> trivialCode (ADD Q False) x y
- AddrSubOp -> trivialCode (SUB Q False) x y
- AddrRemOp -> trivialCode (REM Q True) x y
-
- AndOp -> trivialCode AND x y
- OrOp -> trivialCode OR x y
- XorOp -> trivialCode XOR x y
- SllOp -> trivialCode SLL x y
- SrlOp -> trivialCode SRL x y
-
- ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
- ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
- ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
-
- FloatPowerOp -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
- DoublePowerOp -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y])
- where
- {- ------------------------------------------------------------
- Some bizarre special code for getting condition codes into
- registers. Integer non-equality is a test for equality
- followed by an XOR with 1. (Integer comparisons always set
- the result register to 0 or 1.) Floating point comparisons of
- any kind leave the result in a floating point register, so we
- need to wrangle an integer register out of things.
- -}
- int_NE_code :: StixTree -> StixTree -> NatM Register
-
- int_NE_code x y
- = trivialCode (CMP EQQ) x y `thenNat` \ register ->
- getNewRegNat IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst)
- in
- return (Any IntRep code__2)
-
- {- ------------------------------------------------------------
- Comments for int_NE_code also apply to cmpF_code
- -}
- cmpF_code
- :: (Reg -> Reg -> Reg -> Instr)
- -> Cond
- -> StixTree -> StixTree
- -> NatM Register
-
- cmpF_code instr cond x y
- = trivialFCode pr instr x y `thenNat` \ register ->
- getNewRegNat FF64 `thenNat` \ tmp ->
- getBlockIdNat `thenNat` \ lbl ->
- let
- code = registerCode register tmp
- result = registerName register tmp
-
- code__2 dst = code . mkSeqInstrs [
- OR zeroh (RIImm (ImmInt 1)) dst,
- BF cond result (ImmCLbl lbl),
- OR zeroh (RIReg zeroh) dst,
- NEWBLOCK lbl]
- in
- return (Any IntRep code__2)
- where
- pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
- ------------------------------------------------------------
-
-getRegister (CmmLoad pk mem)
- = getAmode mem `thenNat` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- size = primRepToSize pk
- code__2 dst = code . mkSeqInstr (LD size dst src)
- in
- return (Any pk code__2)
-
-getRegister (StInt i)
- | fits8Bits i
- = let
- code dst = mkSeqInstr (OR zeroh (RIImm src) dst)
- in
- return (Any IntRep code)
- | otherwise
- = let
- code dst = mkSeqInstr (LDI Q dst src)
- in
- return (Any IntRep code)
- where
- src = ImmInt (fromInteger i)
-
-getRegister leaf
- | isJust imm
- = let
- code dst = mkSeqInstr (LDA dst (AddrImm imm__2))
- in
- return (Any PtrRep code)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-
-getAmode :: CmmExpr -> NatM Amode
-getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-#if alpha_TARGET_ARCH
-
-getAmode (StPrim IntSubOp [x, StInt i])
- = getNewRegNat PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (-(fromInteger i))
- in
- return (Amode (AddrRegImm reg off) code)
-
-getAmode (StPrim IntAddOp [x, StInt i])
- = getNewRegNat PtrRep `thenNat` \ tmp ->
- getRegister x `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- off = ImmInt (fromInteger i)
- in
- return (Amode (AddrRegImm reg off) code)
-
-getAmode leaf
- | isJust imm
- = return (Amode (AddrImm imm__2) id)
- where
- imm = maybeImm leaf
- imm__2 = case imm of Just x -> x
-
-getAmode other
- = getNewRegNat PtrRep `thenNat` \ tmp ->
- getRegister other `thenNat` \ register ->
- let
- code = registerCode register tmp
- reg = registerName register tmp
- in
- return (Amode (AddrReg reg) code)
-
-#endif /* alpha_TARGET_ARCH */
-
-
--- -----------------------------------------------------------------------------
--- Generating assignments
-
--- Assignments are really at the heart of the whole code generation
--- business. Almost all top-level nodes of any real importance are
--- assignments, which correspond to loads, stores, or register
--- transfers. If we're really lucky, some of the register transfers
--- will go away, because we can use the destination register to
--- complete the code generation for the right hand side. This only
--- fails when the right hand side is forced into a fixed register
--- (e.g. the result of a call).
-
-assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock
-
-assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock
-
-
-assignIntCode pk (CmmLoad dst _) src
- = getNewRegNat IntRep `thenNat` \ tmp ->
- getAmode dst `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- code1 = amodeCode amode []
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp []
- src__2 = registerName register tmp
- sz = primRepToSize pk
- code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
- in
- return code__2
-
-assignIntCode pk dst src
- = getRegister dst `thenNat` \ register1 ->
- getRegister src `thenNat` \ register2 ->
- let
- dst__2 = registerName register1 zeroh
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2
- then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2)
- else code
- in
- return code__2
-
-assignFltCode pk (CmmLoad dst _) src
- = getNewRegNat pk `thenNat` \ tmp ->
- getAmode dst `thenNat` \ amode ->
- getRegister src `thenNat` \ register ->
- let
- code1 = amodeCode amode []
- dst__2 = amodeAddr amode
- code2 = registerCode register tmp []
- src__2 = registerName register tmp
- sz = primRepToSize pk
- code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2)
- in
- return code__2
-
-assignFltCode pk dst src
- = getRegister dst `thenNat` \ register1 ->
- getRegister src `thenNat` \ register2 ->
- let
- dst__2 = registerName register1 zeroh
- code = registerCode register2 dst__2
- src__2 = registerName register2 dst__2
- code__2 = if isFixed register2
- then code . mkSeqInstr (FMOV src__2 dst__2)
- else code
- in
- return code__2
-
-
--- -----------------------------------------------------------------------------
--- Generating an non-local jump
-
--- (If applicable) Do not fill the delay slots here; you will confuse the
--- register allocator.
-
-genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-
-genJump (CmmLabel lbl)
- | isAsmTemp lbl = returnInstr (BR target)
- | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0]
- where
- target = ImmCLbl lbl
-
-genJump tree
- = getRegister tree `thenNat` \ register ->
- getNewRegNat PtrRep `thenNat` \ tmp ->
- let
- dst = registerName register pv
- code = registerCode register pv
- target = registerName register pv
- in
- if isFixed register then
- returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0]
- else
- return (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
-
-
--- -----------------------------------------------------------------------------
--- Unconditional branches
-
-genBranch :: BlockId -> NatM InstrBlock
-
-genBranch = return . toOL . mkBranchInstr
-
-
--- -----------------------------------------------------------------------------
--- Conditional jumps
-
-{-
-Conditional jumps are always to local labels, so we can use branch
-instructions. We peek at the arguments to decide what kind of
-comparison to do.
-
-ALPHA: For comparisons with 0, we're laughing, because we can just do
-the desired conditional branch.
-
--}
-
-
-genCondJump
- :: BlockId -- the branch target
- -> CmmExpr -- the condition on which to branch
- -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-genCondJump id (StPrim op [x, StInt 0])
- = getRegister x `thenNat` \ register ->
- getNewRegNat (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- value = registerName register tmp
- pk = registerRep register
- target = ImmCLbl lbl
- in
- returnSeq code [BI (cmpOp op) value target]
- where
- cmpOp CharGtOp = GTT
- cmpOp CharGeOp = GE
- cmpOp CharEqOp = EQQ
- cmpOp CharNeOp = NE
- cmpOp CharLtOp = LTT
- cmpOp CharLeOp = LE
- cmpOp IntGtOp = GTT
- cmpOp IntGeOp = GE
- cmpOp IntEqOp = EQQ
- cmpOp IntNeOp = NE
- cmpOp IntLtOp = LTT
- cmpOp IntLeOp = LE
- cmpOp WordGtOp = NE
- cmpOp WordGeOp = ALWAYS
- cmpOp WordEqOp = EQQ
- cmpOp WordNeOp = NE
- cmpOp WordLtOp = NEVER
- cmpOp WordLeOp = EQQ
- cmpOp AddrGtOp = NE
- cmpOp AddrGeOp = ALWAYS
- cmpOp AddrEqOp = EQQ
- cmpOp AddrNeOp = NE
- cmpOp AddrLtOp = NEVER
- cmpOp AddrLeOp = EQQ
-
-genCondJump lbl (StPrim op [x, StDouble 0.0])
- = getRegister x `thenNat` \ register ->
- getNewRegNat (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- value = registerName register tmp
- pk = registerRep register
- target = ImmCLbl lbl
- in
- return (code . mkSeqInstr (BF (cmpOp op) value target))
- where
- cmpOp FloatGtOp = GTT
- cmpOp FloatGeOp = GE
- cmpOp FloatEqOp = EQQ
- cmpOp FloatNeOp = NE
- cmpOp FloatLtOp = LTT
- cmpOp FloatLeOp = LE
- cmpOp DoubleGtOp = GTT
- cmpOp DoubleGeOp = GE
- cmpOp DoubleEqOp = EQQ
- cmpOp DoubleNeOp = NE
- cmpOp DoubleLtOp = LTT
- cmpOp DoubleLeOp = LE
-
-genCondJump lbl (StPrim op [x, y])
- | fltCmpOp op
- = trivialFCode pr instr x y `thenNat` \ register ->
- getNewRegNat FF64 `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- result = registerName register tmp
- target = ImmCLbl lbl
- in
- return (code . mkSeqInstr (BF cond result target))
- where
- pr = panic "trivialU?FCode: does not use PrimRep on Alpha"
-
- fltCmpOp op = case op of
- FloatGtOp -> True
- FloatGeOp -> True
- FloatEqOp -> True
- FloatNeOp -> True
- FloatLtOp -> True
- FloatLeOp -> True
- DoubleGtOp -> True
- DoubleGeOp -> True
- DoubleEqOp -> True
- DoubleNeOp -> True
- DoubleLtOp -> True
- DoubleLeOp -> True
- _ -> False
- (instr, cond) = case op of
- FloatGtOp -> (FCMP TF LE, EQQ)
- FloatGeOp -> (FCMP TF LTT, EQQ)
- FloatEqOp -> (FCMP TF EQQ, NE)
- FloatNeOp -> (FCMP TF EQQ, EQQ)
- FloatLtOp -> (FCMP TF LTT, NE)
- FloatLeOp -> (FCMP TF LE, NE)
- DoubleGtOp -> (FCMP TF LE, EQQ)
- DoubleGeOp -> (FCMP TF LTT, EQQ)
- DoubleEqOp -> (FCMP TF EQQ, NE)
- DoubleNeOp -> (FCMP TF EQQ, EQQ)
- DoubleLtOp -> (FCMP TF LTT, NE)
- DoubleLeOp -> (FCMP TF LE, NE)
-
-genCondJump lbl (StPrim op [x, y])
- = trivialCode instr x y `thenNat` \ register ->
- getNewRegNat IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- result = registerName register tmp
- target = ImmCLbl lbl
- in
- return (code . mkSeqInstr (BI cond result target))
- where
- (instr, cond) = case op of
- CharGtOp -> (CMP LE, EQQ)
- CharGeOp -> (CMP LTT, EQQ)
- CharEqOp -> (CMP EQQ, NE)
- CharNeOp -> (CMP EQQ, EQQ)
- CharLtOp -> (CMP LTT, NE)
- CharLeOp -> (CMP LE, NE)
- IntGtOp -> (CMP LE, EQQ)
- IntGeOp -> (CMP LTT, EQQ)
- IntEqOp -> (CMP EQQ, NE)
- IntNeOp -> (CMP EQQ, EQQ)
- IntLtOp -> (CMP LTT, NE)
- IntLeOp -> (CMP LE, NE)
- WordGtOp -> (CMP ULE, EQQ)
- WordGeOp -> (CMP ULT, EQQ)
- WordEqOp -> (CMP EQQ, NE)
- WordNeOp -> (CMP EQQ, EQQ)
- WordLtOp -> (CMP ULT, NE)
- WordLeOp -> (CMP ULE, NE)
- AddrGtOp -> (CMP ULE, EQQ)
- AddrGeOp -> (CMP ULT, EQQ)
- AddrEqOp -> (CMP EQQ, NE)
- AddrNeOp -> (CMP EQQ, EQQ)
- AddrLtOp -> (CMP ULT, NE)
- AddrLeOp -> (CMP ULE, NE)
-
--- -----------------------------------------------------------------------------
--- Generating C calls
-
--- Now the biggest nightmare---calls. Most of the nastiness is buried in
--- @get_arg@, which moves the arguments to the correct registers/stack
--- locations. Apart from that, the code is easy.
---
--- (If applicable) Do not fill the delay slots here; you will confuse the
--- register allocator.
-
-genCCall
- :: CmmCallTarget -- function to call
- -> HintedCmmFormals -- where to put the result
- -> HintedCmmActuals -- arguments (of mixed type)
- -> NatM InstrBlock
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-ccallResultRegs =
-
-genCCall fn cconv result_regs args
- = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args
- `thenNat` \ ((unused,_), argCode) ->
- let
- nRegs = length allArgRegs - length unused
- code = asmSeqThen (map ($ []) argCode)
- in
- returnSeq code [
- LDA pv (AddrImm (ImmLab (ptext fn))),
- JSR ra (AddrReg pv) nRegs,
- LDGP gp (AddrReg ra)]
- where
- ------------------------
- {- Try to get a value into a specific register (or registers) for
- a call. The first 6 arguments go into the appropriate
- argument register (separate registers for integer and floating
- point arguments, but used in lock-step), and the remaining
- arguments are dumped to the stack, beginning at 0(sp). Our
- first argument is a pair of the list of remaining argument
- registers to be assigned for this call and the next stack
- offset to use for overflowing arguments. This way,
- @get_Arg@ can be applied to all of a call's arguments using
- @mapAccumLNat@.
- -}
- get_arg
- :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator)
- -> StixTree -- Current argument
- -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code
-
- -- We have to use up all of our argument registers first...
-
- get_arg ((iDst,fDst):dsts, offset) arg
- = getRegister arg `thenNat` \ register ->
- let
- reg = if isFloatType pk then fDst else iDst
- code = registerCode register reg
- src = registerName register reg
- pk = registerRep register
- in
- return (
- if isFloatType pk then
- ((dsts, offset), if isFixed register then
- code . mkSeqInstr (FMOV src fDst)
- else code)
- else
- ((dsts, offset), if isFixed register then
- code . mkSeqInstr (OR src (RIReg src) iDst)
- else code))
-
- -- Once we have run out of argument registers, we move to the
- -- stack...
-
- get_arg ([], offset) arg
- = getRegister arg `thenNat` \ register ->
- getNewRegNat (registerRep register)
- `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- pk = registerRep register
- sz = primRepToSize pk
- in
- return (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
-
-trivialCode instr x (StInt y)
- | fits8Bits y
- = getRegister x `thenNat` \ register ->
- getNewRegNat IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src1 = registerName register tmp
- src2 = ImmInt (fromInteger y)
- code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst)
- in
- return (Any IntRep code__2)
-
-trivialCode instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNat IntRep `thenNat` \ tmp1 ->
- getNewRegNat IntRep `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1 []
- src1 = registerName register1 tmp1
- code2 = registerCode register2 tmp2 []
- src2 = registerName register2 tmp2
- code__2 dst = asmSeqThen [code1, code2] .
- mkSeqInstr (instr src1 (RIReg src2) dst)
- in
- return (Any IntRep code__2)
-
-------------
-trivialUCode instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNat IntRep `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (instr (RIReg src) dst)
- in
- return (Any IntRep code__2)
-
-------------
-trivialFCode _ instr x y
- = getRegister x `thenNat` \ register1 ->
- getRegister y `thenNat` \ register2 ->
- getNewRegNat FF64 `thenNat` \ tmp1 ->
- getNewRegNat FF64 `thenNat` \ tmp2 ->
- let
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- code2 = registerCode register2 tmp2
- src2 = registerName register2 tmp2
-
- code__2 dst = asmSeqThen [code1 [], code2 []] .
- mkSeqInstr (instr src1 src2 dst)
- in
- return (Any FF64 code__2)
-
-trivialUFCode _ instr x
- = getRegister x `thenNat` \ register ->
- getNewRegNat FF64 `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
- code__2 dst = code . mkSeqInstr (instr src dst)
- in
- return (Any FF64 code__2)
-
-#if alpha_TARGET_ARCH
-
-coerceInt2FP _ x
- = getRegister x `thenNat` \ register ->
- getNewRegNat IntRep `thenNat` \ reg ->
- let
- code = registerCode register reg
- src = registerName register reg
-
- code__2 dst = code . mkSeqInstrs [
- ST Q src (spRel 0),
- LD TF dst (spRel 0),
- CVTxy Q TF dst dst]
- in
- return (Any FF64 code__2)
-
--------------
-coerceFP2Int x
- = getRegister x `thenNat` \ register ->
- getNewRegNat FF64 `thenNat` \ tmp ->
- let
- code = registerCode register tmp
- src = registerName register tmp
-
- code__2 dst = code . mkSeqInstrs [
- CVTxy TF Q src tmp,
- ST TF tmp (spRel 0),
- LD Q dst (spRel 0)]
- in
- return (Any IntRep code__2)
-
-#endif /* alpha_TARGET_ARCH */
-
-
--}
-
-
-
-
-
+++ /dev/null
------------------------------------------------------------------------------
---
--- Machine-dependent assembly language
---
--- (c) The University of Glasgow 1993-2004
---
------------------------------------------------------------------------------
-
-#include "HsVersions.h"
-#include "nativeGen/NCG.h"
-
-module Alpha.Instr (
--- Cond(..),
--- Instr(..),
--- RI(..)
-)
-
-where
-
-{-
-import BlockId
-import Regs
-import Cmm
-import FastString
-import CLabel
-
-data Cond
- = ALWAYS -- For BI (same as BR)
- | EQQ -- For CMP and BI (NB: "EQ" is a 1.3 Prelude name)
- | GE -- For BI only
- | GTT -- For BI only (NB: "GT" is a 1.3 Prelude name)
- | LE -- For CMP and BI
- | LTT -- For CMP and BI (NB: "LT" is a 1.3 Prelude name)
- | NE -- For BI only
- | NEVER -- For BI (null instruction)
- | ULE -- For CMP only
- | ULT -- For CMP only
- deriving Eq
-
-
--- -----------------------------------------------------------------------------
--- Machine's assembly language
-
--- We have a few common "instructions" (nearly all the pseudo-ops) but
--- mostly all of 'Instr' is machine-specific.
-
--- Register or immediate
-data RI
- = RIReg Reg
- | RIImm Imm
-
-data Instr
- -- comment pseudo-op
- = COMMENT FastString
-
- -- some static data spat out during code
- -- generation. Will be extracted before
- -- pretty-printing.
- | LDATA Section [CmmStatic]
-
- -- start a new basic block. Useful during
- -- codegen, removed later. Preceding
- -- instruction should be a jump, as per the
- -- invariants for a BasicBlock (see Cmm).
- | NEWBLOCK BlockId
-
- -- specify current stack offset for
- -- benefit of subsequent passes
- | DELTA Int
-
- -- | spill this reg to a stack slot
- | SPILL Reg Int
-
- -- | reload this reg from a stack slot
- | RELOAD Int Reg
-
- -- Loads and stores.
- | LD Size Reg AddrMode -- size, dst, src
- | LDA Reg AddrMode -- dst, src
- | LDAH Reg AddrMode -- dst, src
- | LDGP Reg AddrMode -- dst, src
- | LDI Size Reg Imm -- size, dst, src
- | ST Size Reg AddrMode -- size, src, dst
-
- -- Int Arithmetic.
- | CLR Reg -- dst
- | ABS Size RI Reg -- size, src, dst
- | NEG Size Bool RI Reg -- size, overflow, src, dst
- | ADD Size Bool Reg RI Reg -- size, overflow, src, src, dst
- | SADD Size Size Reg RI Reg -- size, scale, src, src, dst
- | SUB Size Bool Reg RI Reg -- size, overflow, src, src, dst
- | SSUB Size Size Reg RI Reg -- size, scale, src, src, dst
- | MUL Size Bool Reg RI Reg -- size, overflow, src, src, dst
- | DIV Size Bool Reg RI Reg -- size, unsigned, src, src, dst
- | REM Size Bool Reg RI Reg -- size, unsigned, src, src, dst
-
- -- Simple bit-twiddling.
- | NOT RI Reg
- | AND Reg RI Reg
- | ANDNOT Reg RI Reg
- | OR Reg RI Reg
- | ORNOT Reg RI Reg
- | XOR Reg RI Reg
- | XORNOT Reg RI Reg
- | SLL Reg RI Reg
- | SRL Reg RI Reg
- | SRA Reg RI Reg
-
- | ZAP Reg RI Reg
- | ZAPNOT Reg RI Reg
-
- | NOP
-
- -- Comparison
- | CMP Cond Reg RI Reg
-
- -- Float Arithmetic.
- | FCLR Reg
- | FABS Reg Reg
- | FNEG Size Reg Reg
- | FADD Size Reg Reg Reg
- | FDIV Size Reg Reg Reg
- | FMUL Size Reg Reg Reg
- | FSUB Size Reg Reg Reg
- | CVTxy Size Size Reg Reg
- | FCMP Size Cond Reg Reg Reg
- | FMOV Reg Reg
-
- -- Jumping around.
- | BI Cond Reg Imm
- | BF Cond Reg Imm
- | BR Imm
- | JMP Reg AddrMode Int
- | BSR Imm Int
- | JSR Reg AddrMode Int
-
- -- Alpha-specific pseudo-ops.
- | FUNBEGIN CLabel
- | FUNEND CLabel
-
-
--}
+++ /dev/null
-
-module Alpha.Ppr (
-{-
- pprReg,
- pprSize,
- pprCond,
- pprAddr,
- pprSectionHeader,
- pprTypeAndSizeDecl,
- pprRI,
- pprRegRIReg,
- pprSizeRegRegReg
--}
-)
-
-where
-
-{-
-#include "nativeGen/NCG.h"
-#include "HsVersions.h"
-
-import BlockId
-import Cmm
-import Regs -- may differ per-platform
-import Instrs
-
-import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel,
- labelDynamic, mkAsmTempLabel, entryLblToInfoLbl )
-
-#if HAVE_SUBSECTIONS_VIA_SYMBOLS
-import CLabel ( mkDeadStripPreventer )
-#endif
-
-import Panic ( panic )
-import Unique ( pprUnique )
-import Pretty
-import FastString
-import qualified Outputable
-import Outputable ( Outputable, pprPanic, ppr, docToSDoc)
-
-import Data.Array.ST
-import Data.Word ( Word8 )
-import Control.Monad.ST
-import Data.Char ( chr, ord )
-import Data.Maybe ( isJust )
-
-
-
-pprReg :: Reg -> Doc
-pprReg r
- = case r of
- RealReg i -> ppr_reg_no i
- VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u)
- VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u)
- VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u)
- VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u)
- where
- ppr_reg_no :: Int -> Doc
- ppr_reg_no i = ptext
- (case i of {
- 0 -> sLit "$0"; 1 -> sLit "$1";
- 2 -> sLit "$2"; 3 -> sLit "$3";
- 4 -> sLit "$4"; 5 -> sLit "$5";
- 6 -> sLit "$6"; 7 -> sLit "$7";
- 8 -> sLit "$8"; 9 -> sLit "$9";
- 10 -> sLit "$10"; 11 -> sLit "$11";
- 12 -> sLit "$12"; 13 -> sLit "$13";
- 14 -> sLit "$14"; 15 -> sLit "$15";
- 16 -> sLit "$16"; 17 -> sLit "$17";
- 18 -> sLit "$18"; 19 -> sLit "$19";
- 20 -> sLit "$20"; 21 -> sLit "$21";
- 22 -> sLit "$22"; 23 -> sLit "$23";
- 24 -> sLit "$24"; 25 -> sLit "$25";
- 26 -> sLit "$26"; 27 -> sLit "$27";
- 28 -> sLit "$28"; 29 -> sLit "$29";
- 30 -> sLit "$30"; 31 -> sLit "$31";
- 32 -> sLit "$f0"; 33 -> sLit "$f1";
- 34 -> sLit "$f2"; 35 -> sLit "$f3";
- 36 -> sLit "$f4"; 37 -> sLit "$f5";
- 38 -> sLit "$f6"; 39 -> sLit "$f7";
- 40 -> sLit "$f8"; 41 -> sLit "$f9";
- 42 -> sLit "$f10"; 43 -> sLit "$f11";
- 44 -> sLit "$f12"; 45 -> sLit "$f13";
- 46 -> sLit "$f14"; 47 -> sLit "$f15";
- 48 -> sLit "$f16"; 49 -> sLit "$f17";
- 50 -> sLit "$f18"; 51 -> sLit "$f19";
- 52 -> sLit "$f20"; 53 -> sLit "$f21";
- 54 -> sLit "$f22"; 55 -> sLit "$f23";
- 56 -> sLit "$f24"; 57 -> sLit "$f25";
- 58 -> sLit "$f26"; 59 -> sLit "$f27";
- 60 -> sLit "$f28"; 61 -> sLit "$f29";
- 62 -> sLit "$f30"; 63 -> sLit "$f31";
- _ -> sLit "very naughty alpha register"
- })
-
-
-pprSize :: Size -> Doc
-pprSize x = ptext (case x of
- B -> sLit "b"
- Bu -> sLit "bu"
--- W -> sLit "w" UNUSED
--- Wu -> sLit "wu" UNUSED
- L -> sLit "l"
- Q -> sLit "q"
--- FF -> sLit "f" UNUSED
--- DF -> sLit "d" UNUSED
--- GF -> sLit "g" UNUSED
--- SF -> sLit "s" UNUSED
- TF -> sLit "t"
-
-
-pprCond :: Cond -> Doc
-pprCond c
- = ptext (case c of
- EQQ -> sLit "eq"
- LTT -> sLit "lt"
- LE -> sLit "le"
- ULT -> sLit "ult"
- ULE -> sLit "ule"
- NE -> sLit "ne"
- GTT -> sLit "gt"
- GE -> sLit "ge")
-
-
-pprAddr :: AddrMode -> Doc
-pprAddr (AddrReg r) = parens (pprReg r)
-pprAddr (AddrImm i) = pprImm i
-pprAddr (AddrRegImm r1 i)
- = (<>) (pprImm i) (parens (pprReg r1))
-
-
-pprSectionHeader Text
- = ptext (sLit "\t.text\n\t.align 3")
-
-pprSectionHeader Data
- = ptext (sLit "\t.data\n\t.align 3")
-
-pprSectionHeader ReadOnlyData
- = ptext (sLit "\t.data\n\t.align 3")
-
-pprSectionHeader RelocatableReadOnlyData
- = ptext (sLit "\t.data\n\t.align 3")
-
-pprSectionHeader UninitialisedData
- = ptext (sLit "\t.bss\n\t.align 3")
-
-pprSectionHeader ReadOnlyData16
- = ptext (sLit "\t.data\n\t.align 4")
-
-pprSectionHeader (OtherSection sec)
- = panic "PprMach.pprSectionHeader: unknown section"
-
-
-pprTypeAndSizeDecl :: CLabel -> Doc
-pprTypeAndSizeDecl lbl
- = empty
-
-
-
-pprInstr :: Instr -> Doc
-
-pprInstr (DELTA d)
- = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
-
-pprInstr (NEWBLOCK _)
- = panic "PprMach.pprInstr: NEWBLOCK"
-
-pprInstr (LDATA _ _)
- = panic "PprMach.pprInstr: LDATA"
-
-pprInstr (SPILL reg slot)
- = hcat [
- ptext (sLit "\tSPILL"),
- char '\t',
- pprReg reg,
- comma,
- ptext (sLit "SLOT") <> parens (int slot)]
-
-pprInstr (RELOAD slot reg)
- = hcat [
- ptext (sLit "\tRELOAD"),
- char '\t',
- ptext (sLit "SLOT") <> parens (int slot),
- comma,
- pprReg reg]
-
-pprInstr (LD size reg addr)
- = hcat [
- ptext (sLit "\tld"),
- pprSize size,
- char '\t',
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (LDA reg addr)
- = hcat [
- ptext (sLit "\tlda\t"),
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (LDAH reg addr)
- = hcat [
- ptext (sLit "\tldah\t"),
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (LDGP reg addr)
- = hcat [
- ptext (sLit "\tldgp\t"),
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (LDI size reg imm)
- = hcat [
- ptext (sLit "\tldi"),
- pprSize size,
- char '\t',
- pprReg reg,
- comma,
- pprImm imm
- ]
-
-pprInstr (ST size reg addr)
- = hcat [
- ptext (sLit "\tst"),
- pprSize size,
- char '\t',
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (CLR reg)
- = hcat [
- ptext (sLit "\tclr\t"),
- pprReg reg
- ]
-
-pprInstr (ABS size ri reg)
- = hcat [
- ptext (sLit "\tabs"),
- pprSize size,
- char '\t',
- pprRI ri,
- comma,
- pprReg reg
- ]
-
-pprInstr (NEG size ov ri reg)
- = hcat [
- ptext (sLit "\tneg"),
- pprSize size,
- if ov then ptext (sLit "v\t") else char '\t',
- pprRI ri,
- comma,
- pprReg reg
- ]
-
-pprInstr (ADD size ov reg1 ri reg2)
- = hcat [
- ptext (sLit "\tadd"),
- pprSize size,
- if ov then ptext (sLit "v\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (SADD size scale reg1 ri reg2)
- = hcat [
- ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
- ptext (sLit "add"),
- pprSize size,
- char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (SUB size ov reg1 ri reg2)
- = hcat [
- ptext (sLit "\tsub"),
- pprSize size,
- if ov then ptext (sLit "v\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (SSUB size scale reg1 ri reg2)
- = hcat [
- ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}),
- ptext (sLit "sub"),
- pprSize size,
- char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (MUL size ov reg1 ri reg2)
- = hcat [
- ptext (sLit "\tmul"),
- pprSize size,
- if ov then ptext (sLit "v\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (DIV size uns reg1 ri reg2)
- = hcat [
- ptext (sLit "\tdiv"),
- pprSize size,
- if uns then ptext (sLit "u\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (REM size uns reg1 ri reg2)
- = hcat [
- ptext (sLit "\trem"),
- pprSize size,
- if uns then ptext (sLit "u\t") else char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (NOT ri reg)
- = hcat [
- ptext (sLit "\tnot"),
- char '\t',
- pprRI ri,
- comma,
- pprReg reg
- ]
-
-pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2
-pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2
-pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2
-pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2
-pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2
-pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2
-
-pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2
-pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2
-pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2
-
-pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2
-pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2
-
-pprInstr (NOP) = ptext (sLit "\tnop")
-
-pprInstr (CMP cond reg1 ri reg2)
- = hcat [
- ptext (sLit "\tcmp"),
- pprCond cond,
- char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprInstr (FCLR reg)
- = hcat [
- ptext (sLit "\tfclr\t"),
- pprReg reg
- ]
-
-pprInstr (FABS reg1 reg2)
- = hcat [
- ptext (sLit "\tfabs\t"),
- pprReg reg1,
- comma,
- pprReg reg2
- ]
-
-pprInstr (FNEG size reg1 reg2)
- = hcat [
- ptext (sLit "\tneg"),
- pprSize size,
- char '\t',
- pprReg reg1,
- comma,
- pprReg reg2
- ]
-
-pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3
-pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3
-pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3
-pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3
-
-pprInstr (CVTxy size1 size2 reg1 reg2)
- = hcat [
- ptext (sLit "\tcvt"),
- pprSize size1,
- case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2},
- char '\t',
- pprReg reg1,
- comma,
- pprReg reg2
- ]
-
-pprInstr (FCMP size cond reg1 reg2 reg3)
- = hcat [
- ptext (sLit "\tcmp"),
- pprSize size,
- pprCond cond,
- char '\t',
- pprReg reg1,
- comma,
- pprReg reg2,
- comma,
- pprReg reg3
- ]
-
-pprInstr (FMOV reg1 reg2)
- = hcat [
- ptext (sLit "\tfmov\t"),
- pprReg reg1,
- comma,
- pprReg reg2
- ]
-
-pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab)
-
-pprInstr (BI NEVER reg lab) = empty
-
-pprInstr (BI cond reg lab)
- = hcat [
- ptext (sLit "\tb"),
- pprCond cond,
- char '\t',
- pprReg reg,
- comma,
- pprImm lab
- ]
-
-pprInstr (BF cond reg lab)
- = hcat [
- ptext (sLit "\tfb"),
- pprCond cond,
- char '\t',
- pprReg reg,
- comma,
- pprImm lab
- ]
-
-pprInstr (BR lab)
- = (<>) (ptext (sLit "\tbr\t")) (pprImm lab)
-
-pprInstr (JMP reg addr hint)
- = hcat [
- ptext (sLit "\tjmp\t"),
- pprReg reg,
- comma,
- pprAddr addr,
- comma,
- int hint
- ]
-
-pprInstr (BSR imm n)
- = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm)
-
-pprInstr (JSR reg addr n)
- = hcat [
- ptext (sLit "\tjsr\t"),
- pprReg reg,
- comma,
- pprAddr addr
- ]
-
-pprInstr (FUNBEGIN clab)
- = hcat [
- if (externallyVisibleCLabel clab) then
- hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n']
- else
- empty,
- ptext (sLit "\t.ent "),
- pp_lab,
- char '\n',
- pp_lab,
- pp_ldgp,
- pp_lab,
- pp_frame
- ]
- where
- pp_lab = pprCLabel_asm clab
-
- -- NEVER use commas within those string literals, cpp will ruin your day
- pp_ldgp = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ]
- pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',',
- ptext (sLit "4240"), char ',',
- ptext (sLit "$26"), char ',',
- ptext (sLit "0\n\t.prologue 1") ]
-
-pprInstr (FUNEND clab)
- = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab)
-
-
-pprRI :: RI -> Doc
-
-pprRI (RIReg r) = pprReg r
-pprRI (RIImm r) = pprImm r
-
-pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc
-pprRegRIReg name reg1 ri reg2
- = hcat [
- char '\t',
- ptext name,
- char '\t',
- pprReg reg1,
- comma,
- pprRI ri,
- comma,
- pprReg reg2
- ]
-
-pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
-pprSizeRegRegReg name size reg1 reg2 reg3
- = hcat [
- char '\t',
- ptext name,
- pprSize size,
- char '\t',
- pprReg reg1,
- comma,
- pprReg reg2,
- comma,
- pprReg reg3
- ]
-
--}
-
-
-
+++ /dev/null
-
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 1996-2004
---
------------------------------------------------------------------------------
-
-module Alpha.RegInfo (
-{-
- RegUsage(..),
- noUsage,
- regUsage,
- patchRegs,
- jumpDests,
- isJumpish,
- patchJump,
- isRegRegMove,
-
- JumpDest, canShortcut, shortcutJump, shortcutStatic,
-
- maxSpillSlots,
- mkSpillInstr,
- mkLoadInstr,
- mkRegRegMoveInstr,
- mkBranchInstr
--}
-)
-
-where
-
-{-
-#include "nativeGen/NCG.h"
-#include "HsVersions.h"
-
-
-import BlockId
-import Cmm
-import CLabel
-import Instrs
-import Regs
-import Outputable
-import Constants ( rESERVED_C_STACK_BYTES )
-import FastBool
-
-data RegUsage = RU [Reg] [Reg]
-
-noUsage :: RegUsage
-noUsage = RU [] []
-
-regUsage :: Instr -> RegUsage
-
-regUsage instr = case instr of
- SPILL reg slot -> usage ([reg], [])
- RELOAD slot reg -> usage ([], [reg])
- LD B reg addr -> usage (regAddr addr, [reg, t9])
- LD Bu reg addr -> usage (regAddr addr, [reg, t9])
--- LD W reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED
--- LD Wu reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED
- LD sz reg addr -> usage (regAddr addr, [reg])
- LDA reg addr -> usage (regAddr addr, [reg])
- LDAH reg addr -> usage (regAddr addr, [reg])
- LDGP reg addr -> usage (regAddr addr, [reg])
- LDI sz reg imm -> usage ([], [reg])
- ST B reg addr -> usage (reg : regAddr addr, [t9, t10])
--- ST W reg addr -> usage (reg : regAddr addr, [t9, t10]) : UNUSED
- ST sz reg addr -> usage (reg : regAddr addr, [])
- CLR reg -> usage ([], [reg])
- ABS sz ri reg -> usage (regRI ri, [reg])
- NEG sz ov ri reg -> usage (regRI ri, [reg])
- ADD sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SADD sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SUB sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SSUB sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2])
- MUL sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2])
- DIV sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12])
- REM sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12])
- NOT ri reg -> usage (regRI ri, [reg])
- AND r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ANDNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
- OR r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
- XOR r1 ar r2 -> usage (r1 : regRI ar, [r2])
- XORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SLL r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SRL r1 ar r2 -> usage (r1 : regRI ar, [r2])
- SRA r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ZAP r1 ar r2 -> usage (r1 : regRI ar, [r2])
- ZAPNOT r1 ar r2 -> usage (r1 : regRI ar, [r2])
- CMP co r1 ar r2 -> usage (r1 : regRI ar, [r2])
- FCLR reg -> usage ([], [reg])
- FABS r1 r2 -> usage ([r1], [r2])
- FNEG sz r1 r2 -> usage ([r1], [r2])
- FADD sz r1 r2 r3 -> usage ([r1, r2], [r3])
- FDIV sz r1 r2 r3 -> usage ([r1, r2], [r3])
- FMUL sz r1 r2 r3 -> usage ([r1, r2], [r3])
- FSUB sz r1 r2 r3 -> usage ([r1, r2], [r3])
- CVTxy sz1 sz2 r1 r2 -> usage ([r1], [r2])
- FCMP sz co r1 r2 r3 -> usage ([r1, r2], [r3])
- FMOV r1 r2 -> usage ([r1], [r2])
-
-
- -- We assume that all local jumps will be BI/BF/BR. JMP must be out-of-line.
- BI cond reg lbl -> usage ([reg], [])
- BF cond reg lbl -> usage ([reg], [])
- JMP reg addr hint -> RU (mkRegSet (filter interesting (regAddr addr))) freeRegSet
-
- BSR _ n -> RU (argRegSet n) callClobberedRegSet
- JSR reg addr n -> RU (argRegSet n) callClobberedRegSet
-
- _ -> noUsage
-
- where
- usage (src, dst) = RU (mkRegSet (filter interesting src))
- (mkRegSet (filter interesting dst))
-
- interesting (FixedReg _) = False
- interesting _ = True
-
- regAddr (AddrReg r1) = [r1]
- regAddr (AddrRegImm r1 _) = [r1]
- regAddr (AddrImm _) = []
-
- regRI (RIReg r) = [r]
- regRI _ = []
-
-
-patchRegs :: Instr -> (Reg -> Reg) -> Instr
-patchRegs instr env = case instr of
- SPILL reg slot -> SPILL (env reg) slot
- RELOAD slot reg -> RELOAD slot (env reg)
- LD sz reg addr -> LD sz (env reg) (fixAddr addr)
- LDA reg addr -> LDA (env reg) (fixAddr addr)
- LDAH reg addr -> LDAH (env reg) (fixAddr addr)
- LDGP reg addr -> LDGP (env reg) (fixAddr addr)
- LDI sz reg imm -> LDI sz (env reg) imm
- ST sz reg addr -> ST sz (env reg) (fixAddr addr)
- CLR reg -> CLR (env reg)
- ABS sz ar reg -> ABS sz (fixRI ar) (env reg)
- NEG sz ov ar reg -> NEG sz ov (fixRI ar) (env reg)
- ADD sz ov r1 ar r2 -> ADD sz ov (env r1) (fixRI ar) (env r2)
- SADD sz sc r1 ar r2 -> SADD sz sc (env r1) (fixRI ar) (env r2)
- SUB sz ov r1 ar r2 -> SUB sz ov (env r1) (fixRI ar) (env r2)
- SSUB sz sc r1 ar r2 -> SSUB sz sc (env r1) (fixRI ar) (env r2)
- MUL sz ov r1 ar r2 -> MUL sz ov (env r1) (fixRI ar) (env r2)
- DIV sz un r1 ar r2 -> DIV sz un (env r1) (fixRI ar) (env r2)
- REM sz un r1 ar r2 -> REM sz un (env r1) (fixRI ar) (env r2)
- NOT ar reg -> NOT (fixRI ar) (env reg)
- AND r1 ar r2 -> AND (env r1) (fixRI ar) (env r2)
- ANDNOT r1 ar r2 -> ANDNOT (env r1) (fixRI ar) (env r2)
- OR r1 ar r2 -> OR (env r1) (fixRI ar) (env r2)
- ORNOT r1 ar r2 -> ORNOT (env r1) (fixRI ar) (env r2)
- XOR r1 ar r2 -> XOR (env r1) (fixRI ar) (env r2)
- XORNOT r1 ar r2 -> XORNOT (env r1) (fixRI ar) (env r2)
- SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2)
- SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2)
- SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2)
- ZAP r1 ar r2 -> ZAP (env r1) (fixRI ar) (env r2)
- ZAPNOT r1 ar r2 -> ZAPNOT (env r1) (fixRI ar) (env r2)
- CMP co r1 ar r2 -> CMP co (env r1) (fixRI ar) (env r2)
- FCLR reg -> FCLR (env reg)
- FABS r1 r2 -> FABS (env r1) (env r2)
- FNEG s r1 r2 -> FNEG s (env r1) (env r2)
- FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3)
- FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3)
- FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3)
- FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3)
- CVTxy s1 s2 r1 r2 -> CVTxy s1 s2 (env r1) (env r2)
- FCMP s co r1 r2 r3 -> FCMP s co (env r1) (env r2) (env r3)
- FMOV r1 r2 -> FMOV (env r1) (env r2)
- BI cond reg lbl -> BI cond (env reg) lbl
- BF cond reg lbl -> BF cond (env reg) lbl
- JMP reg addr hint -> JMP (env reg) (fixAddr addr) hint
- JSR reg addr i -> JSR (env reg) (fixAddr addr) i
- _ -> instr
- where
- fixAddr (AddrReg r1) = AddrReg (env r1)
- fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i
- fixAddr other = other
-
- fixRI (RIReg r) = RIReg (env r)
- fixRI other = other
-
-
-mkSpillInstr
- :: Reg -- register to spill
- -> Int -- current stack delta
- -> Int -- spill slot to use
- -> Instr
-
-mkSpillInstr reg delta slot
- = let off = spillSlotToOffset slot
- in
- -- Alpha: spill below the stack pointer (?)
- ST sz dyn (spRel (- (off `div` 8)))
-
-
-mkLoadInstr
- :: Reg -- register to load
- -> Int -- current stack delta
- -> Int -- spill slot to use
- -> Instr
-mkLoadInstr reg delta slot
- = let off = spillSlotToOffset slot
- in
- LD sz dyn (spRel (- (off `div` 8)))
-
-
-mkBranchInstr
- :: BlockId
- -> [Instr]
-
-mkBranchInstr id = [BR id]
-
--}
-
-
-
-
+++ /dev/null
--- -----------------------------------------------------------------------------
---
--- (c) The University of Glasgow 1994-2004
---
--- Alpha support is rotted and incomplete.
--- -----------------------------------------------------------------------------
-
-
-module Alpha.Regs (
-{-
- Size(..),
- AddrMode(..),
- fits8Bits,
- fReg,
- gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zeroh
--}
-)
-
-where
-
-{-
-#include "nativeGen/NCG.h"
-#include "HsVersions.h"
-#include "../includes/stg/MachRegs.h"
-
-import RegsBase
-
-import BlockId
-import Cmm
-import CLabel ( CLabel, mkMainCapabilityLabel )
-import Pretty
-import Outputable ( Outputable(..), pprPanic, panic )
-import qualified Outputable
-import Unique
-import UniqSet
-import Constants
-import FastTypes
-import FastBool
-import UniqFM
-
-
-data Size
- = B -- byte
- | Bu
--- | W -- word (2 bytes): UNUSED
--- | Wu -- : UNUSED
- | L -- longword (4 bytes)
- | Q -- quadword (8 bytes)
--- | FF -- VAX F-style floating pt: UNUSED
--- | GF -- VAX G-style floating pt: UNUSED
--- | DF -- VAX D-style floating pt: UNUSED
--- | SF -- IEEE single-precision floating pt: UNUSED
- | TF -- IEEE double-precision floating pt
- deriving Eq
-
-
-data AddrMode
- = AddrImm Imm
- | AddrReg Reg
- | AddrRegImm Reg Imm
-
-
-addrOffset :: AddrMode -> Int -> Maybe AddrMode
-addrOffset addr off
- = case addr of
- _ -> panic "MachMisc.addrOffset not defined for Alpha"
-
-fits8Bits :: Integer -> Bool
-fits8Bits i = i >= -256 && i < 256
-
-
--- The Alpha has 64 registers of interest; 32 integer registers and 32 floating
--- point registers. The mapping of STG registers to alpha machine registers
--- is defined in StgRegs.h. We are, of course, prepared for any eventuality.
-
-fReg :: Int -> RegNo
-fReg x = (32 + x)
-
-v0, f0, ra, pv, gp, sp, zeroh :: Reg
-v0 = realReg 0
-f0 = realReg (fReg 0)
-ra = FixedReg ILIT(26)
-pv = t12
-gp = FixedReg ILIT(29)
-sp = FixedReg ILIT(30)
-zeroh = FixedReg ILIT(31) -- "zero" is used in 1.3 (MonadZero method)
-
-t9, t10, t11, t12 :: Reg
-t9 = realReg 23
-t10 = realReg 24
-t11 = realReg 25
-t12 = realReg 27
-
-
-#define f0 32
-#define f1 33
-#define f2 34
-#define f3 35
-#define f4 36
-#define f5 37
-#define f6 38
-#define f7 39
-#define f8 40
-#define f9 41
-#define f10 42
-#define f11 43
-#define f12 44
-#define f13 45
-#define f14 46
-#define f15 47
-#define f16 48
-#define f17 49
-#define f18 50
-#define f19 51
-#define f20 52
-#define f21 53
-#define f22 54
-#define f23 55
-#define f24 56
-#define f25 57
-#define f26 58
-#define f27 59
-#define f28 60
-#define f29 61
-#define f30 62
-#define f31 63
-
-
--- allMachRegs is the complete set of machine regs.
-allMachRegNos :: [RegNo]
-allMachRegNos = [0..63]
-
-
--- these are the regs which we cannot assume stay alive over a
--- C call.
-callClobberedRegs :: [Reg]
-callClobberedRegs
- = [0, 1, 2, 3, 4, 5, 6, 7, 8,
- 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29,
- fReg 0, fReg 1, fReg 10, fReg 11, fReg 12, fReg 13, fReg 14, fReg 15,
- fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21, fReg 22, fReg 23,
- fReg 24, fReg 25, fReg 26, fReg 27, fReg 28, fReg 29, fReg 30]
-
-
--- argRegs is the set of regs which are read for an n-argument call to C.
--- For archs which pass all args on the stack (x86), is empty.
--- Sparc passes up to the first 6 args in regs.
--- Dunno about Alpha.
-argRegs :: RegNo -> [Reg]
-
-argRegs 0 = []
-argRegs 1 = freeMappedRegs [16, fReg 16]
-argRegs 2 = freeMappedRegs [16, 17, fReg 16, fReg 17]
-argRegs 3 = freeMappedRegs [16, 17, 18, fReg 16, fReg 17, fReg 18]
-argRegs 4 = freeMappedRegs [16, 17, 18, 19, fReg 16, fReg 17, fReg 18, fReg 19]
-argRegs 5 = freeMappedRegs [16, 17, 18, 19, 20, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20]
-argRegs 6 = freeMappedRegs [16, 17, 18, 19, 20, 21, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21]
-argRegs _ = panic "MachRegs.argRegs(alpha): don't know about >6 arguments!"
-
-
--- all of the arg regs ??
-allArgRegs :: [(Reg, Reg)]
-allArgRegs = [(realReg i, realReg (fReg i)) | i <- [16..21]]
-
-
--- horror show -----------------------------------------------------------------
-
-freeReg :: RegNo -> FastBool
-
-freeReg 26 = fastBool False -- return address (ra)
-freeReg 28 = fastBool False -- reserved for the assembler (at)
-freeReg 29 = fastBool False -- global pointer (gp)
-freeReg 30 = fastBool False -- stack pointer (sp)
-freeReg 31 = fastBool False -- always zero (zeroh)
-freeReg 63 = fastBool False -- always zero (f31)
-
-#ifdef REG_Base
-freeReg REG_Base = fastBool False
-#endif
-#ifdef REG_R1
-freeReg REG_R1 = fastBool False
-#endif
-#ifdef REG_R2
-freeReg REG_R2 = fastBool False
-#endif
-#ifdef REG_R3
-freeReg REG_R3 = fastBool False
-#endif
-#ifdef REG_R4
-freeReg REG_R4 = fastBool False
-#endif
-#ifdef REG_R5
-freeReg REG_R5 = fastBool False
-#endif
-#ifdef REG_R6
-freeReg REG_R6 = fastBool False
-#endif
-#ifdef REG_R7
-freeReg REG_R7 = fastBool False
-#endif
-#ifdef REG_R8
-freeReg REG_R8 = fastBool False
-#endif
-#ifdef REG_F1
-freeReg REG_F1 = fastBool False
-#endif
-#ifdef REG_F2
-freeReg REG_F2 = fastBool False
-#endif
-#ifdef REG_F3
-freeReg REG_F3 = fastBool False
-#endif
-#ifdef REG_F4
-freeReg REG_F4 = fastBool False
-#endif
-#ifdef REG_D1
-freeReg REG_D1 = fastBool False
-#endif
-#ifdef REG_D2
-freeReg REG_D2 = fastBool False
-#endif
-#ifdef REG_Sp
-freeReg REG_Sp = fastBool False
-#endif
-#ifdef REG_Su
-freeReg REG_Su = fastBool False
-#endif
-#ifdef REG_SpLim
-freeReg REG_SpLim = fastBool False
-#endif
-#ifdef REG_Hp
-freeReg REG_Hp = fastBool False
-#endif
-#ifdef REG_HpLim
-freeReg REG_HpLim = fastBool False
-#endif
-freeReg n = fastBool True
-
-
--- | Returns 'Nothing' if this global register is not stored
--- in a real machine register, otherwise returns @'Just' reg@, where
--- reg is the machine register it is stored in.
-
-globalRegMaybe :: GlobalReg -> Maybe Reg
-
-#ifdef REG_Base
-globalRegMaybe BaseReg = Just (RealReg REG_Base)
-#endif
-#ifdef REG_R1
-globalRegMaybe (VanillaReg 1 _) = Just (RealReg REG_R1)
-#endif
-#ifdef REG_R2
-globalRegMaybe (VanillaReg 2 _) = Just (RealReg REG_R2)
-#endif
-#ifdef REG_R3
-globalRegMaybe (VanillaReg 3 _) = Just (RealReg REG_R3)
-#endif
-#ifdef REG_R4
-globalRegMaybe (VanillaReg 4 _) = Just (RealReg REG_R4)
-#endif
-#ifdef REG_R5
-globalRegMaybe (VanillaReg 5 _) = Just (RealReg REG_R5)
-#endif
-#ifdef REG_R6
-globalRegMaybe (VanillaReg 6 _) = Just (RealReg REG_R6)
-#endif
-#ifdef REG_R7
-globalRegMaybe (VanillaReg 7 _) = Just (RealReg REG_R7)
-#endif
-#ifdef REG_R8
-globalRegMaybe (VanillaReg 8 _) = Just (RealReg REG_R8)
-#endif
-#ifdef REG_R9
-globalRegMaybe (VanillaReg 9 _) = Just (RealReg REG_R9)
-#endif
-#ifdef REG_R10
-globalRegMaybe (VanillaReg 10 _) = Just (RealReg REG_R10)
-#endif
-#ifdef REG_F1
-globalRegMaybe (FloatReg 1) = Just (RealReg REG_F1)
-#endif
-#ifdef REG_F2
-globalRegMaybe (FloatReg 2) = Just (RealReg REG_F2)
-#endif
-#ifdef REG_F3
-globalRegMaybe (FloatReg 3) = Just (RealReg REG_F3)
-#endif
-#ifdef REG_F4
-globalRegMaybe (FloatReg 4) = Just (RealReg REG_F4)
-#endif
-#ifdef REG_D1
-globalRegMaybe (DoubleReg 1) = Just (RealReg REG_D1)
-#endif
-#ifdef REG_D2
-globalRegMaybe (DoubleReg 2) = Just (RealReg REG_D2)
-#endif
-#ifdef REG_Sp
-globalRegMaybe Sp = Just (RealReg REG_Sp)
-#endif
-#ifdef REG_Lng1
-globalRegMaybe (LongReg 1) = Just (RealReg REG_Lng1)
-#endif
-#ifdef REG_Lng2
-globalRegMaybe (LongReg 2) = Just (RealReg REG_Lng2)
-#endif
-#ifdef REG_SpLim
-globalRegMaybe SpLim = Just (RealReg REG_SpLim)
-#endif
-#ifdef REG_Hp
-globalRegMaybe Hp = Just (RealReg REG_Hp)
-#endif
-#ifdef REG_HpLim
-globalRegMaybe HpLim = Just (RealReg REG_HpLim)
-#endif
-#ifdef REG_CurrentTSO
-globalRegMaybe CurrentTSO = Just (RealReg REG_CurrentTSO)
-#endif
-#ifdef REG_CurrentNursery
-globalRegMaybe CurrentNursery = Just (RealReg REG_CurrentNursery)
-#endif
-globalRegMaybe _ = Nothing
-
--}
#include "nativeGen/NCG.h"
-#if alpha_TARGET_ARCH
-import Alpha.CodeGen
-import Alpha.Regs
-import Alpha.RegInfo
-import Alpha.Instr
-
-#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
-import X86.CodeGen
-import X86.Regs
-import X86.Instr
-import X86.Ppr
-
-#elif sparc_TARGET_ARCH
-import SPARC.CodeGen
-import SPARC.CodeGen.Expand
-import SPARC.Regs
-import SPARC.Instr
-import SPARC.Ppr
-import SPARC.ShortcutJump
-
-#elif powerpc_TARGET_ARCH
-import PPC.CodeGen
-import PPC.Cond
-import PPC.Regs
-import PPC.RegInfo
-import PPC.Instr
-import PPC.Ppr
-
-#else
-#error "AsmCodeGen: unknown architecture"
-
-#endif
+import qualified X86.CodeGen
+import qualified X86.Regs
+import qualified X86.Instr
+import qualified X86.Ppr
+
+import qualified SPARC.CodeGen
+import qualified SPARC.Regs
+import qualified SPARC.Instr
+import qualified SPARC.Ppr
+import qualified SPARC.ShortcutJump
+import qualified SPARC.CodeGen.Expand
+
+import qualified PPC.CodeGen
+import qualified PPC.Cond
+import qualified PPC.Regs
+import qualified PPC.RegInfo
+import qualified PPC.Instr
+import qualified PPC.Ppr
import RegAlloc.Liveness
import qualified RegAlloc.Linear.Main as Linear
import TargetReg
import Platform
+import Config
import Instruction
import PIC
import Reg
import BlockId
import CgUtils ( fixStgRegisters )
import OldCmm
-import CmmOpt ( cmmMiniInline, cmmMachOpFold )
+import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
import OldPprCmm
import CLabel
import DynFlags
import StaticFlags
import Util
-import Config
import Digraph
+import Pretty (Doc)
import qualified Pretty
import BufWrite
import Outputable
import Data.Maybe
import Control.Monad
import System.IO
-import Distribution.System
{-
The native-code generator has machine-independent and
-- -----------------------------------------------------------------------------
-- Top-level of the native codegen
+data NcgImpl instr jumpDest = NcgImpl {
+ cmmTopCodeGen :: DynFlags -> RawCmmTop -> NatM [NatCmmTop instr],
+ generateJumpTableForInstr :: instr -> Maybe (NatCmmTop instr),
+ getJumpDestBlockId :: jumpDest -> Maybe BlockId,
+ canShortcut :: instr -> Maybe jumpDest,
+ shortcutStatic :: (BlockId -> Maybe jumpDest) -> CmmStatic -> CmmStatic,
+ shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
+ pprNatCmmTop :: NatCmmTop instr -> Doc,
+ maxSpillSlots :: Int,
+ allocatableRegs :: [RealReg],
+ ncg_x86fp_kludge :: [NatCmmTop instr] -> [NatCmmTop instr],
+ ncgExpandTop :: [NatCmmTop instr] -> [NatCmmTop instr],
+ ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr]
+ }
+
--------------------
nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
nativeCodeGen dflags h us cmms
+ = let nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
+ x86NcgImpl = NcgImpl {
+ cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
+ ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
+ ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId
+ ,canShortcut = X86.Instr.canShortcut
+ ,shortcutStatic = X86.Instr.shortcutStatic
+ ,shortcutJump = X86.Instr.shortcutJump
+ ,pprNatCmmTop = X86.Ppr.pprNatCmmTop
+ ,maxSpillSlots = X86.Instr.maxSpillSlots
+ ,allocatableRegs = X86.Regs.allocatableRegs
+ ,ncg_x86fp_kludge = id
+ ,ncgExpandTop = id
+ ,ncgMakeFarBranches = id
+ }
+ in case platformArch $ targetPlatform dflags of
+ ArchX86 -> nCG' (x86NcgImpl { ncg_x86fp_kludge = map x86fp_kludge })
+ ArchX86_64 -> nCG' x86NcgImpl
+ ArchPPC ->
+ nCG' $ NcgImpl {
+ cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
+ ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
+ ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId
+ ,canShortcut = PPC.RegInfo.canShortcut
+ ,shortcutStatic = PPC.RegInfo.shortcutStatic
+ ,shortcutJump = PPC.RegInfo.shortcutJump
+ ,pprNatCmmTop = PPC.Ppr.pprNatCmmTop
+ ,maxSpillSlots = PPC.Instr.maxSpillSlots
+ ,allocatableRegs = PPC.Regs.allocatableRegs
+ ,ncg_x86fp_kludge = id
+ ,ncgExpandTop = id
+ ,ncgMakeFarBranches = makeFarBranches
+ }
+ ArchSPARC ->
+ nCG' $ NcgImpl {
+ cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
+ ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
+ ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId
+ ,canShortcut = SPARC.ShortcutJump.canShortcut
+ ,shortcutStatic = SPARC.ShortcutJump.shortcutStatic
+ ,shortcutJump = SPARC.ShortcutJump.shortcutJump
+ ,pprNatCmmTop = SPARC.Ppr.pprNatCmmTop
+ ,maxSpillSlots = SPARC.Instr.maxSpillSlots
+ ,allocatableRegs = SPARC.Regs.allocatableRegs
+ ,ncg_x86fp_kludge = id
+ ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
+ ,ncgMakeFarBranches = id
+ }
+ ArchPPC_64 ->
+ panic "nativeCodeGen: No NCG for PPC 64"
+
+nativeCodeGen' :: (Instruction instr, Outputable instr)
+ => DynFlags
+ -> NcgImpl instr jumpDest
+ -> Handle -> UniqSupply -> [RawCmm] -> IO ()
+nativeCodeGen' dflags ncgImpl h us cmms
= do
let split_cmms = concat $ map add_split cmms
-
-- BufHandle is a performance hack. We could hide it inside
-- Pretty if it weren't for the fact that we do lots of little
-- printDocs here (in order to do codegen in constant space).
bufh <- newBufHandle h
- (imports, prof) <- cmmNativeGens dflags bufh us split_cmms [] [] 0
+ (imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0
bFlush bufh
let (native, colorStats, linearStats)
-- dump native code
dumpIfSet_dyn dflags
Opt_D_dump_asm "Asm code"
- (vcat $ map (docToSDoc . pprNatCmmTop) $ concat native)
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) $ concat native)
-- dump global NCG stats for graph coloring allocator
(case concat $ catMaybes colorStats of
-- | Do native code generation on all these cmms.
--
-cmmNativeGens :: DynFlags
+cmmNativeGens :: (Instruction instr, Outputable instr)
+ => DynFlags
+ -> NcgImpl instr jumpDest
-> BufHandle
-> UniqSupply
-> [RawCmmTop]
-> [[CLabel]]
- -> [ ([NatCmmTop Instr],
- Maybe [Color.RegAllocStats Instr],
+ -> [ ([NatCmmTop instr],
+ Maybe [Color.RegAllocStats instr],
Maybe [Linear.RegAllocStats]) ]
-> Int
-> IO ( [[CLabel]],
- [([NatCmmTop Instr],
- Maybe [Color.RegAllocStats Instr],
+ [([NatCmmTop instr],
+ Maybe [Color.RegAllocStats instr],
Maybe [Linear.RegAllocStats])] )
-cmmNativeGens _ _ _ [] impAcc profAcc _
+cmmNativeGens _ _ _ _ [] impAcc profAcc _
= return (reverse impAcc, reverse profAcc)
-cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
+cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
= do
(us', native, imports, colorStats, linearStats)
- <- cmmNativeGen dflags us cmm count
+ <- cmmNativeGen dflags ncgImpl us cmm count
Pretty.bufLeftRender h
- $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native
+ $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmTop ncgImpl) native
-- carefully evaluate this strictly. Binding it with 'let'
-- and then using 'seq' doesn't work, because the let
-- force evaulation all this stuff to avoid space leaks
seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
- cmmNativeGens dflags h us' cmms
+ cmmNativeGens dflags ncgImpl
+ h us' cmms
(imports : impAcc)
((lsPprNative, colorStats, linearStats) : profAcc)
count'
-- | Complete native code generation phase for a single top-level chunk of Cmm.
-- Dumping the output of each stage along the way.
-- Global conflict graph and NGC stats
-cmmNativeGen
- :: DynFlags
+cmmNativeGen
+ :: (Instruction instr, Outputable instr)
+ => DynFlags
+ -> NcgImpl instr jumpDest
-> UniqSupply
-> RawCmmTop -- ^ the cmm to generate code for
-> Int -- ^ sequence number of this top thing
-> IO ( UniqSupply
- , [NatCmmTop Instr] -- native code
+ , [NatCmmTop instr] -- native code
, [CLabel] -- things imported by this cmm
- , Maybe [Color.RegAllocStats Instr] -- stats for the coloring register allocator
+ , Maybe [Color.RegAllocStats instr] -- stats for the coloring register allocator
, Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
-cmmNativeGen dflags us cmm count
+cmmNativeGen dflags ncgImpl us cmm count
= do
-- rewrite assignments to global regs
-- generate native code from cmm
let ((native, lastMinuteImports), usGen) =
{-# SCC "genMachCode" #-}
- initUs us $ genMachCode dflags opt_cmm
+ initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
dumpIfSet_dyn dflags
Opt_D_dump_asm_native "Native code"
- (vcat $ map (docToSDoc . pprNatCmmTop) native)
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) native)
-- tag instructions with register liveness information
let (withLiveness, usLive) =
= foldr (\r -> plusUFM_C unionUniqSets
$ unitUFM (targetClassOfRealReg r) (unitUniqSet r))
emptyUFM
- $ allocatableRegs
+ $ allocatableRegs ncgImpl
-- do the graph coloring register allocation
let ((alloced, regAllocStats), usAlloc)
$ Color.regAlloc
dflags
alloc_regs
- (mkUniqSet [0..maxSpillSlots])
+ (mkUniqSet [0 .. maxSpillSlots ncgImpl])
withLiveness
-- dump out what happened during register allocation
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
- (vcat $ map (docToSDoc . pprNatCmmTop) alloced)
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced)
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc_stages "Build/spill stages"
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
- (vcat $ map (docToSDoc . pprNatCmmTop) alloced)
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced)
let mPprStats =
if dopt Opt_D_dump_asm_stats dflags
, Nothing
, mPprStats)
+ ---- x86fp_kludge. This pass inserts ffree instructions to clear
+ ---- the FPU stack on x86. The x86 ABI requires that the FPU stack
+ ---- is clear, and library functions can return odd results if it
+ ---- isn't.
+ ----
+ ---- NB. must happen before shortcutBranches, because that
+ ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
+ let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
+
+ ---- generate jump tables
+ let tabled =
+ {-# SCC "generateJumpTables" #-}
+ generateJumpTables ncgImpl kludged
+
---- shortcut branches
let shorted =
{-# SCC "shortcutBranches" #-}
- shortcutBranches dflags alloced
+ shortcutBranches dflags ncgImpl tabled
---- sequence blocks
let sequenced =
{-# SCC "sequenceBlocks" #-}
- map sequenceTop shorted
-
- ---- x86fp_kludge
- let kludged =
-#if i386_TARGET_ARCH
- {-# SCC "x86fp_kludge" #-}
- map x86fp_kludge sequenced
-#else
- sequenced
-#endif
+ map (sequenceTop ncgImpl) shorted
- ---- expansion of SPARC synthetic instrs
-#if sparc_TARGET_ARCH
+ ---- expansion of SPARC synthetic instrs
let expanded =
{-# SCC "sparc_expand" #-}
- map expandTop kludged
+ ncgExpandTop ncgImpl sequenced
dumpIfSet_dyn dflags
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
- (vcat $ map (docToSDoc . pprNatCmmTop) expanded)
-#else
- let expanded =
- kludged
-#endif
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) expanded)
return ( usAlloc
, expanded
, ppr_raStatsLinear)
-#if i386_TARGET_ARCH
-x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr
+x86fp_kludge :: NatCmmTop X86.Instr.Instr -> NatCmmTop X86.Instr.Instr
x86fp_kludge top@(CmmData _ _) = top
x86fp_kludge (CmmProc info lbl (ListGraph code)) =
- CmmProc info lbl (ListGraph $ i386_insert_ffrees code)
-#endif
+ CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
-- | Build a doc for all the imports.
-- stack so add the note in:
Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
#endif
-#if !defined(darwin_TARGET_OS)
-- And just because every other compiler does, lets stick in
-- an identifier directive: .ident "GHC x.y.z"
- Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
+ Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
Pretty.text cProjectVersion
in Pretty.text ".ident" Pretty.<+>
Pretty.doubleQuotes compilerIdent
-#endif
where
-- Generate "symbol stubs" for all external symbols that might
| otherwise
= Pretty.empty
- doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
+ doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle)
astyle = mkCodeStyle AsmStyle
-- fallthroughs.
sequenceTop
- :: NatCmmTop Instr
- -> NatCmmTop Instr
+ :: Instruction instr
+ => NcgImpl instr jumpDest -> NatCmmTop instr -> NatCmmTop instr
-sequenceTop top@(CmmData _ _) = top
-sequenceTop (CmmProc info lbl (ListGraph blocks)) =
- CmmProc info lbl (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
+sequenceTop _ top@(CmmData _ _) = top
+sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
+ CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
-- The algorithm is very simple (and stupid): we make a graph out of
-- the blocks where there is an edge from one block to another iff the
-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
-- big, we have to work around this limitation.
-makeFarBranches
- :: [NatBasicBlock Instr]
- -> [NatBasicBlock Instr]
-
-#if powerpc_TARGET_ARCH
+makeFarBranches
+ :: [NatBasicBlock PPC.Instr.Instr]
+ -> [NatBasicBlock PPC.Instr.Instr]
makeFarBranches blocks
| last blockAddresses < nearLimit = blocks
| otherwise = zipWith handleBlock blockAddresses blocks
handleBlock addr (BasicBlock id instrs)
= BasicBlock id (zipWith makeFar [addr..] instrs)
- makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt
- makeFar addr (BCC cond tgt)
+ makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt
+ makeFar addr (PPC.Instr.BCC cond tgt)
| abs (addr - targetAddr) >= nearLimit
- = BCCFAR cond tgt
+ = PPC.Instr.BCCFAR cond tgt
| otherwise
- = BCC cond tgt
+ = PPC.Instr.BCC cond tgt
where Just targetAddr = lookupUFM blockAddressMap tgt
makeFar _ other = other
-- things exactly
blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
-#else
-makeFarBranches = id
-#endif
+
+-- -----------------------------------------------------------------------------
+-- Generate jump tables
+
+-- Analyzes all native code and generates data sections for all jump
+-- table instructions.
+generateJumpTables
+ :: NcgImpl instr jumpDest
+ -> [NatCmmTop instr] -> [NatCmmTop instr]
+generateJumpTables ncgImpl xs = concatMap f xs
+ where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
+ f p = [p]
+ g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
-- -----------------------------------------------------------------------------
-- Shortcut branches
-shortcutBranches
- :: DynFlags
- -> [NatCmmTop Instr]
- -> [NatCmmTop Instr]
+shortcutBranches
+ :: DynFlags
+ -> NcgImpl instr jumpDest
+ -> [NatCmmTop instr]
+ -> [NatCmmTop instr]
-shortcutBranches dflags tops
+shortcutBranches dflags ncgImpl tops
| optLevel dflags < 1 = tops -- only with -O or higher
- | otherwise = map (apply_mapping mapping) tops'
+ | otherwise = map (apply_mapping ncgImpl mapping) tops'
where
- (tops', mappings) = mapAndUnzip build_mapping tops
+ (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
mapping = foldr plusUFM emptyUFM mappings
-build_mapping :: GenCmmTop d t (ListGraph Instr)
- -> (GenCmmTop d t (ListGraph Instr), UniqFM JumpDest)
-build_mapping top@(CmmData _ _) = (top, emptyUFM)
-build_mapping (CmmProc info lbl (ListGraph []))
+build_mapping :: NcgImpl instr jumpDest
+ -> GenCmmTop d t (ListGraph instr)
+ -> (GenCmmTop d t (ListGraph instr), UniqFM jumpDest)
+build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
+build_mapping _ (CmmProc info lbl (ListGraph []))
= (CmmProc info lbl (ListGraph []), emptyUFM)
-build_mapping (CmmProc info lbl (ListGraph (head:blocks)))
+build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
= (CmmProc info lbl (ListGraph (head:others)), mapping)
-- drop the shorted blocks, but don't ever drop the first one,
-- because it is pointed to by a global label.
-- Don't completely eliminate loops here -- that can leave a dangling jump!
(_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
- | Just (DestBlockId dest) <- canShortcut insn,
+ | Just jd <- canShortcut ncgImpl insn,
+ Just dest <- getJumpDestBlockId ncgImpl jd,
(setMember dest s) || dest == id -- loop checks
= (s, shortcut_blocks, b : others)
split (s, shortcut_blocks, others) (BasicBlock id [insn])
- | Just dest <- canShortcut insn
+ | Just dest <- canShortcut ncgImpl insn
= (setInsert id s, (id,dest) : shortcut_blocks, others)
split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
mapping = foldl add emptyUFM shortcut_blocks
add ufm (id,dest) = addToUFM ufm id dest
-apply_mapping :: UniqFM JumpDest
- -> GenCmmTop CmmStatic h (ListGraph Instr)
- -> GenCmmTop CmmStatic h (ListGraph Instr)
-apply_mapping ufm (CmmData sec statics)
- = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
+apply_mapping :: NcgImpl instr jumpDest
+ -> UniqFM jumpDest
+ -> GenCmmTop CmmStatic h (ListGraph instr)
+ -> GenCmmTop CmmStatic h (ListGraph instr)
+apply_mapping ncgImpl ufm (CmmData sec statics)
+ = CmmData sec (map (shortcutStatic ncgImpl (lookupUFM ufm)) statics)
-- we need to get the jump tables, so apply the mapping to the entries
-- of a CmmData too.
-apply_mapping ufm (CmmProc info lbl (ListGraph blocks))
+apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
= CmmProc info lbl (ListGraph $ map short_bb blocks)
where
short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
- short_insn i = shortcutJump (lookupUFM ufm) i
+ short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i
-- shortcutJump should apply the mapping repeatedly,
-- just in case we can short multiple branches.
genMachCode
:: DynFlags
+ -> (DynFlags -> RawCmmTop -> NatM [NatCmmTop instr])
-> RawCmmTop
-> UniqSM
- ( [NatCmmTop Instr]
+ ( [NatCmmTop instr]
, [CLabel])
-genMachCode dflags cmm_top
+genMachCode dflags cmmTopCodeGen cmm_top
= do { initial_us <- getUs
; let initial_st = mkNatM_State initial_us 0 dflags
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen dflags cmm_top)
and position independent refs
(ii) compile a list of imported symbols
-Ideas for other things we could do (ToDo):
+Ideas for other things we could do:
- shortcut jumps-to-jumps
- - eliminate dead code blocks
- simple CSE: if an expr is assigned to a temp, then replace later occs of
that expr with the temp, until the expr is no longer valid (can push through
temp assignments, and certain assigns to mem...)
cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
cmmToCmm _ top@(CmmData _ _) = (top, [])
cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
- blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
+ blocks' <- mapM cmmBlockConFold (cmmMiniInline (cmmEliminateDeadBlocks blocks))
return $ CmmProc info lbl (ListGraph blocks')
newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
-cmmExprConFold referenceKind expr
- = case expr of
+cmmExprConFold referenceKind expr = do
+ dflags <- getDynFlagsCmmOpt
+ let arch = platformArch (targetPlatform dflags)
+ case expr of
CmmLoad addr rep
-> do addr' <- cmmExprConFold DataReference addr
return $ CmmLoad addr' rep
CmmLit (CmmLabel lbl)
-> do
- dflags <- getDynFlagsCmmOpt
cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
CmmLit (CmmLabelOff lbl off)
-> do
- dflags <- getDynFlagsCmmOpt
dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
return $ cmmMachOpFold (MO_Add wordWidth) [
dynRef,
-- to use the register table, so we replace these registers
-- with the corresponding labels:
CmmReg (CmmGlobal EagerBlackholeInfo)
- | cTargetArch == PPC && not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
- | cTargetArch == PPC && not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
- | cTargetArch == PPC && not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
module PPC.CodeGen (
cmmTopCodeGen,
+ generateJumpTableForInstr,
InstrBlock
)
genJump tree
= do
(target,code) <- getSomeReg tree
- return (code `snocOL` MTCTR target `snocOL` BCTR [])
+ return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing)
-- -----------------------------------------------------------------------------
dflags <- getDynFlagsNat
dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
- let
- jumpTable = map jumpTableEntryRel ids
-
- jumpTableEntryRel Nothing
- = CmmStaticLit (CmmInt 0 wordWidth)
- jumpTableEntryRel (Just blockid)
- = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
- where blockLabel = mkAsmTempLabel (getUnique blockid)
-
- code = e_code `appOL` t_code `appOL` toOL [
- LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+ let code = e_code `appOL` t_code `appOL` toOL [
SLW tmp reg (RIImm (ImmInt 2)),
LD II32 tmp (AddrRegReg tableReg tmp),
ADD tmp tmp (RIReg tableReg),
MTCTR tmp,
- BCTR [ id | Just id <- ids ]
+ BCTR ids (Just lbl)
]
return code
| otherwise
(reg,e_code) <- getSomeReg expr
tmp <- getNewRegNat II32
lbl <- getNewLabelNat
- let
- jumpTable = map jumpTableEntry ids
-
- code = e_code `appOL` toOL [
- LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
+ let code = e_code `appOL` toOL [
SLW tmp reg (RIImm (ImmInt 2)),
ADDIS tmp tmp (HA (ImmCLbl lbl)),
LD II32 tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
MTCTR tmp,
- BCTR [ id | Just id <- ids ]
+ BCTR ids (Just lbl)
]
return code
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (BCTR ids (Just lbl)) =
+ let jumpTable
+ | opt_PIC = map jumpTableEntryRel ids
+ | otherwise = map jumpTableEntry ids
+ where jumpTableEntryRel Nothing
+ = CmmStaticLit (CmmInt 0 wordWidth)
+ jumpTableEntryRel (Just blockid)
+ = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
+ where blockLabel = mkAsmTempLabel (getUnique blockid)
+ in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable))
+generateJumpTableForInstr _ = Nothing
-- -----------------------------------------------------------------------------
-- 'condIntReg' and 'condFltReg': condition codes into registers
| JMP CLabel -- same as branch,
-- but with CLabel instead of block ID
| MTCTR Reg
- | BCTR [BlockId] -- with list of local destinations
+ | BCTR [Maybe BlockId] (Maybe CLabel) -- with list of local destinations, and jump table location if necessary
| BL CLabel [Reg] -- with list of argument regs
| BCTRL [Reg]
BCC _ _ -> noUsage
BCCFAR _ _ -> noUsage
MTCTR reg -> usage ([reg],[])
- BCTR _ -> noUsage
+ BCTR _ _ -> noUsage
BL _ params -> usage (params, callClobberedRegs)
BCTRL params -> usage (params, callClobberedRegs)
ADD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
BCC cond lbl -> BCC cond lbl
BCCFAR cond lbl -> BCCFAR cond lbl
MTCTR reg -> MTCTR (env reg)
- BCTR targets -> BCTR targets
+ BCTR targets lbl -> BCTR targets lbl
BL imm argRegs -> BL imm argRegs -- argument regs
BCTRL argRegs -> BCTRL argRegs -- cannot be remapped
ADD reg1 reg2 ri -> ADD (env reg1) (env reg2) (fixRI ri)
= case insn of
BCC _ id -> [id]
BCCFAR _ id -> [id]
- BCTR targets -> targets
+ BCTR targets _ -> [id | Just id <- targets]
_ -> []
= case insn of
BCC cc id -> BCC cc (patchF id)
BCCFAR cc id -> BCCFAR cc (patchF id)
- BCTR _ -> error "Cannot patch BCTR"
+ BCTR ids lbl -> BCTR (map (fmap patchF) ids) lbl
_ -> insn
pprSectionHeader,
pprData,
pprInstr,
- pprUserReg,
pprSize,
pprImm,
pprDataItem,
ppr instr = Outputable.docToSDoc $ pprInstr instr
-pprUserReg :: Reg -> Doc
-pprUserReg = pprReg
-
pprReg :: Reg -> Doc
pprReg r
char '\t',
pprReg reg
]
-pprInstr (BCTR _) = hcat [
+pprInstr (BCTR _ _) = hcat [
char '\t',
ptext (sLit "bctr")
]
-----------------------------------------------------------------------------
module PPC.RegInfo (
- JumpDest( DestBlockId ),
+ JumpDest( DestBlockId ), getJumpDestBlockId,
canShortcut,
shortcutJump,
data JumpDest = DestBlockId BlockId | DestImm Imm
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+getJumpDestBlockId _ = Nothing
+
canShortcut :: Instr -> Maybe JumpDest
canShortcut _ = Nothing
-- argRegs is the set of regs which are read for an n-argument call to C.
-- For archs which pass all args on the stack (x86), is empty.
-- Sparc passes up to the first 6 args in regs.
--- Dunno about Alpha.
argRegs :: RegNo -> [Reg]
argRegs 0 = []
argRegs 1 = map regSingle [3]
_ -> let instr' = patchJumpInstr instr
(\bid -> if bid == dest
then mkBlockId fixup_block_id
- else dest)
+ else bid) -- no change!
in joinToTargets' block_live (block : new_blocks) block_id instr' dests
module SPARC.CodeGen (
cmmTopCodeGen,
+ generateJumpTableForInstr,
InstrBlock
)
dst <- getNewRegNat II32
label <- getNewLabelNat
- let jumpTable = map jumpTableEntry ids
return $ e_code `appOL`
toOL
- -- the jump table
- [ LDATA ReadOnlyData (CmmDataLabel label : jumpTable)
-
- -- load base of jump table
- , SETHI (HI (ImmCLbl label)) base_reg
+ [ -- load base of jump table
+ SETHI (HI (ImmCLbl label)) base_reg
, OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
-- the addrs in the table are 32 bits wide..
-- load and jump to the destination
, LD II32 (AddrRegReg base_reg offset_reg) dst
- , JMP_TBL (AddrRegImm dst (ImmInt 0)) [i | Just i <- ids]
+ , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label
, NOP ]
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (JMP_TBL _ ids label) =
+ let jumpTable = map jumpTableEntry ids
+ in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable))
+generateJumpTableForInstr _ = Nothing
import Reg
import Size
+import CLabel
import BlockId
import OldCmm
import FastString
-- With a tabled jump we know all the possible destinations.
-- We also need this info so we can work out what regs are live across the jump.
--
- | JMP_TBL AddrMode [BlockId]
+ | JMP_TBL AddrMode [Maybe BlockId] CLabel
| CALL (Either Imm Reg) Int Bool -- target, args, terminal
FxTOy _ _ r1 r2 -> usage ([r1], [r2])
JMP addr -> usage (regAddr addr, [])
- JMP_TBL addr _ -> usage (regAddr addr, [])
+ JMP_TBL addr _ _ -> usage (regAddr addr, [])
CALL (Left _ ) _ True -> noUsage
CALL (Left _ ) n False -> usage (argRegs n, callClobberedRegs)
FxTOy s1 s2 r1 r2 -> FxTOy s1 s2 (env r1) (env r2)
JMP addr -> JMP (fixAddr addr)
- JMP_TBL addr ids -> JMP_TBL (fixAddr addr) ids
+ JMP_TBL addr ids l -> JMP_TBL (fixAddr addr) ids l
CALL (Left i) n t -> CALL (Left i) n t
CALL (Right r) n t -> CALL (Right (env r)) n t
= case insn of
BI _ _ id -> [id]
BF _ _ id -> [id]
- JMP_TBL _ ids -> ids
+ JMP_TBL _ ids _ -> [id | Just id <- ids]
_ -> []
= case insn of
BI cc annul id -> BI cc annul (patchF id)
BF cc annul id -> BF cc annul (patchF id)
+ JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l
_ -> insn
pprSectionHeader,
pprData,
pprInstr,
- pprUserReg,
pprSize,
pprImm,
pprDataItem
-- | Pretty print a register.
--- This is an alias of pprReg for legacy reasons, should remove it.
-pprUserReg :: Reg -> Doc
-pprUserReg = pprReg
-
-
--- | Pretty print a register.
pprReg :: Reg -> Doc
pprReg reg
= case reg of
]
pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
-pprInstr (JMP_TBL op _) = pprInstr (JMP op)
+pprInstr (JMP_TBL op _ _) = pprInstr (JMP op)
pprInstr (CALL (Left imm) n _)
= hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ]
module SPARC.ShortcutJump (
- JumpDest(..),
+ JumpDest(..), getJumpDestBlockId,
canShortcut,
shortcutJump,
shortcutStatic,
= DestBlockId BlockId
| DestImm Imm
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+getJumpDestBlockId _ = Nothing
+
canShortcut :: Instr -> Maybe JumpDest
canShortcut _ = Nothing
module X86.CodeGen (
cmmTopCodeGen,
+ generateJumpTableForInstr,
InstrBlock
)
dflags <- getDynFlagsNat
dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
- let
- jumpTable = map jumpTableEntryRel ids
-
- jumpTableEntryRel Nothing
- = CmmStaticLit (CmmInt 0 wordWidth)
- jumpTableEntryRel (Just blockid)
- = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
- where blockLabel = mkAsmTempLabel (getUnique blockid)
-
- op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
+ let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
(EAIndex reg wORD_SIZE) (ImmInt 0))
#if x86_64_TARGET_ARCH
code = e_code `appOL` t_code `appOL` toOL [
ADD (intSize wordWidth) op (OpReg tableReg),
- JMP_TBL (OpReg tableReg) [ id | Just id <- ids ],
- LDATA Text (CmmDataLabel lbl : jumpTable)
+ JMP_TBL (OpReg tableReg) ids Text lbl
]
#else
-- HACK: On x86_64 binutils<2.17 is only able to generate PC32
-- conjunction with the hack in PprMach.hs/pprDataItem once
-- binutils 2.17 is standard.
code = e_code `appOL` t_code `appOL` toOL [
- LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
MOVSxL II32
(OpAddr (AddrBaseIndex (EABaseReg tableReg)
(EAIndex reg wORD_SIZE) (ImmInt 0)))
(OpReg reg),
ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg),
- JMP_TBL (OpReg tableReg) [ id | Just id <- ids ]
+ JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl
]
#endif
#else
code = e_code `appOL` t_code `appOL` toOL [
- LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
ADD (intSize wordWidth) op (OpReg tableReg),
- JMP_TBL (OpReg tableReg) [ id | Just id <- ids ]
+ JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl
]
#endif
return code
(reg,e_code) <- getSomeReg expr
lbl <- getNewLabelNat
let
- jumpTable = map jumpTableEntry ids
op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl))
code = e_code `appOL` toOL [
- LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
- JMP_TBL op [ id | Just id <- ids ]
+ JMP_TBL op ids ReadOnlyData lbl
]
-- in
return code
+generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr)
+generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl)
+generateJumpTableForInstr _ = Nothing
+
+createJumpTable ids section lbl
+ = let jumpTable
+ | opt_PIC =
+ let jumpTableEntryRel Nothing
+ = CmmStaticLit (CmmInt 0 wordWidth)
+ jumpTableEntryRel (Just blockid)
+ = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
+ where blockLabel = mkAsmTempLabel (getUnique blockid)
+ in map jumpTableEntryRel ids
+ | otherwise = map jumpTableEntry ids
+ in CmmData section (CmmDataLabel lbl : jumpTable)
-- -----------------------------------------------------------------------------
-- 'condIntReg' and 'condFltReg': condition codes into registers
| JMP Operand
| JXX Cond BlockId -- includes unconditional branches
| JXX_GBL Cond Imm -- non-local version of JXX
- | JMP_TBL Operand [BlockId] -- table jump
+ -- Table jump
+ | JMP_TBL Operand -- Address to jump to
+ [Maybe BlockId] -- Blocks in the jump table
+ Section -- Data section jump table should be put in
+ CLabel -- Label of jump table
| CALL (Either Imm Reg) [Reg]
-- Other things.
JXX _ _ -> mkRU [] []
JXX_GBL _ _ -> mkRU [] []
JMP op -> mkRUR (use_R op)
- JMP_TBL op _ -> mkRUR (use_R op)
+ JMP_TBL op _ _ _ -> mkRUR (use_R op)
CALL (Left _) params -> mkRU params callClobberedRegs
CALL (Right reg) params -> mkRU (reg:params) callClobberedRegs
CLTD _ -> mkRU [eax] [edx]
POP sz op -> patch1 (POP sz) op
SETCC cond op -> patch1 (SETCC cond) op
JMP op -> patch1 JMP op
- JMP_TBL op ids -> patch1 JMP_TBL op $ ids
+ JMP_TBL op ids s lbl-> JMP_TBL (patchOp op) ids s lbl
GMOV src dst -> GMOV (env src) (env dst)
GLD sz src dst -> GLD sz (lookupAddr src) (env dst)
x86_jumpDestsOfInstr insn
= case insn of
JXX _ id -> [id]
- JMP_TBL _ ids -> ids
+ JMP_TBL _ ids _ _ -> [id | Just id <- ids]
_ -> []
x86_patchJumpInstr insn patchF
= case insn of
JXX cc id -> JXX cc (patchF id)
- JMP_TBL _ _ -> error "Cannot patch JMP_TBL"
+ JMP_TBL op ids section lbl
+ -> JMP_TBL op (map (fmap patchF) ids) section lbl
_ -> insn
where p insn r = case insn of
CALL _ _ -> GFREE : insn : r
JMP _ -> GFREE : insn : r
- JXX_GBL _ _ -> GFREE : insn : r
+ JXX_GBL _ _ -> panic "i386_insert_ffrees: cannot handle JXX_GBL"
_ -> insn : r
-- if you ever add a new FP insn to the fake x86 FP insn set,
data JumpDest = DestBlockId BlockId | DestImm Imm
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+getJumpDestBlockId _ = Nothing
canShortcut :: Instr -> Maybe JumpDest
canShortcut (JXX ALWAYS id) = Just (DestBlockId id)
pprSectionHeader,
pprData,
pprInstr,
- pprUserReg,
pprSize,
pprImm,
pprDataItem,
import OldCmm
import CLabel
-import Config
import Unique ( pprUnique, Uniquable(..) )
import Pretty
import FastString
import Outputable (panic, Outputable)
import Data.Word
-import Distribution.System
#if i386_TARGET_ARCH && darwin_TARGET_OS
import Data.Bits
<+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
else empty
#endif
+ $$ pprSizeDecl (if null info then lbl else entryLblToInfoLbl lbl)
+-- | Output the ELF .size directive.
+pprSizeDecl :: CLabel -> Doc
+#if elf_OBJ_FORMAT
+pprSizeDecl lbl =
+ ptext (sLit "\t.size") <+> pprCLabel_asm lbl
+ <> ptext (sLit ", .-") <> pprCLabel_asm lbl
+#else
+pprSizeDecl _ = empty
+#endif
pprBasicBlock :: NatBasicBlock Instr -> Doc
pprBasicBlock (BasicBlock blockid instrs) =
ppr instr = Outputable.docToSDoc $ pprInstr instr
-pprUserReg :: Reg -> Doc
-pprUserReg
- | cTargetArch == I386 = pprReg II32
- | cTargetArch == X86_64 = pprReg II64
- | otherwise = panic "X86.Ppr.pprUserReg: not defined"
-
pprReg :: Size -> Reg -> Doc
pprReg s r
pprInstr (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm)
pprInstr (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand archWordSize op)
-pprInstr (JMP_TBL op _) = pprInstr (JMP op)
+pprInstr (JMP_TBL op _ _ _) = pprInstr (JMP op)
pprInstr (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm)
pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg)
pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to
pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to
-pprInstr (CVTTSS2SIQ sz from to) = pprSizeOpReg (sLit "cvttss2si") sz from to
-pprInstr (CVTTSD2SIQ sz from to) = pprSizeOpReg (sLit "cvttsd2si") sz from to
+pprInstr (CVTTSS2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttss2si") FF32 sz from to
+pprInstr (CVTTSD2SIQ sz from to) = pprSizeSizeOpReg (sLit "cvttsd2si") FF64 sz from to
pprInstr (CVTSI2SS sz from to) = pprSizeOpReg (sLit "cvtsi2ss") sz from to
pprInstr (CVTSI2SD sz from to) = pprSizeOpReg (sLit "cvtsi2sd") sz from to
pprReg archWordSize reg2
]
-
pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc
pprCondRegReg name size cond reg1 reg2
= hcat [
pprSize size2,
space,
pprReg size1 reg1,
-
comma,
pprReg size2 reg2
]
+pprSizeSizeOpReg :: LitString -> Size -> Size -> Operand -> Reg -> Doc
+pprSizeSizeOpReg name size1 size2 op1 reg2
+ = hcat [
+ pprMnemonic name size2,
+ pprOperand size1 op1,
+ comma,
+ pprReg size2 reg2
+ ]
pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc
pprSizeRegRegReg name size reg1 reg2 reg3
-- argRegs is the set of regs which are read for an n-argument call to C.
-- For archs which pass all args on the stack (x86), is empty.
-- Sparc passes up to the first 6 args in regs.
--- Dunno about Alpha.
argRegs :: RegNo -> [Reg]
argRegs _ = panic "MachRegs.argRegs(x86): should not be used!"
{-
AMD x86_64 architecture:
-- Registers 0-16 have 32-bit counterparts (eax, ebx etc.)
-- Registers 0-7 have 16-bit counterparts (ax, bx etc.)
-- Registers 0-3 have 8 bit counterparts (ah, bh etc.)
-
+- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values:
+
+ 8 16 32 64
+ ---------------------
+ al ax eax rax
+ bl bx ebx rbx
+ cl cx ecx rcx
+ dl dx edx rdx
+ sil si esi rsi
+ dil si edi rdi
+ bpl bp ebp rbp
+ spl sp esp rsp
+ r10b r10w r10d r10
+ r11b r11w r11d r11
+ r12b r12w r12d r12
+ r13b r13w r13d r13
+ r14b r14w r14d r14
+ r15b r15w r15d r15
-}
rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi,
import DynFlags
import Module
import Ctype
-import BasicTypes ( InlineSpec(..), RuleMatchInfo(..) )
+import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
import Util ( readRational )
import Control.Monad
{ token ITcubxparen }
}
-<0> {
- "{|" / { ifExtension genericsEnabled } { token ITocurlybar }
- "|}" / { ifExtension genericsEnabled } { token ITccurlybar }
-}
-
<0,option_prags> {
\( { special IToparen }
\) { special ITcparen }
| ITchar Char
| ITstring FastString
| ITinteger Integer
- | ITrational Rational
+ | ITrational FractionalLit
| ITprimchar Char
| ITprimstring FastString
| ITprimint Integer
| ITprimword Integer
- | ITprimfloat Rational
- | ITprimdouble Rational
+ | ITprimfloat FractionalLit
+ | ITprimdouble FractionalLit
-- Template Haskell extension tokens
| ITopenExpQuote -- [| or [e|
-- readRational can understand negative rationals, exponents, everything.
tok_float, tok_primfloat, tok_primdouble :: String -> Token
-tok_float str = ITrational $! readRational str
-tok_primfloat str = ITprimfloat $! readRational str
-tok_primdouble str = ITprimdouble $! readRational str
+tok_float str = ITrational $! readFractionalLit str
+tok_primfloat str = ITprimfloat $! readFractionalLit str
+tok_primdouble str = ITprimdouble $! readFractionalLit str
+
+readFractionalLit :: String -> FractionalLit
+readFractionalLit str = (FL $! str) $! readRational str
-- -----------------------------------------------------------------------------
-- Layout processing
-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed
-- integer
-genericsBit :: Int
-genericsBit = 0 -- {| and |}
+-- The "genericsBit" is now unused, available for others
+-- genericsBit :: Int
+-- genericsBit = 0 -- {|, |} and "generic"
+
ffiBit :: Int
ffiBit = 1
parrBit :: Int
always :: Int -> Bool
always _ = True
-genericsEnabled :: Int -> Bool
-genericsEnabled flags = testBit flags genericsBit
parrEnabled :: Int -> Bool
parrEnabled flags = testBit flags parrBit
arrowsEnabled :: Int -> Bool
mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
mkPState flags buf loc =
PState {
- buffer = buf,
+ buffer = buf,
dflags = flags,
messages = emptyMessages,
last_loc = mkSrcSpan loc loc,
code_type_bracket_depth = 0
}
where
- bitmap = genericsBit `setBitIf` xopt Opt_Generics flags
- .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
- .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
- .|. arrowsBit `setBitIf` xopt Opt_Arrows flags
- .|. hetMetBit `setBitIf` xopt Opt_ModalTypes flags
- .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
- .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
- .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
- .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
- .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
- .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
- .|. haddockBit `setBitIf` dopt Opt_Haddock flags
- .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
- .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
- .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
- .|. recBit `setBitIf` xopt Opt_DoRec flags
- .|. recBit `setBitIf` xopt Opt_Arrows flags
- .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
- .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
+ bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags
+ .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags
+ .|. arrowsBit `setBitIf` xopt Opt_Arrows flags
+ .|. hetMetBit `setBitIf` xopt Opt_ModalTypes flags
+ .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags
+ .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags
+ .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags
+ .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags
+ .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags
+ .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags
+ .|. haddockBit `setBitIf` dopt Opt_Haddock flags
+ .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags
+ .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags
+ .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags
+ .|. recBit `setBitIf` xopt Opt_DoRec flags
+ .|. recBit `setBitIf` xopt Opt_Arrows flags
+ .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags
+ .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags
.|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags
.|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags
+ .|. transformComprehensionsBit `setBitIf` xopt Opt_MonadComprehensions flags
.|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags
.|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
- .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
+ .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags
.|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
--
setBitIf :: Int -> Bool -> Int
b `setBitIf` cond | cond = bit b
- | otherwise = 0
+ | otherwise = 0
addWarning :: DynFlag -> SrcSpan -> SDoc -> P ()
addWarning option srcspan warning
decl_cls : at_decl_cls { LL (unitOL (L1 (TyClD (unLoc $1)))) }
| decl { $1 }
+ -- A 'default' signature used with the generic-programming extension
+ | 'default' infixexp '::' sigtypedoc
+ {% do { (TypeSig l ty) <- checkValSig $2 $4
+ ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } }
+
decls_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed
: decls_cls ';' decl_cls { LL (unLoc $1 `appOL` unLoc $3) }
| decls_cls ';' { LL (unLoc $1) }
| '$(' exp ')' { LL $ mkHsSpliceTy $2 }
| TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $
mkUnqual varName (getTH_ID_SPLICE $1) }
--- Generics
- | INTEGER { L1 (HsNumTy (getINTEGER $1)) }
-- An inst_type is what occurs in the head of an instance decl
-- e.g. (Foo a, Gaz b) => Wibble a b
: '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 }
sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
- : infixexp '::' sigtypedoc {% do s <- checkValSig $1 $3
- ; return (LL $ unitOL (LL $ SigD s)) }
- -- See Note [Declaration/signature overlap] for why we need infixexp here
-
+ :
+ -- See Note [Declaration/signature overlap] for why we need infixexp here
+ infixexp '::' sigtypedoc
+ {% do s <- checkValSig $1 $3
+ ; return (LL $ unitOL (LL $ SigD s)) }
| var ',' sig_vars '::' sigtypedoc
{ LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
| infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
| 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
| '-' fexp { LL $ NegApp $2 noSyntaxExpr }
- | 'do' stmtlist {% let loc = comb2 $1 $2 in
- checkDo loc (unLoc $2) >>= \ (stmts,body) ->
- return (L loc (mkHsDo DoExpr stmts body)) }
- | 'mdo' stmtlist {% let loc = comb2 $1 $2 in
- checkDo loc (unLoc $2) >>= \ (stmts,body) ->
- return (L loc (mkHsDo MDoExpr
- [L loc (mkRecStmt stmts)]
- body)) }
+ | 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) }
+ | 'mdo' stmtlist { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) }
+
| scc_annot exp { LL $ if opt_SccProfilingOn
then HsSCC (unLoc $1) $2
else HsPar $2 }
| texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) }
| texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) }
| texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) }
- | texp '|' flattenedpquals { sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 }
+ | texp '|' flattenedpquals
+ {% checkMonadComp >>= \ ctxt ->
+ return (sL (comb2 $1 $>) $
+ mkHsComp ctxt (unLoc $3) $1) }
lexps :: { Located [LHsExpr RdrName] }
: lexps ',' texp { LL (((:) $! $3) $! unLoc $1) }
-- We just had one thing in our "parallel" list so
-- we simply return that thing directly
- qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]]
+ qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr]
-- We actually found some actual parallel lists so
-- we wrap them into as a ParStmt
}
-- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |}
-- above. Due to a lack of consensus on the syntax, this feature is not being used until we get user
--- demand. Note that the {| |} symbols are reused from -XGenerics and hence if you want to compile
--- a program that makes use of this temporary syntax you must supply that flag to GHC
+-- demand.
transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) }
-- Function is applied to a list of stmts *in order*
(reverse (unLoc $1)) }
| texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) }
| texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) }
- | texp '|' flattenedpquals { LL $ mkHsDo PArrComp (unLoc $3) $1 }
+ | texp '|' flattenedpquals { LL $ mkHsComp PArrComp (unLoc $3) $1 }
-- We are reusing `lexps' and `flattenedpquals' from the list case.
| '%let' let_bind '%in' exp { IfaceLet $2 $4 }
-- gaw 2004
| '%case' '(' ty ')' aexp '%of' id_bndr
- '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 }
+ '{' alts1 '}' { IfaceCase $5 (fst $7) $9 }
| '%cast' aexp aty { IfaceCast $2 $3 }
-- No InlineMe any more
-- | '%note' STRING exp
checkPattern, -- HsExp -> P HsPat
bang_RDR,
checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat]
- checkDo, -- [Stmt] -> P [Stmt]
- checkMDo, -- [Stmt] -> P [Stmt]
+ checkMonadComp, -- P (HsStmtContext RdrName)
checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
checkDoAndIfThenElse,
import TypeRep ( Kind )
import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc,
isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
+import Name ( Name )
import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo,
InlinePragma(..), InlineSpec(..) )
import Lexer
HsPredTy p -> extract_pred p acc
HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
HsParTy ty -> extract_lty ty acc
- HsNumTy {} -> acc
HsCoreTy {} -> acc -- The type is closed
HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables
HsSpliceTy {} -> acc -- Type splices mention no type variables
get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms
get _ acc = acc
- get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc
- get_m _ acc = acc
+ get_m _ acc = acc
\end{code}
check loc _ _ = parseErrorSDoc loc
(text "malformed class assertion:" <+> ppr ty)
----------------------------------------------------------------------------
--- Checking statements in a do-expression
--- We parse do { e1 ; e2 ; }
--- as [ExprStmt e1, ExprStmt e2]
--- checkDo (a) checks that the last thing is an ExprStmt
--- (b) returns it separately
--- same comments apply for mdo as well
-
-checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
-
-checkDo = checkDoMDo "a " "'do'"
-checkMDo = checkDoMDo "an " "'mdo'"
-
-checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
-checkDoMDo _ nm loc [] = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct"))
-checkDoMDo pre nm _ ss = do
- check ss
- where
- check [] = panic "RdrHsSyn:checkDoMDo"
- check [L _ (ExprStmt e _ _)] = return ([], e)
- check [L l e] = parseErrorSDoc l
- (text ("The last statement in " ++ pre ++ nm ++
- " construct must be an expression:")
- $$ ppr e)
- check (s:ss) = do
- (ss',e') <- check ss
- return ((s:ss'),e')
-
-- -------------------------------------------------------------------------
-- Checking Patterns.
-> do fs <- mapM checkPatField fs
return (ConPatIn c (RecCon (HsRecFields fs dd)))
HsQuasiQuoteE q -> return (QuasiQuotePat q)
--- Generics
- HsType ty -> return (TypePat ty)
_ -> patFail loc e0
placeHolderPunRhs :: LHsExpr RdrName
ppr lhs <+> text "::" <+> ppr ty)
$$ text hint)
where
- hint = if looks_like_foreign lhs
+ hint = if foreign_RDR `looks_like` lhs
then "Perhaps you meant to use -XForeignFunctionInterface?"
- else "Should be of form <variable> :: <type>"
+ else if default_RDR `looks_like` lhs
+ then "Perhaps you meant to use -XDefaultSignatures?"
+ else "Should be of form <variable> :: <type>"
-- A common error is to forget the ForeignFunctionInterface flag
-- so check for that, and suggest. cf Trac #3805
-- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
- looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR
- looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs
- looks_like_foreign _ = False
+ looks_like s (L _ (HsVar v)) = v == s
+ looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
+ looks_like _ _ = False
foreign_RDR = mkUnqual varName (fsLit "foreign")
+ default_RDR = mkUnqual varName (fsLit "default")
checkDoAndIfThenElse :: LHsExpr RdrName
-> Bool
_ -> return Nothing }
go _ _ = return Nothing
+
+---------------------------------------------------------------------------
+-- Check for monad comprehensions
+--
+-- If the flag MonadComprehensions is set, return a `MonadComp' context,
+-- otherwise use the usual `ListComp' context
+
+checkMonadComp :: P (HsStmtContext Name)
+checkMonadComp = do
+ pState <- getPState
+ return $ if xopt Opt_MonadComprehensions (dflags pState)
+ then MonadComp
+ else ListComp
+
---------------------------------------------------------------------------
-- Miscellaneous utilities
{-# LANGUAGE DeriveDataTypeable #-}
module ForeignCall (
- ForeignCall(..),
+ ForeignCall(..), isSafeForeignCall,
Safety(..), playSafe, playInterruptible,
CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
deriving Eq
{-! derive: Binary !-}
+isSafeForeignCall :: ForeignCall -> Bool
+isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe
+
-- We may need more clues to distinguish foreign calls
-- but this simple printer will do for now
instance Outputable ForeignCall where
%* *
%************************************************************************
-This section tells what the compiler knows about the assocation of
+This section tells what the compiler knows about the association of
names with uniques. These ones are the *non* wired-in ones. The
wired in ones are defined in TysWiredIn etc.
-- Monad stuff
thenIOName, bindIOName, returnIOName, failIOName,
failMName, bindMName, thenMName, returnMName,
+ fmapName,
-- MonadRec stuff
mfixName,
-- dotnet interop
, objectTyConName, marshalObjectName, unmarshalObjectName
, marshalStringName, unmarshalStringName, checkDotnetResName
+
+ -- Generics
+ , genClassName, gen1ClassName
+ , datatypeClassName, constructorClassName, selectorClassName
+
+ -- Monad comprehensions
+ , guardMName
+ , liftMName
+ , groupMName
+ , mzipName
]
genericTyConNames :: [Name]
-genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName]
+genericTyConNames = [
+ v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
+ k1TyConName, m1TyConName, sumTyConName, prodTyConName,
+ compTyConName, rTyConName, pTyConName, dTyConName,
+ cTyConName, sTyConName, rec0TyConName, par0TyConName,
+ d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
+ repTyConName, rep1TyConName
+ ]
-- Know names from the DPH package which vary depending on the selected DPH backend.
--
gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS,
gHC_MAGIC,
- gHC_CLASSES, gHC_BASE, gHC_ENUM,
+ gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST,
gHC_HETMET_CODETYPES,
gHC_HETMET_PRIVATE,
gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception,
gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL,
gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS,
- dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, aRROW, cONTROL_APPLICATIVE,
- gHC_DESUGAR, rANDOM, gHC_EXTS, cONTROL_EXCEPTION_BASE :: Module
+ dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_GROUP, mONAD_ZIP,
+ aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
+ cONTROL_EXCEPTION_BASE :: Module
gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values
gHC_TYPES = mkPrimModule (fsLit "GHC.Types")
gHC_ORDERING = mkPrimModule (fsLit "GHC.Ordering")
gHC_GENERICS = mkPrimModule (fsLit "GHC.Generics")
gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic")
+gHC_CSTRING = mkPrimModule (fsLit "GHC.CString")
gHC_CLASSES = mkBaseModule (fsLit "GHC.Classes")
gHC_BASE = mkBaseModule (fsLit "GHC.Base")
gHC_WORD = mkBaseModule (fsLit "GHC.Word")
mONAD = mkBaseModule (fsLit "Control.Monad")
mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix")
+mONAD_GROUP = mkBaseModule (fsLit "Control.Monad.Group")
+mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip")
aRROW = mkBaseModule (fsLit "Control.Arrow")
cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative")
gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar")
undefined_RDR :: RdrName
undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined")
+error_RDR :: RdrName
+error_RDR = varQual_RDR gHC_ERR (fsLit "error")
+
+-- Old Generics (constructors and functions)
crossDataCon_RDR, inlDataCon_RDR, inrDataCon_RDR, genUnitDataCon_RDR :: RdrName
crossDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:")
inlDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inl")
inrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inr")
genUnitDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Unit")
+-- Generics (constructors and functions)
+u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,
+ k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR,
+ prodDataCon_RDR, comp1DataCon_RDR, from_RDR, from1_RDR,
+ to_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, conName_RDR,
+ conFixity_RDR, conIsRecord_RDR,
+ noArityDataCon_RDR, arityDataCon_RDR, selName_RDR,
+ prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,
+ rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName
+
+u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1")
+par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1")
+rec1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Rec1")
+k1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "K1")
+m1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "M1")
+
+l1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "L1")
+r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1")
+
+prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:")
+comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1")
+
+from_RDR = varQual_RDR gHC_GENERICS (fsLit "from")
+from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1")
+to_RDR = varQual_RDR gHC_GENERICS (fsLit "to")
+to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1")
+
+datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName")
+moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName")
+selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName")
+conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName")
+conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity")
+conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord")
+
+noArityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NoArity")
+arityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Arity")
+prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix")
+infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix")
+leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative")
+rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative")
+notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
+
+
fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, traverse_RDR :: RdrName
fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap")
pure_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure")
leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey
rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey
--- Generics
-crossTyConName, plusTyConName, genUnitTyConName :: Name
-crossTyConName = tcQual gHC_GENERICS (fsLit ":*:") crossTyConKey
-plusTyConName = tcQual gHC_GENERICS (fsLit ":+:") plusTyConKey
-genUnitTyConName = tcQual gHC_GENERICS (fsLit "Unit") genUnitTyConKey
+-- Generics (types)
+v1TyConName, u1TyConName, par1TyConName, rec1TyConName,
+ k1TyConName, m1TyConName, sumTyConName, prodTyConName,
+ compTyConName, rTyConName, pTyConName, dTyConName,
+ cTyConName, sTyConName, rec0TyConName, par0TyConName,
+ d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
+ repTyConName, rep1TyConName :: Name
+
+v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey
+u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey
+par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey
+rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey
+k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey
+m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey
+
+sumTyConName = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey
+prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey
+compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey
+
+rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey
+pTyConName = tcQual gHC_GENERICS (fsLit "P") pTyConKey
+dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey
+cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey
+sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey
+
+rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey
+par0TyConName = tcQual gHC_GENERICS (fsLit "Par0") par0TyConKey
+d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey
+c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey
+s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey
+noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey
+
+repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey
+rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey
-- Base strings Strings
unpackCStringName, unpackCStringAppendName, unpackCStringFoldrName,
unpackCStringUtf8Name, eqStringName, stringTyConName :: Name
-unpackCStringName = varQual gHC_BASE (fsLit "unpackCString#") unpackCStringIdKey
-unpackCStringAppendName = varQual gHC_BASE (fsLit "unpackAppendCString#") unpackCStringAppendIdKey
-unpackCStringFoldrName = varQual gHC_BASE (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey
-unpackCStringUtf8Name = varQual gHC_BASE (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey
+unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey
+unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey
+unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey
+unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey
eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey
stringTyConName = tcQual gHC_BASE (fsLit "String") stringTyConKey
inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey
-- Base classes (Eq, Ord, Functor)
-eqClassName, eqName, ordClassName, geName, functorClassName :: Name
+fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name
eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey
eqName = methName gHC_CLASSES (fsLit "==") eqClassOpKey
ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey
geName = methName gHC_CLASSES (fsLit ">=") geClassOpKey
functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey
+fmapName = methName gHC_BASE (fsLit "fmap") fmapClassOpKey
-- Class Monad
monadClassName, thenMName, bindMName, returnMName, failMName :: Name
readClassName :: Name
readClassName = clsQual gHC_READ (fsLit "Read") readClassKey
+-- Classes Generic and Generic1, Datatype, Constructor and Selector
+genClassName, gen1ClassName, datatypeClassName, constructorClassName,
+ selectorClassName :: Name
+genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey
+gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey
+
+datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey
+constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey
+selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey
+
-- parallel array types and functions
enumFromToPName, enumFromThenToPName, nullPName, lengthPName,
singletonPName, replicatePName, mapPName, filterPName,
choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey
loopAName = varQual aRROW (fsLit "loop") loopAIdKey
+-- Monad comprehensions
+guardMName, liftMName, groupMName, mzipName :: Name
+guardMName = varQual mONAD (fsLit "guard") guardMIdKey
+liftMName = varQual mONAD (fsLit "liftM") liftMIdKey
+groupMName = varQual mONAD_GROUP (fsLit "mgroupWith") groupMIdKey
+mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey
+
+
-- Annotation type checking
toAnnotationWrapperName :: Name
toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey
applicativeClassKey = mkPreludeClassUnique 34
foldableClassKey = mkPreludeClassUnique 35
traversableClassKey = mkPreludeClassUnique 36
+
+genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey,
+ selectorClassKey :: Unique
+genClassKey = mkPreludeClassUnique 37
+gen1ClassKey = mkPreludeClassUnique 38
+
+datatypeClassKey = mkPreludeClassUnique 39
+constructorClassKey = mkPreludeClassUnique 40
+selectorClassKey = mkPreludeClassUnique 41
\end{code}
%************************************************************************
word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey,
liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
- funPtrTyConKey, tVarPrimTyConKey :: Unique
+ funPtrTyConKey, tVarPrimTyConKey, eqPredPrimTyConKey :: Unique
statePrimTyConKey = mkPreludeTyConUnique 50
stableNamePrimTyConKey = mkPreludeTyConUnique 51
-stableNameTyConKey = mkPreludeTyConUnique 52
-mutVarPrimTyConKey = mkPreludeTyConUnique 55
+stableNameTyConKey = mkPreludeTyConUnique 52
+eqPredPrimTyConKey = mkPreludeTyConUnique 53
+mutVarPrimTyConKey = mkPreludeTyConUnique 55
ioTyConKey = mkPreludeTyConUnique 56
wordPrimTyConKey = mkPreludeTyConUnique 58
wordTyConKey = mkPreludeTyConUnique 59
funPtrTyConKey = mkPreludeTyConUnique 75
tVarPrimTyConKey = mkPreludeTyConUnique 76
--- Generic Type Constructors
-crossTyConKey, plusTyConKey, genUnitTyConKey :: Unique
-crossTyConKey = mkPreludeTyConUnique 79
-plusTyConKey = mkPreludeTyConUnique 80
-genUnitTyConKey = mkPreludeTyConUnique 81
-
-- Parallel array type constructor
parrTyConKey :: Unique
parrTyConKey = mkPreludeTyConUnique 82
eitherTyConKey = mkPreludeTyConUnique 84
-- Super Kinds constructors
-tySuperKindTyConKey, coSuperKindTyConKey :: Unique
+tySuperKindTyConKey :: Unique
tySuperKindTyConKey = mkPreludeTyConUnique 85
-coSuperKindTyConKey = mkPreludeTyConUnique 86
-- Kind constructors
liftedTypeKindTyConKey, openTypeKindTyConKey, unliftedTypeKindTyConKey,
stringTyConKey :: Unique
stringTyConKey = mkPreludeTyConUnique 134
--- Heterogeneous Metaprogramming code type constructor
-hetMetCodeTypeTyConKey :: Unique
-hetMetCodeTypeTyConKey = mkPreludeTyConUnique 135
+-- Generics (Unique keys)
+v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,
+ k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,
+ compTyConKey, rTyConKey, pTyConKey, dTyConKey,
+ cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey,
+ d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey,
+ repTyConKey, rep1TyConKey :: Unique
+
+v1TyConKey = mkPreludeTyConUnique 135
+u1TyConKey = mkPreludeTyConUnique 136
+par1TyConKey = mkPreludeTyConUnique 137
+rec1TyConKey = mkPreludeTyConUnique 138
+k1TyConKey = mkPreludeTyConUnique 139
+m1TyConKey = mkPreludeTyConUnique 140
+
+sumTyConKey = mkPreludeTyConUnique 141
+prodTyConKey = mkPreludeTyConUnique 142
+compTyConKey = mkPreludeTyConUnique 143
+
+rTyConKey = mkPreludeTyConUnique 144
+pTyConKey = mkPreludeTyConUnique 145
+dTyConKey = mkPreludeTyConUnique 146
+cTyConKey = mkPreludeTyConUnique 147
+sTyConKey = mkPreludeTyConUnique 148
+
+rec0TyConKey = mkPreludeTyConUnique 149
+par0TyConKey = mkPreludeTyConUnique 150
+d1TyConKey = mkPreludeTyConUnique 151
+c1TyConKey = mkPreludeTyConUnique 152
+s1TyConKey = mkPreludeTyConUnique 153
+noSelTyConKey = mkPreludeTyConUnique 154
+
+repTyConKey = mkPreludeTyConUnique 155
+rep1TyConKey = mkPreludeTyConUnique 156
+>>>>>>> 18691d440f90a3dff4ef538091c886af505e5cf5
---------------- Template Haskell -------------------
-- USES TyConUniques 200-299
groupWithIdKey = mkPreludeMiscIdUnique 70
dollarIdKey = mkPreludeMiscIdUnique 71
+coercionTokenIdKey :: Unique
+coercionTokenIdKey = mkPreludeMiscIdUnique 72
+
-- Parallel array functions
singletonPIdKey, nullPIdKey, lengthPIdKey, replicatePIdKey, mapPIdKey,
filterPIdKey, zipPIdKey, crossMapPIdKey, indexPIdKey, toPIdKey,
fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey,
enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey,
enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey,
- failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey
+ failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey,
+ fmapClassOpKey
:: Unique
fromIntegerClassOpKey = mkPreludeMiscIdUnique 102
minusClassOpKey = mkPreludeMiscIdUnique 103
failMClassOpKey = mkPreludeMiscIdUnique 112
bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>)
+fmapClassOpKey = mkPreludeMiscIdUnique 115
returnMClassOpKey = mkPreludeMiscIdUnique 117
-- Recursive do notation
toIntegerClassOpKey = mkPreludeMiscIdUnique 129
toRationalClassOpKey = mkPreludeMiscIdUnique 130
+-- Monad comprehensions
+guardMIdKey, liftMIdKey, groupMIdKey, mzipIdKey :: Unique
+guardMIdKey = mkPreludeMiscIdUnique 131
+liftMIdKey = mkPreludeMiscIdUnique 132
+groupMIdKey = mkPreludeMiscIdUnique 133
+mzipIdKey = mkPreludeMiscIdUnique 134
+
-- code types
-hetmet_brak_key, hetmet_esc_key, hetmet_csp_key, hetmet_flatten_key, hetmet_unflatten_key, hetmet_flattened_id_key :: Unique
-hetmet_brak_key = mkPreludeMiscIdUnique 131
-hetmet_esc_key = mkPreludeMiscIdUnique 132
-hetmet_csp_key = mkPreludeMiscIdUnique 133
+hetMetCodeTypeTyConKey :: Unique
+hetMetCodeTypeTyConKey = mkPreludeTyConUnique 135
+
hetmet_guest_integer_literal_key, hetmet_guest_string_literal_key, hetmet_guest_char_literal_key :: Unique
hetmet_guest_integer_literal_key = mkPreludeMiscIdUnique 134
hetmet_guest_string_literal_key = mkPreludeMiscIdUnique 135
hetmet_PGArrow_exponent_key :: Unique
hetmet_PGArrow_exponent_key = mkPreludeMiscIdUnique 160
+hetmet_brak_key, hetmet_esc_key, hetmet_csp_key, hetmet_flatten_key, hetmet_unflatten_key, hetmet_flattened_id_key :: Unique
+hetmet_brak_key = mkPreludeMiscIdUnique 161
+hetmet_esc_key = mkPreludeMiscIdUnique 162
+hetmet_csp_key = mkPreludeMiscIdUnique 163
---------------- Template Haskell -------------------
like that, so we use a BuiltinRule instead, so that we
can match in any two literal values. So the rule is really
more like
- (Lit 4) +# (Lit y) = Lit (x+#y)
+ (Lit x) +# (Lit y) = Lit (x+#y)
where the (+#) on the rhs is done at compile time
That is why these rules are built in here. Other rules
dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr)
dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
| tag_to_enum `hasKey` tagToEnumKey
- , ty1 `coreEqType` ty2
+ , ty1 `eqType` ty2
= Just tag -- dataToTag (tagToEnum x) ==> x
dataToTagRule id_unf [_, val_arg]
]
| unpk `hasKey` unpackCStringFoldrIdKey &&
c1 `cheapEqExpr` c2
- = ASSERT( ty1 `coreEqType` ty2 )
+ = ASSERT( ty1 `eqType` ty2 )
Just (Var unpk `App` Type ty1
`App` Lit (MachStr (s1 `appendFS` s2))
`App` c1
tagToEnumKey,
- primOpOutOfLine, primOpNeedsWrapper,
- primOpOkForSpeculation, primOpIsCheap, primOpIsDupable,
+ primOpOutOfLine, primOpCodeSize,
+ primOpOkForSpeculation, primOpIsCheap,
getPrimOpResultInfo, PrimOpResultInfo(..),
-- even if primOpIsCheap sometimes says 'True'.
\end{code}
-primOpIsDupable
-~~~~~~~~~~~~~~~
-primOpIsDupable means that the use of the primop is small enough to
-duplicate into different case branches. See CoreUtils.exprIsDupable.
+primOpCodeSize
+~~~~~~~~~~~~~~
+Gives an indication of the code size of a primop, for the purposes of
+calculating unfolding sizes; see CoreUnfold.sizeExpr.
\begin{code}
-primOpIsDupable :: PrimOp -> Bool
- -- See comments with CoreUtils.exprIsDupable
- -- We say it's dupable it isn't implemented by a C call with a wrapper
-primOpIsDupable op = not (primOpNeedsWrapper op)
-\end{code}
+primOpCodeSize :: PrimOp -> Int
+#include "primop-code-size.hs-incl"
+
+primOpCodeSizeDefault :: Int
+primOpCodeSizeDefault = 1
+ -- CoreUnfold.primOpSize already takes into account primOpOutOfLine
+ -- and adds some further costs for the args in that case.
+primOpCodeSizeForeignCall :: Int
+primOpCodeSizeForeignCall = 4
+\end{code}
\begin{code}
primOpCanFail :: PrimOp -> Bool
#include "primop-has-side-effects.hs-incl"
\end{code}
-Inline primitive operations that perform calls need wrappers to save
-any live variables that are stored in caller-saves registers.
-
-\begin{code}
-primOpNeedsWrapper :: PrimOp -> Bool
-#include "primop-needs-wrapper.hs-incl"
-\end{code}
-
\begin{code}
primOpType :: PrimOp -> Type -- you may want to use primOpSig instead
primOpType op
openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars,
argAlphaTy, argAlphaTyVar, argBetaTy, argBetaTyVar,
- primTyCons,
+ -- Kind constructors...
+ tySuperKindTyCon, tySuperKind,
+ liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
+ argTypeKindTyCon, ubxTupleKindTyCon,
+
+ tySuperKindTyConName, liftedTypeKindTyConName,
+ openTypeKindTyConName, unliftedTypeKindTyConName,
+ ubxTupleKindTyConName, argTypeKindTyConName,
+
+ -- Kinds
+ liftedTypeKind, unliftedTypeKind, openTypeKind,
+ argTypeKind, ubxTupleKind,
+ mkArrowKind, mkArrowKinds, isCoercionKind,
+
+ funTyCon, funTyConName,
+ primTyCons,
charPrimTyCon, charPrimTy,
intPrimTyCon, intPrimTy,
word32PrimTyCon, word32PrimTy,
int64PrimTyCon, int64PrimTy,
- word64PrimTyCon, word64PrimTy,
+ word64PrimTyCon, word64PrimTy,
+
+ eqPredPrimTyCon, -- ty1 ~ ty2
-- * Any
anyTyCon, anyTyConOfKind, anyTypeOfKind
import Var ( TyVar, mkTyVar )
import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName )
-import OccName ( mkTcOcc )
-import OccName ( mkTyVarOccFS, mkTcOccFS )
-import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon )
+import OccName ( mkTcOcc,mkTyVarOccFS, mkTcOccFS )
+import TyCon
+import TypeRep
import Type
-import TypeRep ( ecKind )
import Coercion
import SrcLoc
import Unique ( mkAlphaTyVarUnique )
, word32PrimTyCon
, word64PrimTyCon
, anyTyCon
+ , eqPredPrimTyCon
]
mkPrimTc :: FastString -> Unique -> TyCon -> Name
(ATyCon tycon) -- Relevant TyCon
UserSyntax -- None are built-in syntax
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPredPrimTyConName :: Name
charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon
int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon
floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon
doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon
-statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
-realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
+statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
+eqPredPrimTyConName = mkPrimTc (fsLit "~") eqPredPrimTyConKey eqPredPrimTyCon
+realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon
%************************************************************************
%* *
- Any
+ FunTyCon
%* *
%************************************************************************
-Note [Any types]
-~~~~~~~~~~~~~~~~
-The type constructor Any::* has these properties
-
- * It is defined in module GHC.Prim, and exported so that it is
- available to users. For this reason it's treated like any other
- primitive type:
- - has a fixed unique, anyTyConKey,
- - lives in the global name cache
- - built with TyCon.PrimTyCon
-
- * It is lifted, and hence represented by a pointer
-
- * It is inhabited by at least one value, namely bottom
-
- * You can unsafely coerce any lifted type to Ayny, and back.
-
- * It does not claim to be a *data* type, and that's important for
- the code generator, because the code gen may *enter* a data value
- but never enters a function value.
-
- * It is used to instantiate otherwise un-constrained type variables of kind *
- For example length Any []
- See Note [Strangely-kinded void TyCons]
-
-In addition, we have a potentially-infinite family of types, one for
-each kind /other than/ *, needed to instantiate otherwise
-un-constrained type variables of kinds other than *. This is a bit
-like tuples; there is a potentially-infinite family. They have slightly
-different characteristics to Any::*:
-
- * They are built with TyCon.AnyTyCon
- * They have non-user-writable names like "Any(*->*)"
- * They are not exported by GHC.Prim
- * They are uninhabited (of course; not kind *)
- * They have a unique derived from their OccName (see Note [Uniques of Any])
- * Their Names do not live in the global name cache
-
-Note [Uniques of Any]
-~~~~~~~~~~~~~~~~~~~~~
-Although Any(*->*), say, doesn't have a binding site, it still needs
-to have a Unique. Unlike tuples (which are also an infinite family)
-there is no convenient way to index them, so we use the Unique from
-their OccName instead. That should be unique,
- - both wrt each other, because their strings differ
-
- - and wrt any other Name, because Names get uniques with
- various 'char' tags, but the OccName of Any will
- get a Unique built with mkTcOccUnique, which has a particular 'char'
- tag; see Unique.mkTcOccUnique!
-
-Note [Strangely-kinded void TyCons]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See Trac #959 for more examples
+\begin{code}
+funTyConName :: Name
+funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
+
+funTyCon :: TyCon
+funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind)
+ -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
+ -- But if we do that we get kind errors when saying
+ -- instance Control.Arrow (->)
+ -- becuase the expected kind is (*->*->*). The trouble is that the
+ -- expected/actual stuff in the unifier does not go contra-variant, whereas
+ -- the kind sub-typing does. Sigh. It really only matters if you use (->) in
+ -- a prefix way, thus: (->) Int# Int#. And this is unusual.
+ -- because they are never in scope in the source
+\end{code}
-When the type checker finds a type variable with no binding, which
-means it can be instantiated with an arbitrary type, it usually
-instantiates it to Void. Eg.
- length []
-===>
- length Any (Nil Any)
+%************************************************************************
+%* *
+ Kinds
+%* *
+%************************************************************************
-But in really obscure programs, the type variable might have a kind
-other than *, so we need to invent a suitably-kinded type.
+\begin{code}
+-- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's
+tySuperKindTyCon, liftedTypeKindTyCon,
+ openTypeKindTyCon, unliftedTypeKindTyCon,
+ ubxTupleKindTyCon, argTypeKindTyCon
+ :: TyCon
+tySuperKindTyConName, liftedTypeKindTyConName,
+ openTypeKindTyConName, unliftedTypeKindTyConName,
+ ubxTupleKindTyConName, argTypeKindTyConName
+ :: Name
+
+tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName
+liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind
+openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind
+unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
+ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind
+argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind
+
+--------------------------
+-- ... and now their names
+
+tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon
+liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon
+openTypeKindTyConName = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon
+unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
+ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon
+argTypeKindTyConName = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon
+
+mkPrimTyConName :: FastString -> Unique -> TyCon -> Name
+mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ)
+ key
+ (ATyCon tycon)
+ BuiltInSyntax
+ -- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax,
+ -- because they are never in scope in the source
+\end{code}
-This commit uses
- Any for kind *
- Any(*->*) for kind *->*
- etc
\begin{code}
-anyTyConName :: Name
-anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon
+kindTyConType :: TyCon -> Type
+kindTyConType kind = TyConApp kind []
-anyTyCon :: TyCon
-anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep
+-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
+liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind
-anyTypeOfKind :: Kind -> Type
-anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) []
+liftedTypeKind = kindTyConType liftedTypeKindTyCon
+unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
+openTypeKind = kindTyConType openTypeKindTyCon
+argTypeKind = kindTyConType argTypeKindTyCon
+ubxTupleKind = kindTyConType ubxTupleKindTyCon
-anyTyConOfKind :: Kind -> TyCon
--- Map all superkinds of liftedTypeKind to liftedTypeKind
-anyTyConOfKind kind
- | liftedTypeKind `isSubKind` kind = anyTyCon
- | otherwise = tycon
- where
- -- Derive the name from the kind, thus:
- -- Any(*->*), Any(*->*->*)
- -- These are names that can't be written by the user,
- -- and are not allocated in the global name cache
- str = "Any" ++ showSDoc (pprParendKind kind)
+-- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
+mkArrowKind :: Kind -> Kind -> Kind
+mkArrowKind k1 k2 = FunTy k1 k2
- occ = mkTcOcc str
- uniq = getUnique occ -- See Note [Uniques of Any]
- name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax
- tycon = mkAnyTyCon name kind
-\end{code}
+-- | Iterated application of 'mkArrowKind'
+mkArrowKinds :: [Kind] -> Kind -> Kind
+mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
+tySuperKind :: SuperKind
+tySuperKind = kindTyConType tySuperKindTyCon
+\end{code}
%************************************************************************
%* *
%* *
%************************************************************************
+Note [The (~) TyCon)
+~~~~~~~~~~~~~~~~~~~~
+There is a perfectly ordinary type constructor (~) that represents the type
+of coercions (which, remember, are values). For example
+ Refl Int :: Int ~ Int
+
+Atcually it is not quite "perfectly ordinary" because it is kind-polymorphic:
+ Refl Maybe :: Maybe ~ Maybe
+
+So the true kind of (~) :: forall k. k -> k -> #. But we don't have
+polymorphic kinds (yet). However, (~) really only appears saturated in
+which case there is no problem in finding the kind of (ty1 ~ ty2). So
+we check that in CoreLint (and, in an assertion, in Kind.typeKind).
+
+Note [The State# TyCon]
+~~~~~~~~~~~~~~~~~~~~~~~
State# is the primitive, unlifted type of states. It has one type parameter,
thus
State# RealWorld
\begin{code}
mkStatePrimTy :: Type -> Type
mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty]
-statePrimTyCon :: TyCon
+
+statePrimTyCon :: TyCon -- See Note [The State# TyCon]
statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep
+
+eqPredPrimTyCon :: TyCon -- The representation type for equality predicates
+ -- See Note [The (~) TyCon]
+eqPredPrimTyCon = pcPrimTyCon eqPredPrimTyConName 2 VoidRep
\end{code}
RealWorld is deeply magical. It is *primitive*, but it is not
Note: the ``state-pairing'' types are not truly primitive, so they are
defined in \tr{TysWiredIn.lhs}, not here.
-
%************************************************************************
%* *
\subsection[TysPrim-arrays]{The primitive array types}
threadIdPrimTyCon :: TyCon
threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep
\end{code}
+
+
+
+%************************************************************************
+%* *
+ Any
+%* *
+%************************************************************************
+
+Note [Any types]
+~~~~~~~~~~~~~~~~
+The type constructor Any::* has these properties
+
+ * It is defined in module GHC.Prim, and exported so that it is
+ available to users. For this reason it's treated like any other
+ primitive type:
+ - has a fixed unique, anyTyConKey,
+ - lives in the global name cache
+ - built with TyCon.PrimTyCon
+
+ * It is lifted, and hence represented by a pointer
+
+ * It is inhabited by at least one value, namely bottom
+
+ * You can unsafely coerce any lifted type to Ayny, and back.
+
+ * It does not claim to be a *data* type, and that's important for
+ the code generator, because the code gen may *enter* a data value
+ but never enters a function value.
+
+ * It is used to instantiate otherwise un-constrained type variables of kind *
+ For example length Any []
+ See Note [Strangely-kinded void TyCons]
+
+In addition, we have a potentially-infinite family of types, one for
+each kind /other than/ *, needed to instantiate otherwise
+un-constrained type variables of kinds other than *. This is a bit
+like tuples; there is a potentially-infinite family. They have slightly
+different characteristics to Any::*:
+
+ * They are built with TyCon.AnyTyCon
+ * They have non-user-writable names like "Any(*->*)"
+ * They are not exported by GHC.Prim
+ * They are uninhabited (of course; not kind *)
+ * They have a unique derived from their OccName (see Note [Uniques of Any])
+ * Their Names do not live in the global name cache
+
+Note [Uniques of Any]
+~~~~~~~~~~~~~~~~~~~~~
+Although Any(*->*), say, doesn't have a binding site, it still needs
+to have a Unique. Unlike tuples (which are also an infinite family)
+there is no convenient way to index them, so we use the Unique from
+their OccName instead. That should be unique,
+ - both wrt each other, because their strings differ
+
+ - and wrt any other Name, because Names get uniques with
+ various 'char' tags, but the OccName of Any will
+ get a Unique built with mkTcOccUnique, which has a particular 'char'
+ tag; see Unique.mkTcOccUnique!
+
+Note [Strangely-kinded void TyCons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Trac #959 for more examples
+
+When the type checker finds a type variable with no binding, which
+means it can be instantiated with an arbitrary type, it usually
+instantiates it to Void. Eg.
+
+ length []
+===>
+ length Any (Nil Any)
+
+But in really obscure programs, the type variable might have a kind
+other than *, so we need to invent a suitably-kinded type.
+
+This commit uses
+ Any for kind *
+ Any(*->*) for kind *->*
+ etc
+
+\begin{code}
+anyTyConName :: Name
+anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon
+
+anyTyCon :: TyCon
+anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep
+
+anyTypeOfKind :: Kind -> Type
+anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) []
+
+anyTyConOfKind :: Kind -> TyCon
+-- Map all superkinds of liftedTypeKind to liftedTypeKind
+anyTyConOfKind kind
+ | isLiftedTypeKind kind = anyTyCon
+ | otherwise = tycon
+ where
+ -- Derive the name from the kind, thus:
+ -- Any(*->*), Any(*->*->*)
+ -- These are names that can't be written by the user,
+ -- and are not allocated in the global name cache
+ str = "Any" ++ showSDoc (pprParendKind kind)
+
+ occ = mkTcOcc str
+ uniq = getUnique occ -- See Note [Uniques of Any]
+ name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax
+ tycon = mkAnyTyCon name kind
+\end{code}
-- others:
import Constants ( mAX_TUPLE_SIZE )
import Module ( Module )
+import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
+import Var
+import TyCon
+import TypeRep
import RdrName
import Name
-import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
-import Var
-import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons,
- mkTupleTyCon, mkAlgTyCon, tyConName,
- TyConParent(NoParentTyCon) )
-
-import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) )
-
-import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys,
- TyThing(..) )
-import Coercion ( unsafeCoercionTyCon, symCoercionTyCon,
- transCoercionTyCon, leftCoercionTyCon,
- rightCoercionTyCon, instCoercionTyCon )
-import TypeRep ( mkArrowKinds, liftedTypeKind, ubxTupleKind )
-import Unique ( incrUnique, mkTupleTyConUnique,
+import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) )
+import Unique ( incrUnique, mkTupleTyConUnique,
mkTupleDataConUnique, mkPArrDataConUnique )
import Data.Array
import FastString
, listTyCon
, parrTyCon
, hetMetCodeTypeTyCon
- , unsafeCoercionTyCon
- , symCoercionTyCon
- , transCoercionTyCon
- , leftCoercionTyCon
- , rightCoercionTyCon
- , instCoercionTyCon
]
\end{code}
(DataTyCon cons is_enum)
NoParentTyCon
is_rec
- True -- All the wired-in tycons have generics
False -- Not in GADT syntax
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
mk_tuple :: Boxity -> Int -> (TyCon,DataCon)
mk_tuple boxity arity = (tycon, tuple_con)
where
- tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info
+ tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity
modu = mkTupleModule boxity arity
tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq
(ATyCon tycon) BuiltInSyntax
(ADataCon tuple_con) BuiltInSyntax
tc_uniq = mkTupleTyConUnique boxity arity
dc_uniq = mkTupleDataConUnique boxity arity
- gen_info = True -- Tuples all have generics..
- -- hmm: that's a *lot* of code
unitTyCon :: TyCon
unitTyCon = tupleTyCon Boxed 0
isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon)
\end{code}
-
Heterogeneous Metaprogramming
\begin{code}
has_side_effects = False
out_of_line = False
commutable = False
- needs_wrapper = False
+ code_size = { primOpCodeSizeDefault }
can_fail = False
strictness = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity lazyDmd) TopRes) }
primop CharLeOp "leChar#" Compare Char# -> Char# -> Bool
primop OrdOp "ord#" GenPrimOp Char# -> Int#
+ with code_size = 0
------------------------------------------------------------------------
section "Int#"
primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #)
{Add with carry. First member of result is (wrapped) sum;
second member is 0 iff no overflow occured.}
+ with code_size = 2
+
primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #)
{Subtract with carry. First member of result is (wrapped) difference;
second member is 0 iff no overflow occured.}
+ with code_size = 2
primop IntGtOp ">#" Compare Int# -> Int# -> Bool
primop IntGeOp ">=#" Compare Int# -> Int# -> Bool
primop IntLeOp "<=#" Compare Int# -> Int# -> Bool
primop ChrOp "chr#" GenPrimOp Int# -> Char#
+ with code_size = 0
primop Int2WordOp "int2Word#" GenPrimOp Int# -> Word#
+ with code_size = 0
+
primop Int2FloatOp "int2Float#" GenPrimOp Int# -> Float#
primop Int2DoubleOp "int2Double#" GenPrimOp Int# -> Double#
in the range 0 to word size - 1 inclusive.}
primop Word2IntOp "word2Int#" GenPrimOp Word# -> Int#
+ with code_size = 0
primop WordGtOp "gtWord#" Compare Word# -> Word# -> Bool
primop WordGeOp "geWord#" Compare Word# -> Word# -> Bool
primop DoubleExpOp "expDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleLogOp "logDouble#" Monadic
Double# -> Double#
with
- needs_wrapper = True
+ code_size = { primOpCodeSizeForeignCall }
can_fail = True
primop DoubleSqrtOp "sqrtDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleSinOp "sinDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleCosOp "cosDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleTanOp "tanDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleAsinOp "asinDouble#" Monadic
Double# -> Double#
with
- needs_wrapper = True
+ code_size = { primOpCodeSizeForeignCall }
can_fail = True
primop DoubleAcosOp "acosDouble#" Monadic
Double# -> Double#
with
- needs_wrapper = True
+ code_size = { primOpCodeSizeForeignCall }
can_fail = True
primop DoubleAtanOp "atanDouble#" Monadic
Double# -> Double#
with
- needs_wrapper = True
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleSinhOp "sinhDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleCoshOp "coshDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleTanhOp "tanhDouble#" Monadic
Double# -> Double#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoublePowerOp "**##" Dyadic
Double# -> Double# -> Double#
{Exponentiation.}
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop DoubleDecode_2IntOp "decodeDouble_2Int#" GenPrimOp
Double# -> (# Int#, Word#, Word#, Int# #)
primop FloatExpOp "expFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatLogOp "logFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
- can_fail = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
+ can_fail = True
primop FloatSqrtOp "sqrtFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatSinOp "sinFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatCosOp "cosFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatTanOp "tanFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatAsinOp "asinFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
- can_fail = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
+ can_fail = True
primop FloatAcosOp "acosFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
- can_fail = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
+ can_fail = True
primop FloatAtanOp "atanFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatSinhOp "sinhFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatCoshOp "coshFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatTanhOp "tanhFloat#" Monadic
Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop FloatPowerOp "powerFloat#" Dyadic
Float# -> Float# -> Float#
- with needs_wrapper = True
+ with
+ code_size = { primOpCodeSizeForeignCall }
primop Float2DoubleOp "float2Double#" GenPrimOp Float# -> Double#
{Write to specified index of mutable array.}
with
has_side_effects = True
+ code_size = 2 -- card update too
primop SizeofArrayOp "sizeofArray#" GenPrimOp
Array# a -> Int#
out_of_line = True
has_side_effects = True
+primop CopyArrayOp "copyArray#" GenPrimOp
+ Array# a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s
+ {Copy a range of the Array# to the specified region in the MutableArray#.
+ Both arrays must fully contain the specified ranges, but this is not checked.
+ The two arrays must not be the same array in different states, but this is not checked either.}
+ with
+ has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop CopyMutableArrayOp "copyMutableArray#" GenPrimOp
+ MutableArray# s a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s
+ {Copy a range of the first MutableArray# to the specified region in the second MutableArray#.
+ Both arrays must fully contain the specified ranges, but this is not checked.}
+ with
+ has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop CloneArrayOp "cloneArray#" GenPrimOp
+ Array# a -> Int# -> Int# -> Array# a
+ {Return a newly allocated Array# with the specified subrange of the provided Array#.
+ The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
+ with
+ has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop CloneMutableArrayOp "cloneMutableArray#" GenPrimOp
+ MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
+ {Return a newly allocated Array# with the specified subrange of the provided Array#.
+ The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
+ with
+ has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop FreezeArrayOp "freezeArray#" GenPrimOp
+ MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, Array# a #)
+ {Return a newly allocated Array# with the specified subrange of the provided MutableArray#.
+ The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
+ with
+ has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
+
+primop ThawArrayOp "thawArray#" GenPrimOp
+ Array# a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
+ {Return a newly allocated Array# with the specified subrange of the provided MutableArray#.
+ The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
+ with
+ has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall + 4 }
+
------------------------------------------------------------------------
section "Byte Arrays"
{Operations on {\tt ByteArray\#}. A {\tt ByteArray\#} is a just a region of
#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64)
primop Addr2IntOp "addr2Int#" GenPrimOp Addr# -> Int#
{Coerce directly from address to int. Strongly deprecated.}
+ with code_size = 0
primop Int2AddrOp "int2Addr#" GenPrimOp Int# -> Addr#
{Coerce directly from int to address. Strongly deprecated.}
+ with code_size = 0
#endif
primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Bool
{Write contents of {\tt MutVar\#}.}
with
has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall } -- for the write barrier
primop SameMutVarOp "sameMutVar#" GenPrimOp
MutVar# s a -> MutVar# s a -> Bool
Int# -> State# s -> State# s
{Sleep specified number of microseconds.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
Int# -> State# s -> State# s
{Block until input is available on specified file descriptor.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
Int# -> State# s -> State# s
{Block until output is possible on specified file descriptor.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
{Asynchronously read bytes from specified file descriptor.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
{Asynchronously write bytes from specified file descriptor.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
Addr# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #)
{Asynchronously perform procedure (first arg), passing it 2nd arg.}
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
primop TouchOp "touch#" GenPrimOp
o -> State# RealWorld -> State# RealWorld
with
+ code_size = { 0 }
has_side_effects = True
------------------------------------------------------------------------
primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp
StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #)
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
primop MakeStableNameOp "makeStableName#" GenPrimOp
a -> State# RealWorld -> (# State# RealWorld, StableName# a #)
with
- needs_wrapper = True
has_side_effects = True
out_of_line = True
-- Note that Par is lazy to avoid that the sparked thing
-- gets evaluted strictly, which it should *not* be
has_side_effects = True
+ code_size = { primOpCodeSizeForeignCall }
primop GetSparkOp "getSpark#" GenPrimOp
State# s -> (# State# s, Int#, a #)
primop AddrToHValueOp "addrToHValue#" GenPrimOp
Addr# -> (# a #)
{Convert an {\tt Addr\#} to a followable type.}
+ with
+ code_size = 0
primop MkApUpd0_Op "mkApUpd0#" GenPrimOp
BCO# -> (# a #)
but never enters a function value.
It's also used to instantiate un-constrained type variables after type
- checking. For example
+ checking. For example, {\tt length} has type
+
+ {\tt length :: forall a. [a] -> Int}
+
+ and the list datacon for the empty list has type
+
+ {\tt [] :: forall a. [a]}
+
+ In order to compose these two terms as {\tt length []} a type
+ application is required, but there is no constraint on the
+ choice. In this situation GHC uses {\tt Any}:
- {\tt length Any []}
+ {\tt length Any ([] Any)}
Annoyingly, we sometimes need {\tt Any}s of other kinds, such as {\tt (* -> *)} etc.
This is a bit like tuples. We define a couple of useful ones here,
import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
-import RdrHsSyn
import RnHsSyn
import TcRnMonad
import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch)
rnBind _ trim (L loc bind@(PatBind { pat_lhs = pat
, pat_rhs = grhss
-- pat fvs were stored in bind_fvs
- -- after processing the LHS
+ -- after processing the LHS
, bind_fvs = pat_fvs }))
= setSrcSpan loc $
do { let bndrs = collectPatBinders pat
, fun_infix = is_infix
, fun_matches = matches }))
-- invariant: no free vars here when it's a FunBind
- = setSrcSpan loc $
+ = setSrcSpan loc $
do { let plain_name = unLoc name
; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
\begin{code}
rnMethodBinds :: Name -- Class name
-> (Name -> [Name]) -- Signature tyvar function
- -> [Name] -- Names for generic type variables
-> LHsBinds RdrName
-> RnM (LHsBinds Name, FreeVars)
-rnMethodBinds cls sig_fn gen_tyvars binds
- = foldlM do_one (emptyBag,emptyFVs) (bagToList binds)
+rnMethodBinds cls sig_fn binds
+ = do { checkDupRdrNames meth_names
+ -- Check that the same method is not given twice in the
+ -- same instance decl instance C T where
+ -- f x = ...
+ -- g y = ...
+ -- f x = ...
+ -- We must use checkDupRdrNames because the Name of the
+ -- method is the Name of the class selector, whose SrcSpan
+ -- points to the class declaration; and we use rnMethodBinds
+ -- for instance decls too
+
+ ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
where
+ meth_names = collectMethodBinders binds
do_one (binds,fvs) bind
- = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind
+ = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind
; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
rnMethodBind :: Name
-> (Name -> [Name])
- -> [Name]
-> LHsBindLR RdrName RdrName
-> RnM (Bag (LHsBindLR Name Name), FreeVars)
-rnMethodBind cls sig_fn gen_tyvars
+rnMethodBind cls sig_fn
(L loc bind@(FunBind { fun_id = name, fun_infix = is_infix
, fun_matches = MatchGroup matches _ }))
= setSrcSpan loc $ do
-- We use the selector name as the binder
(new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
- mapFvRn (rn_match (FunRhs plain_name is_infix)) matches
+ mapFvRn (rnMatch (FunRhs plain_name is_infix)) matches
let new_group = MatchGroup new_matches placeHolderType
when is_infix $ checkPrecMatch plain_name new_group
, bind_fvs = fvs })),
fvs `addOneFV` plain_name)
-- The 'fvs' field isn't used for method binds
- where
- -- Truly gruesome; bring into scope the correct members of the generic
- -- type variables. See comments in RnSource.rnSourceDecl(ClassDecl)
- rn_match info match@(L _ (Match (L _ (TypePat ty) : _) _ _))
- = extendTyVarEnvFVRn gen_tvs $
- rnMatch info match
- where
- tvs = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty)
- gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs]
-
- rn_match info match = rnMatch info match
-- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBind _ _ _ (L loc bind@(PatBind {})) = do
+rnMethodBind _ _ (L loc bind@(PatBind {})) = do
addErrAt loc (methodBindErr bind)
return (emptyBag, emptyFVs)
-rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b)
+rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b)
\end{code}
-- Check for duplicates on RdrName version,
-- because renamed version has unboundName for
-- not-in-scope binders, which gives bogus dup-sig errors
-
+ -- NB: in a class decl, a 'generic' sig is not considered
+ -- equal to an ordinary sig, so we allow, say
+ -- class C a where
+ -- op :: a -> a
+ -- default op :: Eq a => a -> a
+
; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs
; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs'
; new_ty <- rnHsSigType (quotes (ppr v)) ty
; return (TypeSig new_v new_ty) }
+renameSig mb_names sig@(GenericSig v ty)
+ = do { defaultSigs_on <- xoptM Opt_DefaultSignatures
+ ; unless defaultSigs_on (addErr (defaultSigErr sig))
+ ; new_v <- lookupSigOccRn mb_names sig v
+ ; new_ty <- rnHsSigType (quotes (ppr v)) ty
+ ; return (GenericSig new_v new_ty) }
+
renameSig _ (SpecInstSig ty)
= do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
; return (SpecInstSig new_ty) }
-- Standard Haskell 1.4 guards are just a single boolean
-- expression, rather than a list of qualifiers as in the
-- Glasgow extension
- is_standard_guard [] = True
- is_standard_guard [L _ (ExprStmt _ _ _)] = True
- is_standard_guard _ = False
+ is_standard_guard [] = True
+ is_standard_guard [L _ (ExprStmt _ _ _ _)] = True
+ is_standard_guard _ = False
\end{code}
%************************************************************************
= addErrAt loc $
sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]
+defaultSigErr :: Sig RdrName -> SDoc
+defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:"))
+ 2 (ppr sig)
+ , ptext (sLit "Use -XDefaultSignatures to enable default signatures") ]
+
methodBindErr :: HsBindLR RdrName RdrName -> SDoc
methodBindErr mbind
= hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations"))
nonStdGuardErr guards
= hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)"))
4 (interpp'SP guards)
+
\end{code}
import LoadIface ( loadInterfaceForName )
import UniqSet
import Data.List
-import Util ( isSingleton )
+import Util ( isSingleton, snocView )
import ListSetOps ( removeDups )
import Outputable
import SrcLoc
rnLExpr expr `thenM` \ (expr',fvExpr) ->
return (HsLet binds' expr', fvExpr)
-rnExpr (HsDo do_or_lc stmts body _)
- = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ \ _ ->
- rnLExpr body
- ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
+rnExpr (HsDo do_or_lc stmts _)
+ = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs))
+ ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
rnExpr (ExplicitList _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
convertOpFormsCmd (HsLet binds cmd)
= HsLet binds (convertOpFormsLCmd cmd)
-convertOpFormsCmd (HsDo ctxt stmts body ty)
- = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
- (convertOpFormsLCmd body) ty
+convertOpFormsCmd (HsDo DoExpr stmts ty)
+ = HsDo ArrowExpr (map (fmap convertOpFormsStmt) stmts) ty
+ -- Mark the HsDo as begin the body of an arrow command
-- Anything else is unchanged. This includes HsArrForm (already done),
-- things with no sub-commands, and illegal commands (which will be
convertOpFormsStmt :: StmtLR id id -> StmtLR id id
convertOpFormsStmt (BindStmt pat cmd _ _)
= BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
-convertOpFormsStmt (ExprStmt cmd _ _)
- = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
+convertOpFormsStmt (ExprStmt cmd _ _ _)
+ = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType
convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
= stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
convertOpFormsStmt stmt = stmt
methodNamesCmd (HsIf _ _ c1 c2)
= methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
-methodNamesCmd (HsLet _ c) = methodNamesLCmd c
-
-methodNamesCmd (HsDo _ stmts body _)
- = methodNamesStmts stmts `plusFV` methodNamesLCmd body
-
-methodNamesCmd (HsApp c _) = methodNamesLCmd c
-
-methodNamesCmd (HsLam match) = methodNamesMatch match
+methodNamesCmd (HsLet _ c) = methodNamesLCmd c
+methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts
+methodNamesCmd (HsApp c _) = methodNamesLCmd c
+methodNamesCmd (HsLam match) = methodNamesMatch match
methodNamesCmd (HsCase _ matches)
= methodNamesMatch matches `addOneFV` choiceAName
methodNamesLStmt = methodNamesStmt . unLoc
methodNamesStmt :: StmtLR Name Name -> FreeVars
-methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd
+methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd
+methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd
methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd
methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
methodNamesStmt (LetStmt _) = emptyFVs
-methodNamesStmt (ParStmt _) = emptyFVs
-methodNamesStmt (TransformStmt {}) = emptyFVs
-methodNamesStmt (GroupStmt {}) = emptyFVs
- -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error
+methodNamesStmt (ParStmt _ _ _ _) = emptyFVs
+methodNamesStmt (TransStmt {}) = emptyFVs
+ -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error
-- here so we just do what's convenient
\end{code}
\begin{code}
rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
-rnBracket (VarBr n) = do { name <- lookupOccRn n
- ; this_mod <- getModule
- ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
- do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
- ; return () } -- only way that is going to happen
- ; return (VarBr name, unitFV name) }
- where
- msg = ptext (sLit "Need interface for Template Haskell quoted Name")
+rnBracket (VarBr n)
+ = do { name <- lookupOccRn n
+ ; this_mod <- getModule
+ ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes
+ do { _ <- loadInterfaceForName msg name -- the home interface is loaded, and
+ ; return () } -- this is the only way that is going
+ -- to happen
+ ; return (VarBr name, unitFV name) }
+ where
+ msg = ptext (sLit "Need interface for Template Haskell quoted Name")
rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr e', fvs) }
rnSrcDecls group
-- Discard the tcg_env; it contains only extra info about fixity
- ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
+ ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$
+ ppr (duUses (tcg_dus tcg_env))))
; return (DecBrG group', duUses (tcg_dus tcg_env)) }
rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
\begin{code}
rnStmts :: HsStmtContext Name -> [LStmt RdrName]
- -> ([Name] -> RnM (thing, FreeVars))
- -> RnM (([LStmt Name], thing), FreeVars)
+ -> ([Name] -> RnM (thing, FreeVars))
+ -> RnM (([LStmt Name], thing), FreeVars)
-- Variables bound by the Stmts, and mentioned in thing_inside,
-- do not appear in the result FreeVars
---
--- Renaming a single RecStmt can give a sequence of smaller Stmts
-rnStmts _ [] thing_inside
- = do { (res, fvs) <- thing_inside []
- ; return (([], res), fvs) }
+rnStmts ctxt [] thing_inside
+ = do { checkEmptyStmts ctxt
+ ; (thing, fvs) <- thing_inside []
+ ; return (([], thing), fvs) }
+
+rnStmts MDoExpr stmts thing_inside -- Deal with mdo
+ = -- Behave like do { rec { ...all but last... }; last }
+ do { ((stmts1, (stmts2, thing)), fvs)
+ <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ ->
+ do { last_stmt' <- checkLastStmt MDoExpr last_stmt
+ ; rnStmt MDoExpr last_stmt' thing_inside }
+ ; return (((stmts1 ++ stmts2), thing), fvs) }
+ where
+ Just (all_but_last, last_stmt) = snocView stmts
+
+rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside
+ | null lstmts
+ = setSrcSpan loc $
+ do { lstmt' <- checkLastStmt ctxt lstmt
+ ; rnStmt ctxt lstmt' thing_inside }
-rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside
+ | otherwise
= do { ((stmts1, (stmts2, thing)), fvs)
- <- setSrcSpan loc $
- rnStmt ctxt stmt $ \ bndrs1 ->
- rnStmts ctxt stmts $ \ bndrs2 ->
- thing_inside (bndrs1 ++ bndrs2)
+ <- setSrcSpan loc $
+ do { checkStmt ctxt lstmt
+ ; rnStmt ctxt lstmt $ \ bndrs1 ->
+ rnStmts ctxt lstmts $ \ bndrs2 ->
+ thing_inside (bndrs1 ++ bndrs2) }
; return (((stmts1 ++ stmts2), thing), fvs) }
-
-rnStmt :: HsStmtContext Name -> LStmt RdrName
+----------------------
+rnStmt :: HsStmtContext Name
+ -> LStmt RdrName
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt Name], thing), FreeVars)
-- Variables bound by the Stmt, and mentioned in thing_inside,
-- do not appear in the result FreeVars
-rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
+rnStmt ctxt (L loc (LastStmt expr _)) thing_inside
= do { (expr', fv_expr) <- rnLExpr expr
- ; (then_op, fvs1) <- lookupSyntaxName thenMName
- ; (thing, fvs2) <- thing_inside []
- ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
- fv_expr `plusFV` fvs1 `plusFV` fvs2) }
+ ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName
+ ; (thing, fvs3) <- thing_inside []
+ ; return (([L loc (LastStmt expr' ret_op)], thing),
+ fv_expr `plusFV` fvs1 `plusFV` fvs3) }
+
+rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside
+ = do { (expr', fv_expr) <- rnLExpr expr
+ ; (then_op, fvs1) <- lookupStmtName ctxt thenMName
+ ; (guard_op, fvs2) <- if isListCompExpr ctxt
+ then lookupStmtName ctxt guardMName
+ else return (noSyntaxExpr, emptyFVs)
+ -- Only list/parr/monad comprehensions use 'guard'
+ -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
+ -- Here "gd" is a guard
+ ; (thing, fvs3) <- thing_inside []
+ ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing),
+ fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
= do { (expr', fv_expr) <- rnLExpr expr
-- The binders do not scope over the expression
- ; (bind_op, fvs1) <- lookupSyntaxName bindMName
- ; (fail_op, fvs2) <- lookupSyntaxName failMName
+ ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
+ ; (fail_op, fvs2) <- lookupStmtName ctxt failMName
; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
{ (thing, fvs3) <- thing_inside (collectPatBinders pat')
; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
-- fv_expr shouldn't really be filtered by the rnPatsAndThen
-- but it does not matter because the names are unique
-rnStmt ctxt (L loc (LetStmt binds)) thing_inside
- = do { checkLetStmt ctxt binds
- ; rnLocalBindsAndThen binds $ \binds' -> do
+rnStmt _ (L loc (LetStmt binds)) thing_inside
+ = do { rnLocalBindsAndThen binds $ \binds' -> do
{ (thing, fvs) <- thing_inside (collectLocalBinders binds')
; return (([L loc (LetStmt binds')], thing), fvs) } }
rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
- = do { checkRecStmt ctxt
-
+ = do {
-- Step1: Bring all the binders of the mdo into scope
-- (Remember that this also removes the binders from the
-- finally-returned free-vars.)
{ let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
emptyNameSet segs
; (thing, fvs_later) <- thing_inside bndrs
- ; (return_op, fvs1) <- lookupSyntaxName returnMName
- ; (mfix_op, fvs2) <- lookupSyntaxName mfixName
- ; (bind_op, fvs3) <- lookupSyntaxName bindMName
+ ; (return_op, fvs1) <- lookupStmtName ctxt returnMName
+ ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName
+ ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName
; let
-- Step 2: Fill in the fwd refs.
-- The segments are all singletons, but their fwd-ref
; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
-rnStmt ctxt (L loc (ParStmt segs)) thing_inside
- = do { checkParStmt ctxt
- ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
- ; return (([L loc (ParStmt segs')], thing), fvs) }
-
-rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
- = do { checkTransformStmt ctxt
-
- ; (using', fvs1) <- rnLExpr using
-
- ; ((stmts', (by', used_bndrs, thing)), fvs2)
- <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
- do { (by', fvs_by) <- case by of
- Nothing -> return (Nothing, emptyFVs)
- Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
- ; (thing, fvs_thing) <- thing_inside bndrs
- ; let fvs = fvs_by `plusFV` fvs_thing
- used_bndrs = filter (`elemNameSet` fvs) bndrs
- -- The paper (Fig 5) has a bug here; we must treat any free varaible of
- -- the "thing inside", **or of the by-expression**, as used
- ; return ((by', used_bndrs, thing), fvs) }
-
- ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
- fvs1 `plusFV` fvs2) }
-
-rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
- = do { checkTransformStmt ctxt
-
- -- Rename the 'using' expression in the context before the transform is begun
- ; (using', fvs1) <- case using of
- Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
- Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
- ; return (Right e', fvs) }
+rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
+ = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName
+ ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName
+ ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
+ ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
+ ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
+ , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
+
+rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
+ , trS_using = using })) thing_inside
+ = do { -- Rename the 'using' expression in the context before the transform is begun
+ (using', fvs1) <- case form of
+ GroupFormB -> do { (e,fvs) <- lookupStmtName ctxt groupMName
+ ; return (noLoc e, fvs) }
+ _ -> rnLExpr using
-- Rename the stmts and the 'by' expression
-- Keep track of the variables mentioned in the 'by' expression
; ((stmts', (by', used_bndrs, thing)), fvs2)
- <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
+ <- rnStmts (TransStmtCtxt ctxt) stmts $ \ bndrs ->
do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = fvs_by `plusFV` fvs_thing
used_bndrs = filter (`elemNameSet` fvs) bndrs
+ -- The paper (Fig 5) has a bug here; we must treat any free varaible
+ -- of the "thing inside", **or of the by-expression**, as used
; return ((by', used_bndrs, thing), fvs) }
- ; let all_fvs = fvs1 `plusFV` fvs2
+ -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
+ ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
+ ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName
+ ; (fmap_op, fvs5) <- case form of
+ ThenForm -> return (noSyntaxExpr, emptyFVs)
+ _ -> lookupStmtName ctxt fmapName
+
+ ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
+ `plusFV` fvs4 `plusFV` fvs5
bndr_map = used_bndrs `zip` used_bndrs
- -- See Note [GroupStmt binder map] in HsExpr
+ -- See Note [TransStmt binder map] in HsExpr
; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
- ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
-
+ ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
+ , trS_by = by', trS_using = using', trS_form = form
+ , trS_ret = return_op, trS_bind = bind_op
+ , trS_fmap = fmap_op })], thing), all_fvs) }
type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts
cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
<+> quotes (ppr (head vs)))
+
+lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
+-- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable
+-- Neither is ArrowExpr, which has its own desugarer in DsArrows
+lookupStmtName ctxt n
+ = case ctxt of
+ ListComp -> not_rebindable
+ PArrComp -> not_rebindable
+ ArrowExpr -> not_rebindable
+ PatGuard {} -> not_rebindable
+
+ DoExpr -> rebindable
+ MDoExpr -> rebindable
+ MonadComp -> rebindable
+ GhciStmt -> rebindable -- I suppose?
+
+ ParStmtCtxt c -> lookupStmtName c n -- Look inside to
+ TransStmtCtxt c -> lookupStmtName c n -- the parent context
+ where
+ rebindable = lookupSyntaxName n
+ not_rebindable = return (HsVar n, emptyFVs)
\end{code}
Note [Renaming parallel Stmts]
-- so we don't bother to compute it accurately in the other cases
-> RnM [(LStmtLR Name RdrName, FreeVars)]
-rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
- -- this is actually correct
- emptyFVs)]
+rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c))
+ = return [(L loc (ExprStmt expr a b c), emptyFVs)]
+
+rn_rec_stmt_lhs _ (L loc (LastStmt expr a))
+ = return [(L loc (LastStmt expr a), emptyFVs)]
rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
= do
rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec
= rn_rec_stmts_lhs fix_env stmts
-rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo
- = pprPanic "rn_rec_stmt" (ppr stmt)
-
-rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
+rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _)) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt" (ppr stmt)
-rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo
+rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt" (ppr stmt)
rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
-- Rename a Stmt that is inside a RecStmt (or mdo)
-- Assumes all binders are already in scope
-- Turns each stmt into a singleton Stmt
-rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
+rn_rec_stmt _ (L loc (LastStmt expr _)) _
+ = do { (expr', fv_expr) <- rnLExpr expr
+ ; (ret_op, fvs1) <- lookupSyntaxName returnMName
+ ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
+ L loc (LastStmt expr' ret_op))] }
+
+rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _
= rnLExpr expr `thenM` \ (expr', fvs) ->
lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) ->
return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
- L loc (ExprStmt expr' then_op placeHolderType))]
+ L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))]
rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
= rnLExpr expr `thenM` \ (expr', fv_expr) ->
rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
= pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
-rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo
- = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
-
-rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo
- = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
+rn_rec_stmt _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo
+ = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
= panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
%************************************************************************
\begin{code}
+checkEmptyStmts :: HsStmtContext Name -> RnM ()
+-- We've seen an empty sequence of Stmts... is that ok?
+checkEmptyStmts ctxt
+ = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
-----------------------
--- Checking when a particular Stmt is ok
-checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
-checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
-checkLetStmt _ctxt _binds = return ()
- -- We do not allow implicit-parameter bindings in a parallel
- -- list comprehension. I'm not sure what it might mean.
+okEmpty :: HsStmtContext a -> Bool
+okEmpty (PatGuard {}) = True
+okEmpty _ = False
----------
-checkRecStmt :: HsStmtContext Name -> RnM ()
-checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo'
-checkRecStmt DoExpr = return () -- and in 'do'
-checkRecStmt ctxt = addErr msg
- where
- msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
+emptyErr :: HsStmtContext Name -> SDoc
+emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension")
+emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'")
+emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt
----------
-checkParStmt :: HsStmtContext Name -> RnM ()
-checkParStmt _
- = do { parallel_list_comp <- xoptM Opt_ParallelListComp
- ; checkErr parallel_list_comp msg }
+----------------------
+checkLastStmt :: HsStmtContext Name
+ -> LStmt RdrName
+ -> RnM (LStmt RdrName)
+checkLastStmt ctxt lstmt@(L loc stmt)
+ = case ctxt of
+ ListComp -> check_comp
+ MonadComp -> check_comp
+ PArrComp -> check_comp
+ ArrowExpr -> check_do
+ DoExpr -> check_do
+ MDoExpr -> check_do
+ _ -> check_other
where
- msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
+ check_do -- Expect ExprStmt, and change it to LastStmt
+ = case stmt of
+ ExprStmt e _ _ _ -> return (L loc (mkLastStmt e))
+ LastStmt {} -> return lstmt -- "Deriving" clauses may generate a
+ -- LastStmt directly (unlike the parser)
+ _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
+ last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt
+ <+> ptext (sLit "must be an expression"))
+
+ check_comp -- Expect LastStmt; this should be enforced by the parser!
+ = case stmt of
+ LastStmt {} -> return lstmt
+ _ -> pprPanic "checkLastStmt" (ppr lstmt)
+
+ check_other -- Behave just as if this wasn't the last stmt
+ = do { checkStmt ctxt lstmt; return lstmt }
----------
-checkTransformStmt :: HsStmtContext Name -> RnM ()
-checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the
- -- desugarer will break when we come to operate on a parallel array
- = do { transform_list_comp <- xoptM Opt_TransformListComp
- ; checkErr transform_list_comp msg }
- where
- msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
-checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
-checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension
-checkTransformStmt ctxt = addErr msg
+-- Checking when a particular Stmt is ok
+checkStmt :: HsStmtContext Name
+ -> LStmt RdrName
+ -> RnM ()
+checkStmt ctxt (L _ stmt)
+ = do { dflags <- getDOpts
+ ; case okStmt dflags ctxt stmt of
+ Nothing -> return ()
+ Just extra -> addErr (msg $$ extra) }
where
- msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
+ msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement")
+ , ptext (sLit "in") <+> pprAStmtContext ctxt ]
+
+pprStmtCat :: Stmt a -> SDoc
+pprStmtCat (TransStmt {}) = ptext (sLit "transform")
+pprStmtCat (LastStmt {}) = ptext (sLit "return expression")
+pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion")
+pprStmtCat (BindStmt {}) = ptext (sLit "binding")
+pprStmtCat (LetStmt {}) = ptext (sLit "let")
+pprStmtCat (RecStmt {}) = ptext (sLit "rec")
+pprStmtCat (ParStmt {}) = ptext (sLit "parallel")
+
+------------
+isOK, notOK :: Maybe SDoc
+isOK = Nothing
+notOK = Just empty
+
+okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
+ :: DynFlags -> HsStmtContext Name
+ -> Stmt RdrName -> Maybe SDoc
+-- Return Nothing if OK, (Just extra) if not ok
+-- The "extra" is an SDoc that is appended to an generic error message
+
+okStmt dflags ctxt stmt
+ = case ctxt of
+ PatGuard {} -> okPatGuardStmt stmt
+ ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt
+ DoExpr -> okDoStmt dflags ctxt stmt
+ MDoExpr -> okDoStmt dflags ctxt stmt
+ ArrowExpr -> okDoStmt dflags ctxt stmt
+ GhciStmt -> okDoStmt dflags ctxt stmt
+ ListComp -> okCompStmt dflags ctxt stmt
+ MonadComp -> okCompStmt dflags ctxt stmt
+ PArrComp -> okPArrStmt dflags ctxt stmt
+ TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
+
+-------------
+okPatGuardStmt :: Stmt RdrName -> Maybe SDoc
+okPatGuardStmt stmt
+ = case stmt of
+ ExprStmt {} -> isOK
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ _ -> notOK
+
+-------------
+okParStmt dflags ctxt stmt
+ = case stmt of
+ LetStmt (HsIPBinds {}) -> notOK
+ _ -> okStmt dflags ctxt stmt
+
+----------------
+okDoStmt dflags ctxt stmt
+ = case stmt of
+ RecStmt {}
+ | Opt_DoRec `xopt` dflags -> isOK
+ | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec'
+ | otherwise -> Just (ptext (sLit "Use -XDoRec"))
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ ExprStmt {} -> isOK
+ _ -> notOK
+
+----------------
+okCompStmt dflags _ stmt
+ = case stmt of
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ ExprStmt {} -> isOK
+ ParStmt {}
+ | Opt_ParallelListComp `xopt` dflags -> isOK
+ | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
+ TransStmt {}
+ | Opt_TransformListComp `xopt` dflags -> isOK
+ | otherwise -> Just (ptext (sLit "Use -XTransformListComp"))
+ RecStmt {} -> notOK
+ LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt)
+
+----------------
+okPArrStmt dflags _ stmt
+ = case stmt of
+ BindStmt {} -> isOK
+ LetStmt {} -> isOK
+ ExprStmt {} -> isOK
+ ParStmt {}
+ | Opt_ParallelListComp `xopt` dflags -> isOK
+ | otherwise -> Just (ptext (sLit "Use -XParallelListComp"))
+ TransStmt {} -> notOK
+ RecStmt {} -> notOK
+ LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt)
---------
checkTupleSection :: [HsTupArg RdrName] -> RnM ()
extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames,
-- Free variables
- hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs,
-
- maybeGenericMatch
+ hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs
) where
#include "HsVersions.h"
get (HsParTy ty) = getl ty
get (HsBangTy _ ty) = getl ty
get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds)
- get (HsNumTy _) = emptyNameSet
get (HsTyVar tv) = unitNameSet tv
get (HsSpliceTy _ fvs _) = fvs
get (HsQuasiQuoteTy {}) = emptyNameSet
hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs)
hsSigFVs :: Sig Name -> FreeVars
-hsSigFVs (TypeSig _ ty) = extractHsTyNames ty
-hsSigFVs (SpecInstSig ty) = extractHsTyNames ty
-hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty
-hsSigFVs _ = emptyFVs
+hsSigFVs (TypeSig _ ty) = extractHsTyNames ty
+hsSigFVs (GenericSig _ ty) = extractHsTyNames ty
+hsSigFVs (SpecInstSig ty) = extractHsTyNames ty
+hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty
+hsSigFVs _ = emptyFVs
----------------
conDeclFVs :: LConDecl Name -> FreeVars
bangTyFVs :: LHsType Name -> FreeVars
bangTyFVs bty = extractHsTyNames (getBangType bty)
\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{A few functions on generic defintions
-%* *
-%************************************************************************
-
-These functions on generics are defined over Matches Name, which is
-why they are here and not in HsMatches.
-
-\begin{code}
-maybeGenericMatch :: LMatch Name -> Maybe (HsType Name, LMatch Name)
- -- Tells whether a Match is for a generic definition
- -- and extract the type from a generic match and put it at the front
-
-maybeGenericMatch (L loc (Match (L _ (TypePat (L _ ty)) : pats) sig_ty grhss))
- = Just (ty, L loc (Match pats sig_ty grhss))
-
-maybeGenericMatch _ = Nothing
-\end{code}
import TcEnv ( isBrackStage )
import RnEnv
import RnHsDoc ( rnHsDoc )
-import IfaceEnv ( ifaceExportNames )
+import IfaceEnv ( ifaceExportNames )
import LoadIface ( loadSrcInterface )
import TcRnMonad
; pats' <- rnLPatsAndThen mk pats
; return (TuplePat pats' boxed placeHolderType) }
-rnPatAndThen _ (TypePat ty)
- = do { ty' <- liftCpsFV $ rnHsTypeFVs (text "In a type pattern") ty
- ; return (TypePat ty') }
-
#ifndef GHCI
rnPatAndThen _ p@(QuasiQuotePat {})
= pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p)
import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
-import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
+import RdrHsSyn ( extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
makeMiniFixityEnv)
import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn,
lookupTopBndrRn, lookupLocatedTopBndrRn,
- lookupOccRn, newLocalBndrsRn, bindLocalNamesFV,
+ lookupOccRn, bindLocalNamesFV,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
bindLocalNames, checkDupRdrNames, mapFvRn
-- The typechecker (not the renamer) checks that all
-- the bindings are for the right class
let
- meth_names = collectMethodBinders mbinds
(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
in
- checkDupRdrNames meth_names `thenM_`
- -- Check that the same method is not given twice in the
- -- same instance decl instance C T where
- -- f x = ...
- -- g y = ...
- -- f x = ...
- -- We must use checkDupRdrNames because the Name of the
- -- method is the Name of the class selector, whose SrcSpan
- -- points to the class declaration
-
extendTyVarEnvForMethodBinds inst_tyvars (
-- (Slightly strangely) the forall-d tyvars scope over
-- the method bindings too
rnMethodBinds cls (\_ -> []) -- No scoped tyvars
- [] mbinds
+ mbinds
) `thenM` \ (mbinds', meth_fvs) ->
-- Rename the associated types
-- The typechecker (not the renamer) checks that all
-- we want to name both "x" tyvars with the same unique, so that they are
-- easy to group together in the typechecker.
; (mbinds', meth_fvs)
- <- extendTyVarEnvForMethodBinds tyvars' $ do
- { name_env <- getLocalRdrEnv
- ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
- not (unLoc tv `elemLocalRdrEnv` name_env) ]
+ <- extendTyVarEnvForMethodBinds tyvars' $
-- No need to check for duplicate method signatures
-- since that is done by RnNames.extendGlobalRdrEnvRn
-- and the methods are already in scope
- ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
- ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
+ rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds
-- Haddock docs
; docs' <- mapM (wrapLocM rnDocDecl) docs
add_sig :: LSig a -> HsValBinds a -> HsValBinds a
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"
-\end{code}
\ No newline at end of file
+\end{code}
import TcRnMonad
import RdrName
import PrelNames
-import TypeRep ( funTyConName )
+import TysPrim ( funTyConName )
import Name
import SrcLoc
import NameSet
= do { flds' <- rnConDeclFields doc flds
; return (HsRecTy flds') }
-rnHsType _ (HsNumTy i)
- | i == 1 = return (HsNumTy i)
- | otherwise = addErr err_msg >> return (HsNumTy i)
- where
- err_msg = ptext (sLit "Only unit numeric type pattern is valid")
-
-
rnHsType doc (HsFunTy ty1 ty2) = do
ty1' <- rnLHsType doc ty1
-- Might find a for-all as the arg of a function type
tryForCSE :: CSEnv -> CoreExpr -> CoreExpr
tryForCSE _ (Type t) = Type t
+tryForCSE _ (Coercion c) = Coercion c
tryForCSE env expr = case lookupCSEnv env expr' of
Just smaller_expr -> smaller_expr
Nothing -> expr'
cseExpr :: CSEnv -> CoreExpr -> CoreExpr
cseExpr _ (Type t) = Type t
+cseExpr _ (Coercion co) = Coercion co
cseExpr _ (Lit lit) = Lit lit
cseExpr env (Var v) = Var (lookupSubst env v)
cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a)
simpl_phase phase names iter
= CoreDoPasses
- [ maybe_strictness_before phase
+ $ [ maybe_strictness_before phase
, CoreDoSimplify iter
(base_mode { sm_phase = Phase phase
, sm_names = names })
- , maybe_rule_check (Phase phase)
- ]
+ , maybe_rule_check (Phase phase) ]
+
+ -- Vectorisation can introduce a fair few common sub expressions involving
+ -- DPH primitives. For example, see the Reverse test from dph-examples.
+ -- We need to eliminate these common sub expressions before their definitions
+ -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings,
+ -- so we also run simpl_gently to inline them.
+ ++ (if dopt Opt_Vectorise dflags && phase == 3
+ then [CoreCSE, simpl_gently]
+ else [])
vectorisation
= runWhen (dopt Opt_Vectorise dflags) $
-> CoreExprWithFVs -- Input expr
-> CoreExpr -- Result
-fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
-
-fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop )
- Type ty
-fiExpr to_drop (_, AnnCast expr co)
- = Cast (fiExpr to_drop expr) co -- Just float in past coercion
-
-fiExpr _ (_, AnnLit lit) = Lit lit
+fiExpr to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit
+fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty
+fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v)
+fiExpr to_drop (_, AnnCoercion co) = mkCoLets' to_drop (Coercion co)
+fiExpr to_drop (_, AnnCast expr (fvs_co, co))
+ = mkCoLets' (drop_here ++ co_drop) $
+ Cast (fiExpr e_drop expr) co
+ where
+ [drop_here, e_drop, co_drop] = sepBindsByDropPoint False [freeVarsOf expr, fvs_co] to_drop
\end{code}
Applications: we do float inside applications, mainly because we
go seen_one_shot_id [] = seen_one_shot_id
go seen_one_shot_id (b:bs)
- | isTyCoVar b = go seen_one_shot_id bs
+ | isTyVar b = go seen_one_shot_id bs
| isOneShotBndr b = go True bs
| otherwise = False -- Give up at a non-one-shot Id
\end{code}
-----------------
floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v)
floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty)
+floatExpr _ (Coercion co) = (zeroStats, emptyFloats, Coercion co)
floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit)
floatExpr lvl (App e a)
libCase env (Var v) = libCaseId env v
libCase _ (Lit lit) = Lit lit
libCase _ (Type ty) = Type ty
+libCase _ (Coercion co) = Coercion co
libCase env (App fun arg) = App (libCase env fun) (libCase env arg)
libCase env (Note note body) = Note note (libCase env body)
libCase env (Cast e co) = Cast (libCase env e) co
import CoreSyn
import CoreFVs
-import Type ( tyVarsOfType )
-import CoreUtils ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp )
-import Coercion ( CoercionI(..), mkSymCoI )
+import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCoerce )
import Id
import NameEnv
import NameSet
import Name ( Name, localiseName )
import BasicTypes
+import Coercion
+
import VarSet
import VarEnv
-import Var ( varUnique )
+import Var
+
import Maybes ( orElse )
import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR )
import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
[CoreBind])
occAnalBind env _ (NonRec binder rhs) body_usage
- | isTyCoVar binder -- A type let; we don't gather usage info
+ | isTyVar binder -- A type let; we don't gather usage info
= (body_usage, [NonRec binder rhs])
| not (binder `usedIn` body_usage) -- It's not mentioned
make_node (bndr, rhs)
= (details, varUnique bndr, keysUFM out_edges)
- where
+ where
details = ND { nd_bndr = bndr, nd_rhs = rhs'
, nd_uds = rhs_usage3, nd_inl = inl_fvs}
-> (UsageDetails, -- Gives info only about the "interesting" Ids
CoreExpr)
-occAnal _ (Type t) = (emptyDetails, Type t)
-occAnal env (Var v) = (mkOneOcc env v False, Var v)
+occAnal _ expr@(Type _) = (emptyDetails, expr)
+occAnal _ expr@(Lit _) = (emptyDetails, expr)
+occAnal env expr@(Var v) = (mkOneOcc env v False, expr)
-- At one stage, I gathered the idRuleVars for v here too,
-- which in a way is the right thing to do.
-- But that went wrong right after specialisation, when
-- the *occurrences* of the overloaded function didn't have any
-- rules in them, so the *specialised* versions looked as if they
-- weren't used at all.
-\end{code}
-We regard variables that occur as constructor arguments as "dangerousToDup":
-
-\begin{verbatim}
-module A where
-f x = let y = expensive x in
- let z = (True,y) in
- (case z of {(p,q)->q}, case z of {(p,q)->q})
-\end{verbatim}
-
-We feel free to duplicate the WHNF (True,y), but that means
-that y may be duplicated thereby.
+occAnal _ (Coercion co)
+ = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co)
+ -- See Note [Gather occurrences of coercion veriables]
+\end{code}
-If we aren't careful we duplicate the (expensive x) call!
-Constructors are rather like lambdas in this way.
+Note [Gather occurrences of coercion veriables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to gather info about what coercion variables appear, so that
+we can sort them into the right place when doing dependency analysis.
\begin{code}
-occAnal _ expr@(Lit _) = (emptyDetails, expr)
\end{code}
\begin{code}
occAnal env (Cast expr co)
= case occAnal env expr of { (usage, expr') ->
- (markManyIf (isRhsEnv env) usage, Cast expr' co)
+ let usage1 = markManyIf (isRhsEnv env) usage
+ usage2 = addIdOccs usage1 (coVarsOfCo co)
+ -- See Note [Gather occurrences of coercion veriables]
+ in (usage2, Cast expr' co)
-- If we see let x = y `cast` co
-- then mark y as 'Many' so that we don't
-- immediately inline y again.
-- (a) occurrences inside type lambdas only not marked as InsideLam
-- (b) type variables not in environment
-occAnal env (Lam x body) | isTyCoVar x
+occAnal env (Lam x body) | isTyVar x
= case occAnal env body of { (body_usage, body') ->
(body_usage, Lam x body')
}
Applications are dealt with specially because we want
the "build hack" to work.
+Note [Arguments of let-bound constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ f x = let y = expensive x in
+ let z = (True,y) in
+ (case z of {(p,q)->q}, case z of {(p,q)->q})
+We feel free to duplicate the WHNF (True,y), but that means
+that y may be duplicated thereby.
+
+If we aren't careful we duplicate the (expensive x) call!
+Constructors are rather like lambdas in this way.
+
\begin{code}
occAnalApp :: OccEnv
-> (Expr CoreBndr, [Arg CoreBndr])
-- arguments are just variables, or trivial expressions.
--
-- This is the *whole point* of the isRhsEnv predicate
+ -- See Note [Arguments of let-bound constructors]
in
(fun_uds +++ final_args_uds, mkApps (Var fun) args') }
where
where
(body_usg', tagged_bndr) = tagBinder body_usg bndr
rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info
- rhs = mkCoerceI co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]
+ rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]
\end{code}
data ProxyEnv -- See Note [ProxyEnv]
= PE (IdEnv -- Domain = scrutinee variables
(Id, -- The scrutinee variable again
- [(Id,CoercionI)])) -- The case binders that it maps to
+ [(Id,Coercion)])) -- The case binders that it maps to
VarSet -- Free variables of both range and domain
\end{code}
information right.
\begin{code}
-extendProxyEnv :: ProxyEnv -> Id -> CoercionI -> Id -> ProxyEnv
+extendProxyEnv :: ProxyEnv -> Id -> Coercion -> Id -> ProxyEnv
-- (extendPE x co y) typically arises from
-- case (x |> co) of y { ... }
-- It extends the proxy env with the binding
env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co)
single cb_co = (scrut1, [cb_co])
add cb_co (x, cb_cos) = (x, cb_co:cb_cos)
- fvs2 = fvs1 `unionVarSet` freeVarsCoI co
+ fvs2 = fvs1 `unionVarSet` tyCoVarsOfCo co
`extendVarSet` case_bndr
`extendVarSet` scrut1
-- Also we don't want any INLINE or NOINLINE pragmas!
-----------
-type ProxyBind = (Id, Id, CoercionI)
+type ProxyBind = (Id, Id, Coercion)
-- (scrut variable, case-binder variable, coercion)
getProxies :: OccEnv -> Id -> Bag ProxyBind
= -- pprTrace "wrapProxies" (ppr case_bndr) $
go_fwd case_bndr
where
- fwd_pe :: IdEnv (Id, CoercionI)
+ fwd_pe :: IdEnv (Id, Coercion)
fwd_pe = foldVarEnv add1 emptyVarEnv pe
where
add1 (x,ycos) env = foldr (add2 x) env ycos
go_fwd' case_bndr
| Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr
- = unitBag (scrut, case_bndr, mkSymCoI co)
+ = unitBag (scrut, case_bndr, mkSymCo co)
`unionBags` go_fwd scrut
`unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut
, cb /= case_bndr]
| otherwise
= emptyBag
- lookup_bwd :: Id -> [(Id, CoercionI)]
+ lookup_bwd :: Id -> [(Id, Coercion)]
-- Return case_bndrs that are connected to scrut
lookup_bwd scrut = case lookupVarEnv pe scrut of
Nothing -> []
Just (_, cb_cos) -> cb_cos
- go_bwd :: Id -> [(Id, CoercionI)] -> Bag ProxyBind
+ go_bwd :: Id -> [(Id, Coercion)] -> Bag ProxyBind
go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos
- go_bwd1 :: Id -> (Id, CoercionI) -> Bag ProxyBind
+ go_bwd1 :: Id -> (Id, Coercion) -> Bag ProxyBind
go_bwd1 scrut (case_bndr, co)
= -- pprTrace "go_bwd1" (ppr case_bndr) $
unitBag (case_bndr, scrut, co)
where
pe = occ_proxy env
pe' = case scrut of
- Var v -> extendProxyEnv pe v (IdCo (idType v)) cb
- Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb
- _other -> trimProxyEnv pe [cb]
+ Var v -> extendProxyEnv pe v (mkReflCo (idType v)) cb
+ Cast (Var v) co -> extendProxyEnv pe v co cb
+ _other -> trimProxyEnv pe [cb]
-----------
trimOccEnv :: OccEnv -> [CoreBndr] -> OccEnv
trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, [])
| otherwise = (scrut, filterOut discard cb_cos)
discard (cb,co) = bndr_set `intersectsVarSet`
- extendVarSet (freeVarsCoI co) cb
-
------------
-freeVarsCoI :: CoercionI -> VarSet
-freeVarsCoI (IdCo t) = tyVarsOfType t
-freeVarsCoI (ACo co) = tyVarsOfType co
+ extendVarSet (tyCoVarsOfCo co) cb
\end{code}
setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
setBinderOcc usage bndr
- | isTyCoVar bndr = bndr
+ | isTyVar bndr = bndr
| isExportedId bndr = case idOccInfo bndr of
NoOccInfo -> bndr
_ -> setIdOccInfo bndr NoOccInfo
import CoreSyn
import CoreUtils
import Type
+import Coercion
import Id
import Name
import VarEnv
return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss')
\end{code}
\begin{code}
-data App = VarApp Id | TypeApp Type
+data App = VarApp Id | TypeApp Type | CoApp Coercion
data Staticness a = Static a | NotStatic
type IdAppInfo = (Id, SATInfo)
pprStaticness :: Staticness App -> SDoc
pprStaticness (Static (VarApp _)) = ptext (sLit "SV")
pprStaticness (Static (TypeApp _)) = ptext (sLit "ST")
+pprStaticness (Static (CoApp _)) = ptext (sLit "SC")
pprStaticness NotStatic = ptext (sLit "NS")
mergeSATInfo (NotStatic:statics) (_:apps) = NotStatic : mergeSATInfo statics apps
mergeSATInfo (_:statics) (NotStatic:apps) = NotStatic : mergeSATInfo statics apps
mergeSATInfo ((Static (VarApp v)):statics) ((Static (VarApp v')):apps) = (if v == v' then Static (VarApp v) else NotStatic) : mergeSATInfo statics apps
-mergeSATInfo ((Static (TypeApp t)):statics) ((Static (TypeApp t')):apps) = (if t `coreEqType` t' then Static (TypeApp t) else NotStatic) : mergeSATInfo statics apps
+mergeSATInfo ((Static (TypeApp t)):statics) ((Static (TypeApp t')):apps) = (if t `eqType` t' then Static (TypeApp t) else NotStatic) : mergeSATInfo statics apps
+mergeSATInfo ((Static (CoApp c)):statics) ((Static (CoApp c')):apps) = (if c `coreEqCoercion` c' then Static (CoApp c) else NotStatic) : mergeSATInfo statics apps
mergeSATInfo l r = pprPanic "mergeSATInfo" $ ptext (sLit "Left:") <> pprSATInfo l <> ptext (sLit ", ")
<> ptext (sLit "Right:") <> pprSATInfo r
bindersToSATInfo :: [Id] -> SATInfo
bindersToSATInfo vs = map (Static . binderToApp) vs
- where binderToApp v = if isId v
- then VarApp v
- else TypeApp $ mkTyVarTy v
+ where binderToApp v | isId v = VarApp v
+ | isTyVar v = TypeApp $ mkTyVarTy v
+ | otherwise = CoApp $ mkCoVarCo v
finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
finalizeApp Nothing id_sat_info = id_sat_info
-- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface)
let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness])
in case arg of
- Type t -> satRemainderWithStaticness $ Static (TypeApp t)
- Var v -> satRemainderWithStaticness $ Static (VarApp v)
- _ -> satRemainderWithStaticness $ NotStatic
+ Type t -> satRemainderWithStaticness $ Static (TypeApp t)
+ Coercion c -> satRemainderWithStaticness $ Static (CoApp c)
+ Var v -> satRemainderWithStaticness $ Static (VarApp v)
+ _ -> satRemainderWithStaticness $ NotStatic
where
boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)
boring fn' sat_info_fn app_info =
satExpr ty@(Type _) _ = do
return (ty, emptyIdSATInfo, Nothing)
+
+satExpr co@(Coercion _) _ = do
+ return (co, emptyIdSATInfo, Nothing)
satExpr (Cast expr coercion) interesting_ids = do
(expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
\begin{code}
lvlExpr _ _ ( _, AnnType ty) = return (Type ty)
+lvlExpr _ _ ( _, AnnCoercion co) = return (Coercion co)
lvlExpr _ env (_, AnnVar v) = return (lookupVar env v)
lvlExpr _ _ (_, AnnLit lit) = return (Lit lit)
expr' <- lvlExpr ctxt_lvl env expr
return (Note note expr')
-lvlExpr ctxt_lvl env (_, AnnCast expr co) = do
+lvlExpr ctxt_lvl env (_, AnnCast expr (_, co)) = do
expr' <- lvlExpr ctxt_lvl env expr
return (Cast expr' co)
= do { e' <- lvlMFE strict_ctxt ctxt_lvl env e
; return (Note n e') }
-lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co)
+lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e (_, co))
= do { e' <- lvlMFE strict_ctxt ctxt_lvl env e
; return (Cast e' co) }
= lvlExpr ctxt_lvl env e -- Don't share cases
lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
- | isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs]
+ | isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs]
+ -- This includes coercions, which we don't
+ -- want to float anyway
|| notWorthFloating ann_expr abs_vars
|| not good_destination
= -- Don't float it out
go (_, AnnCast e _) n = go e n
go (_, AnnApp e arg) n
| (_, AnnType {}) <- arg = go e n
+ | (_, AnnCoercion {}) <- arg = go e n
| n==0 = False
| is_triv arg = go e (n-1)
| otherwise = False
is_triv (_, AnnVar {}) = True -- (ie not worth floating)
is_triv (_, AnnCast e _) = is_triv e
is_triv (_, AnnApp e (_, AnnType {})) = is_triv e
+ is_triv (_, AnnApp e (_, AnnCoercion {})) = is_triv e
is_triv _ = False
\end{code}
-> LvlM (LevelledBind, LevelEnv)
lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
- | isTyCoVar bndr -- Don't do anything for TyVar binders
+ | isTyVar bndr -- Don't do anything for TyVar binders
-- (simplifier gets rid of them pronto)
= do rhs' <- lvlExpr ctxt_lvl env rhs
return (NonRec (TB bndr ctxt_lvl) rhs', env)
(False, True) -> False
_ -> v1 <= v2 -- Same family
- is_tv v = isTyCoVar v && not (isCoVar v)
+ is_tv v = isTyVar v
uniq :: [Var] -> [Var]
-- Remove adjacent duplicates; the sort will have brought them together
absVarsOf id_env v
| isId v = [av2 | av1 <- lookup_avs v
, av2 <- add_tyvars av1]
- | isCoVar v = add_tyvars v
- | otherwise = [v]
-
+ | otherwise = ASSERT( isTyVar v ) [v]
where
lookup_avs v = case lookupVarEnv id_env v of
Just (abs_vars, _) -> abs_vars
-- Environments
SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract
- mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst,
+ mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,
zapSubstEnv, setSubstEnv,
getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds,
getSimplRules,
SimplSR(..), mkContEx, substId, lookupRecBndr,
simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs,
- simplBinder, simplBinders, addBndrRules,
- substExpr, substTy, substTyVar, getTvSubst, mkCoreSubst,
+ simplBinder, simplBinders, addBndrRules,
+ substExpr, substTy, substTyVar, getTvSubst,
+ getCvSubst, substCo, substCoVar,
+ mkCoreSubst,
-- Floats
Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats,
import MkCore
import TysWiredIn
import qualified CoreSubst
-import qualified Type ( substTy, substTyVarBndr, substTyVar )
+import qualified Type
import Type hiding ( substTy, substTyVarBndr, substTyVar )
-import Coercion
+import qualified Coercion
+import Coercion hiding ( substCo, substTy, substCoVar, substCoVarBndr, substTyVarBndr )
import BasicTypes
import MonadUtils
import Outputable
seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
-- The current substitution
- seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
- seIdSubst :: SimplIdSubst, -- InId |--> OutExpr
+ seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType
+ seCvSubst :: CvSubstEnv, -- InTyCoVar |--> OutCoercion
+ seIdSubst :: SimplIdSubst, -- InId |--> OutExpr
----------- Dynamic part of the environment -----------
-- Dynamic in the sense of describing the setup where
= DoneEx OutExpr -- Completed term
| DoneId OutId -- Completed term variable
| ContEx TvSubstEnv -- A suspended substitution
+ CvSubstEnv
SimplIdSubst
InExpr
instance Outputable SimplSR where
ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e
ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v
- ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
+ ppr (ContEx _tv _cv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-,
ppr (filter_env tv), ppr (filter_env id) -}]
-- where
-- fvs = exprFreeVars e
, seInScope = init_in_scope
, seFloats = emptyFloats
, seTvSubst = emptyVarEnv
+ , seCvSubst = emptyVarEnv
, seIdSubst = emptyVarEnv }
-- The top level "enclosing CC" is "SUBSUMED".
---------------------
extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
- = env {seIdSubst = extendVarEnv subst var res}
+ = ASSERT2( isId var && not (isCoVar var), ppr var )
+ env {seIdSubst = extendVarEnv subst var res}
extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res
= env {seTvSubst = extendVarEnv subst var res}
+extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
+extendCvSubst env@(SimplEnv {seCvSubst = subst}) var res
+ = env {seCvSubst = extendVarEnv subst var res}
+
---------------------
getInScope :: SimplEnv -> InScopeSet
getInScope env = seInScope env
---------------------
zapSubstEnv :: SimplEnv -> SimplEnv
-zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
+zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
-setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv
-setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids }
+setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
+setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
mkContEx :: SimplEnv -> InExpr -> SimplSR
-mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e
+mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
\end{code}
Just (DoneId v) -> DoneId (refine in_scope v)
Just (DoneEx (Var v)) -> DoneId (refine in_scope v)
Just res -> res -- DoneEx non-var, or ContEx
- where
-- Get the most up-to-date thing from the in-scope set
-- Even though it isn't in the substitution, it may be in
-- The substitution is extended only if the variable is cloned, because
-- we *don't* need to use it to track occurrence info.
simplBinder env bndr
- | isTyCoVar bndr = do { let (env', tv) = substTyVarBndr env bndr
+ | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr
; seqTyVar tv `seq` return (env', tv) }
| otherwise = do { let (env', id) = substIdBndr env bndr
; seqId id `seq` return (env', id) }
; seqIds ids1 `seq` return env1 }
---------------
-substIdBndr :: SimplEnv
- -> InBndr -- Env and binder to transform
- -> (SimplEnv, OutBndr)
+substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr)
+-- Might be a coercion variable
+substIdBndr env bndr
+ | isCoVar bndr = substCoVarBndr env bndr
+ | otherwise = substNonCoVarIdBndr env bndr
+
+---------------
+substNonCoVarIdBndr
+ :: SimplEnv
+ -> InBndr -- Env and binder to transform
+ -> (SimplEnv, OutBndr)
-- Clone Id if necessary, substitute its type
-- Return an Id with its
-- * Type substituted
-- Similar to CoreSubst.substIdBndr, except that
-- the type of id_subst differs
-- all fragile info is zapped
-
-substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
- old_id
- = (env { seInScope = in_scope `extendInScopeSet` new_id,
+substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
+ old_id
+ = ASSERT2( not (isCoVar old_id), ppr old_id )
+ (env { seInScope = in_scope `extendInScopeSet` new_id,
seIdSubst = new_subst }, new_id)
where
id1 = uniqAway in_scope old_id
getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env })
= mkTvSubst in_scope tv_env
+getCvSubst :: SimplEnv -> CvSubst
+getCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })
+ = CvSubst in_scope tv_env cv_env
+
substTy :: SimplEnv -> Type -> Type
substTy env ty = Type.substTy (getTvSubst env) ty
substTyVarBndr env tv
= case Type.substTyVarBndr (getTvSubst env) tv of
(TvSubst in_scope' tv_env', tv')
- -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv')
+ -> (env { seInScope = in_scope', seTvSubst = tv_env' }, tv')
+
+substCoVar :: SimplEnv -> CoVar -> Coercion
+substCoVar env tv = Coercion.substCoVar (getCvSubst env) tv
+
+substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
+substCoVarBndr env cv
+ = case Coercion.substCoVarBndr (getCvSubst env) cv of
+ (CvSubst in_scope' tv_env' cv_env', cv')
+ -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
+
+substCo :: SimplEnv -> Coercion -> Coercion
+substCo env co = Coercion.substCo (getCvSubst env) co
-- When substituting in rules etc we can get CoreSubst to do the work
-- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match
-- the substitutions are typically small, and laziness will avoid work in many cases.
mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst
-mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env })
- = mk_subst tv_env id_env
+mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env, seIdSubst = id_env })
+ = mk_subst tv_env cv_env id_env
where
- mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env)
+ mk_subst tv_env cv_env id_env = CoreSubst.mkSubst in_scope tv_env cv_env (mapVarEnv fiddle id_env)
- fiddle (DoneEx e) = e
- fiddle (DoneId v) = Var v
- fiddle (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e
+ fiddle (DoneEx e) = e
+ fiddle (DoneId v) = Var v
+ fiddle (ContEx tv cv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv cv id) e
-- Don't shortcut here
------------------
substIdType :: SimplEnv -> Id -> Id
-substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id
+substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) id
| isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id
| otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty)
-- The tyVarsOfType is cheaper than it looks
import CoreSyn
import qualified CoreSubst
import PprCore
+import DataCon ( dataConCannotMatch )
import CoreFVs
import CoreUtils
import CoreArity
import Var
import Demand
import SimplMonad
-import TcType ( isDictLikeTy )
import Type hiding( substTy )
-import Coercion ( coercionKind )
+import Coercion hiding( substCo )
import TyCon
-import Unify ( dataConCannotMatch )
import VarSet
import BasicTypes
import Util
import MonadUtils
import Outputable
import FastString
+import Pair
import Data.List
\end{code}
| CoerceIt -- C `cast` co
OutCoercion -- The coercion simplified
+ -- Invariant: never an identity coercion
SimplCont
| ApplyTo -- C arg
contIsTrivial :: SimplCont -> Bool
contIsTrivial (Stop {}) = True
contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont
+contIsTrivial (ApplyTo _ (Coercion _) _ cont) = contIsTrivial cont
contIsTrivial (CoerceIt _ cont) = contIsTrivial cont
contIsTrivial _ = False
contResultType env ty cont
= go cont ty
where
- subst_ty se ty = substTy (se `setInScope` env) ty
+ subst_ty se ty = SimplEnv.substTy (se `setInScope` env) ty
+ subst_co se co = SimplEnv.substCo (se `setInScope` env) co
go (Stop {}) ty = ty
- go (CoerceIt co cont) _ = go cont (snd (coercionKind co))
+ go (CoerceIt co cont) _ = go cont (pSnd (coercionKind co))
go (StrictBind _ bs body se cont) _ = go cont (subst_ty se (exprType (mkLams bs body)))
go (StrictArg ai _ cont) _ = go cont (funResultTy (argInfoResultTy ai))
go (Select _ _ alts se cont) _ = go cont (subst_ty se (coreAltsType alts))
go (ApplyTo _ arg se cont) ty = go cont (apply_to_arg ty arg se)
- apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg)
- apply_to_arg ty _ _ = funResultTy ty
+ apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg)
+ apply_to_arg ty (Coercion co_arg) se = applyCo ty (subst_co se co_arg)
+ apply_to_arg ty _ _ = funResultTy ty
argInfoResultTy :: ArgInfo -> OutType
argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args })
-------------------
countValArgs :: SimplCont -> Int
countValArgs (ApplyTo _ (Type _) _ cont) = countValArgs cont
+countValArgs (ApplyTo _ (Coercion _) _ cont) = countValArgs cont
countValArgs (ApplyTo _ _ _ cont) = 1 + countValArgs cont
countValArgs _ = 0
once, because FloatOut has gone to some trouble to extract them out.
Inlining them won't make the program run faster!
+Note [Do not inline CoVars unconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Coercion variables appear inside coercions, and have a separate
+substitution, so don't inline them via the IdSubst!
+
\begin{code}
preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
preInlineUnconditionally env top_lvl bndr rhs
| isStableUnfolding (idUnfolding bndr) = False -- Note [InlineRule and preInlineUnconditionally]
| isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids]
| opt_SimplNoPreInlining = False
+ | isCoVar bndr = False -- Note [Do not inline CoVars unconditionally]
| otherwise = case idOccInfo bndr of
IAmDead -> True -- Happens in ((\x.1) v)
OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
postInlineUnconditionally
:: SimplEnv -> TopLevelFlag
-> OutId -- The binder (an InId would be fine too)
+ -- (*not* a CoVar)
-> OccInfo -- From the InId
-> OutExpr
-> Unfolding
| not (any bad bndrs)
-- Note [Casts and lambdas]
= do { lam <- mkLam' dflags bndrs body
- ; return (mkCoerce (mkPiTypes bndrs co) lam) }
+ ; return (mkCoerce (mkPiCos bndrs co) lam) }
where
- co_vars = tyVarsOfType co
+ co_vars = tyCoVarsOfCo co
bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars
mkLam' dflags bndrs body@(Lam {})
= do { tick (EtaReduction (head bndrs))
; return etad_lam }
- | otherwise
+ | otherwise
= return (mkLams bndrs body)
\end{code}
%* *
%************************************************************************
-When we meet a let-binding we try eta-expansion. To find the
-arity of the RHS we use a little fixpoint analysis; see Note [Arity analysis]
-
\begin{code}
tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
-- See Note [Eta-expanding at let bindings]
; return (subst', (NonRec poly_id poly_rhs)) }
where
rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
- tvs_here | any isCoVar main_tvs = main_tvs -- Note [Abstract over coercions]
- | otherwise
- = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyCoVar rhs')
+ tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
-- Abstract only over the type variables free in the rhs
-- wrt which the new binding is abstracted. But the naive
[con] -> -- It matches exactly one constructor, so fill it in
do { tick (FillInCaseDefault case_bndr)
; us <- getUniquesM
- ; let (ex_tvs, co_tvs, arg_ids) =
- dataConRepInstPat us con inst_tys
- ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, deflt_rhs)] }
+ ; let (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys
+ ; return [(DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)] }
_ -> return [(DEFAULT, [], deflt_rhs)]
import Id
import MkId ( seqId, realWorldPrimId )
import MkCore ( mkImpossibleExpr )
-import Var
import IdInfo
import Name ( mkSystemVarName, isExternalName )
-import Coercion
+import Coercion hiding ( substCo, substTy, substCoVar, extendTvSubst )
import OptCoercion ( optCoercion )
import FamInstEnv ( topNormaliseType )
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
import Data.List ( mapAccumL )
import Outputable
import FastString
+import Pair
\end{code}
-> SimplM SimplEnv
simplNonRecX env bndr new_rhs
- | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of b { (p,q) -> p }
- = return env -- Here b is dead, and we avoid creating
+ | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
+ = return env -- Here c is dead, and we avoid creating
+ -- the binding c = (a,b)
+ | Coercion co <- new_rhs
+ = return (extendCvSubst env bndr co)
| otherwise -- the binding b = (a,b)
= do { (env', bndr') <- simplBinder env bndr
; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Adds new floats to the env iff that allows us to return a good RHS
prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions]
- | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type
+ | Pair ty1 _ty2 <- coercionKind co -- Do *not* do this if rhs has an unlifted type
, not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)]
= do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs
; return (env', Cast rhs' co) }
-- * or by adding to the floats in the envt
completeBind env top_lvl old_bndr new_bndr new_rhs
+ | isCoVar old_bndr
+ = case new_rhs of
+ Coercion co -> return (extendCvSubst env old_bndr co)
+ _ -> return (addNonRec env new_bndr new_rhs)
+
+ | otherwise
= ASSERT( isId new_bndr )
do { let old_info = idInfo old_bndr
old_unf = unfoldingInfo old_info
; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding
-- Inline and discard the binding
then do { tick (PostInlineUnconditionally old_bndr)
- ; -- pprTrace "postInlineUnconditionally"
- -- (ppr old_bndr <+> equals <+> ppr final_rhs $$ ppr occ_info) $
- return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
+ ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
-- Use the substitution to make quite, quite sure that the
-- substitution will happen, since we are going to discard the binding
else
final_id = new_bndr `setIdInfo` info3
- ; -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
+ ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $
return (addNonRec env final_id final_rhs) } }
-- The addNonRec adds it to the in-scope set too
simplExprF env e cont
= -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $
- simplExprF' env e cont
+ simplExprF1 env e cont
-simplExprF' :: SimplEnv -> InExpr -> SimplCont
+simplExprF1 :: SimplEnv -> InExpr -> SimplCont
-> SimplM (SimplEnv, OutExpr)
-simplExprF' env (Var v) cont = simplVarF env v cont
-simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont
-simplExprF' env (Note n expr) cont = simplNote env n expr cont
-simplExprF' env (Cast body co) cont = simplCast env body co cont
-simplExprF' env (App fun arg) cont = simplExprF env fun $
+simplExprF1 env (Var v) cont = simplIdF env v cont
+simplExprF1 env (Lit lit) cont = rebuild env (Lit lit) cont
+simplExprF1 env (Note n expr) cont = simplNote env n expr cont
+simplExprF1 env (Cast body co) cont = simplCast env body co cont
+simplExprF1 env (Coercion co) cont = simplCoercionF env co cont
+simplExprF1 env (Type ty) cont = ASSERT( contIsRhsOrArg cont )
+ rebuild env (Type (substTy env ty)) cont
+simplExprF1 env (App fun arg) cont = simplExprF env fun $
ApplyTo NoDup arg env cont
-simplExprF' env expr@(Lam _ _) cont
+simplExprF1 env expr@(Lam {}) cont
= simplLam env zapped_bndrs body cont
-- The main issue here is under-saturated lambdas
-- (\x1. \x2. e) arg1
n_args = countArgs cont
-- NB: countArgs counts all the args (incl type args)
-- and likewise drop counts all binders (incl type lambdas)
-
- zappable_bndr b = isId b && not (isOneShotBndr b)
- zap b | isTyCoVar b = b
- | otherwise = zapLamIdInfo b
-simplExprF' env (Type ty) cont
- = ASSERT( contIsRhsOrArg cont )
- do { ty' <- simplCoercion env ty
- ; rebuild env (Type ty') cont }
+ zappable_bndr b = isId b && not (isOneShotBndr b)
+ zap b | isTyVar b = b
+ | otherwise = zapLamIdInfo b
-simplExprF' env (Case scrut bndr _ alts) cont
+simplExprF1 env (Case scrut bndr _ alts) cont
| sm_case_case (getMode env)
= -- Simplify the scrutinee with a Select continuation
simplExprF env scrut (Select NoDup bndr alts env cont)
(Select NoDup bndr alts env mkBoringStop)
; rebuild env case_expr' cont }
-simplExprF' env (Let (Rec pairs) body) cont
+simplExprF1 env (Let (Rec pairs) body) cont
= do { env' <- simplRecBndrs env (map fst pairs)
-- NB: bndrs' don't have unfoldings or rules
-- We add them as we go down
; env'' <- simplRecBind env' NotTopLevel pairs
; simplExprF env'' body cont }
-simplExprF' env (Let (NonRec bndr rhs) body) cont
+simplExprF1 env (Let (NonRec bndr rhs) body) cont
= simplNonRecE env bndr (rhs, env) ([], body) cont
---------------------------------
new_ty = substTy env ty
---------------------------------
-simplCoercion :: SimplEnv -> InType -> SimplM OutType
--- The InType isn't *necessarily* a coercion, but it might be
--- (in a type application, say) and optCoercion is a no-op on types
+simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
+ -> SimplM (SimplEnv, OutExpr)
+-- We are simplifying a term of form (Coercion co)
+-- Simplify the InCoercion, and then try to combine with the
+-- context, to implememt the rule
+-- (Coercion co) |> g
+-- = Coercion (syn (nth 0 g) ; co ; nth 1 g)
+simplCoercionF env co cont
+ = do { co' <- simplCoercion env co
+ ; simpl_co co' cont }
+ where
+ simpl_co co (CoerceIt g cont)
+ = simpl_co new_co cont
+ where
+ new_co = mkSymCo g0 `mkTransCo` co `mkTransCo` g1
+ [g0, g1] = decomposeCo 2 g
+
+ simpl_co co cont
+ = seqCo co `seq` rebuild env (Coercion co) cont
+
+simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
simplCoercion env co
- = seqType new_co `seq` return new_co
- where
- new_co = optCoercion (getTvSubst env) co
+ = let opt_co = optCoercion (getCvSubst env) co
+ in opt_co `seq` return opt_co
\end{code}
rebuild env expr cont
= case cont of
Stop {} -> return (env, expr)
- CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
+ CoerceIt co cont -> rebuild env (Cast expr co) cont
Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont
StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
where
addCoerce co cont = add_coerce co (coercionKind co) cont
- add_coerce _co (s1, k1) cont -- co :: ty~ty
- | s1 `coreEqType` k1 = cont -- is a no-op
+ add_coerce _co (Pair s1 k1) cont -- co :: ty~ty
+ | s1 `eqType` k1 = cont -- is a no-op
- add_coerce co1 (s1, _k2) (CoerceIt co2 cont)
- | (_l1, t1) <- coercionKind co2
+ add_coerce co1 (Pair s1 _k2) (CoerceIt co2 cont)
+ | (Pair _l1 t1) <- coercionKind co2
-- e |> (g1 :: S1~L) |> (g2 :: L~T1)
-- ==>
-- e, if S1=T1
-- we may find (coerce T (coerce S (\x.e))) y
-- and we'd like it to simplify to e[y/x] in one round
-- of simplification
- , s1 `coreEqType` t1 = cont -- The coerces cancel out
- | otherwise = CoerceIt (mkTransCoercion co1 co2) cont
+ , s1 `eqType` t1 = cont -- The coerces cancel out
+ | otherwise = CoerceIt (mkTransCo co1 co2) cont
- add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
+ add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
-- (f |> g) ty ---> (f ty) |> (g @ ty)
- -- This implements the PushT and PushC rules from the paper
+ -- This implements the PushT rule from the paper
| Just (tyvar,_) <- splitForAllTy_maybe s1s2
- = let
- (new_arg_ty, new_cast)
- | isCoVar tyvar = (new_arg_co, mkCselRCoercion co) -- PushC rule
- | otherwise = (ty', mkInstCoercion co ty') -- PushT rule
- in
- ApplyTo dup (Type new_arg_ty) (zapSubstEnv arg_se) (addCoerce new_cast cont)
+ = ASSERT( isTyVar tyvar )
+ ApplyTo Simplified (Type arg_ty') (zapSubstEnv arg_se) (addCoerce new_cast cont)
+ where
+ new_cast = mkInstCo co arg_ty'
+ arg_ty' | isSimplified dup = arg_ty
+ | otherwise = substTy (arg_se `setInScope` env) arg_ty
+
+{-
+ add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Coercion arg_co) arg_se cont)
+ -- This implements the PushC rule from the paper
+ | Just (covar,_) <- splitForAllTy_maybe s1s2
+ = ASSERT( isCoVar covar )
+ ApplyTo Simplified (Coercion new_arg_co) (zapSubstEnv arg_se) (addCoerce co1 cont)
where
- ty' = substTy (arg_se `setInScope` env) arg_ty
- new_arg_co = mkCsel1Coercion co `mkTransCoercion`
- ty' `mkTransCoercion`
- mkSymCoercion (mkCsel2Coercion co)
-
- add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
- | not (isTypeArg arg) -- This implements the Push rule from the paper
- , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied
+ [co0, co1] = decomposeCo 2 co
+ [co00, co01] = decomposeCo 2 co0
+
+ arg_co' | isSimplified dup = arg_co
+ | otherwise = substCo (arg_se `setInScope` env) arg_co
+ new_arg_co = co00 `mkTransCo`
+ arg_co' `mkTransCo`
+ mkSymCo co01
+-}
+
+ add_coerce co (Pair s1s2 t1t2) (ApplyTo dup arg arg_se cont)
+ | isFunTy s1s2 -- This implements the Push rule from the paper
+ , isFunTy t1t2 -- Check t1t2 to ensure 'arg' is a value arg
-- (e |> (g :: s1s2 ~ t1->t2)) f
-- ===>
-- (e (f |> (arg g :: t1~s1))
-- t2 ~ s2 with left and right on the curried form:
-- (->) t1 t2 ~ (->) s1 s2
[co1, co2] = decomposeCo 2 co
- new_arg = mkCoerce (mkSymCoercion co1) arg'
+ new_arg = mkCoerce (mkSymCo co1) arg'
arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg
add_coerce co _ cont = CoerceIt co cont
-- First deal with type applications and type lets
-- (/\a. e) (Type ty) and (let a = Type ty in e)
simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
- = ASSERT( isTyCoVar bndr )
+ = ASSERT( isTyVar bndr )
do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont }
- | isStrictId bndr
+ | isStrictId bndr -- Includes coercions
= do { simplExprF (rhs_se `setFloats` env) rhs
(StrictBind bndr bndrs body env cont) }
| otherwise
- = ASSERT( not (isTyCoVar bndr) )
+ = ASSERT( not (isTyVar bndr) )
do { (env1, bndr1) <- simplNonRecBndr env bndr
; let (env2, bndr2) = addBndrRules env1 bndr bndr1
; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
simplVar :: SimplEnv -> InVar -> SimplM OutExpr
-- Look up an InVar in the environment
simplVar env var
- | isTyCoVar var
- = return (Type (substTyVar env var))
+ | isTyVar var = return (Type (substTyVar env var))
+ | isCoVar var = return (Coercion (substCoVar env var))
| otherwise
= case substId env var of
- DoneId var1 -> return (Var var1)
- DoneEx e -> return e
- ContEx tvs ids e -> simplExpr (setSubstEnv env tvs ids) e
+ DoneId var1 -> return (Var var1)
+ DoneEx e -> return e
+ ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e
-simplVarF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
-simplVarF env var cont
+simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr)
+simplIdF env var cont
= case substId env var of
- DoneEx e -> simplExprF (zapSubstEnv env) e cont
- ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
- DoneId var1 -> completeCall env var1 cont
+ DoneEx e -> simplExprF (zapSubstEnv env) e cont
+ ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
+ DoneId var1 -> completeCall env var1 cont
-- Note [zapSubstEnv]
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
res = mkApps (Var fun) (reverse rev_args)
res_ty = exprType res
cont_ty = contResultType env res_ty cont
- co = mkUnsafeCoercion res_ty cont_ty
- mk_coerce expr | cont_ty `coreEqType` res_ty = expr
+ co = mkUnsafeCo res_ty cont_ty
+ mk_coerce expr | cont_ty `eqType` res_ty = expr
| otherwise = mkCoerce co expr
-rebuildCall env info (ApplyTo _ (Type arg_ty) se cont)
- = do { ty' <- simplCoercion (se `setInScope` env) arg_ty
- ; rebuildCall env (info `addArgTo` Type ty') cont }
+rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
+ = do { arg_ty' <- if isSimplified dup_flag then return arg_ty
+ else simplType (se `setInScope` env) arg_ty
+ ; rebuildCall env (info `addArgTo` Type arg_ty') cont }
rebuildCall env info@(ArgInfo { ai_encl = encl_rules
, ai_strs = str:strs, ai_discs = disc:discs })
| isSimplified dup_flag -- See Note [Avoid redundant simplification]
= rebuildCall env (addArgTo info' arg) cont
- | str -- Strict argument
+ | str -- Strict argument
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
simplExprF (arg_se `setFloats` env) arg
(StrictArg info' cci cont)
| not (isDeadBinder case_bndr) -- Not a pure seq! See Note [Improving seq]
, Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
= do { case_bndr2 <- newId (fsLit "nt") ty2
- ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
+ ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co)
env2 = extendIdSubst env case_bndr rhs
; return (env2, scrut `Cast` co, case_bndr2) }
= go vs the_strs
where
go [] [] = []
- go (v:vs') strs | isTyCoVar v = v : go vs' strs
+ go (v:vs') strs | isTyVar v = v : go vs' strs
go (v:vs') (str:strs)
| isMarkedStrict str = evald_v : go vs' strs
| otherwise = zapped_v : go vs' strs
bind_args env' [] _ = return env'
bind_args env' (b:bs') (Type ty : args)
- = ASSERT( isTyCoVar b )
+ = ASSERT( isTyVar b )
bind_args (extendTvSubst env' b ty) bs' args
bind_args env' (b:bs') (arg : args)
| otherwise = bndrs' ++ [case_bndr_w_unf]
abstract_over bndr
- | isTyCoVar bndr = True -- Abstract over all type variables just in case
+ | isTyVar bndr = True -- Abstract over all type variables just in case
| otherwise = not (isDeadBinder bndr)
-- The deadness info on the new Ids is preserved by simplBinders
import PprCore ( pprRules )
import Type ( Type )
import TcType ( tcSplitTyConApp_maybe )
+import Coercion
import CoreTidy ( tidyRules )
import Id
import IdInfo ( SpecInfo( SpecInfo ) )
-import Var ( Var )
import VarEnv
import VarSet
import Name ( Name, NamedThing(..) )
import Data.List
\end{code}
-
Note [Overall plumbing for rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* After the desugarer:
roughTopName :: CoreExpr -> Maybe Name
roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
- Just (tc,_) -> Just (getName tc)
- Nothing -> Nothing
+ Just (tc,_) -> Just (getName tc)
+ Nothing -> Nothing
+roughTopName (Coercion _) = Nothing
roughTopName (App f _) = roughTopName f
roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName]
, isDataConWorkId f || idArity f > 0
-- succeed in matching what looks like the template variable 'a' against 3.
-- The Var case follows closely what happens in Unify.match
-match renv subst (Var v1) e2
- | Just subst <- match_var renv subst v1 e2
- = Just subst
-
+match renv subst (Var v1) e2 = match_var renv subst v1 e2
match renv subst (Note _ e1) e2 = match renv subst e1 e2
match renv subst e1 (Note _ e2) = match renv subst e1 e2
-- Ignore notes in both template and thing to be matched
match renv subst (Type ty1) (Type ty2)
= match_ty renv subst ty1 ty2
+match renv subst (Coercion co1) (Coercion co2)
+ = match_co renv subst co1 co2
match renv subst (Cast e1 co1) (Cast e2 co2)
- = do { subst1 <- match_ty renv subst co1 co2
+ = do { subst1 <- match_co renv subst co1 co2
; match renv subst1 e1 e2 }
-- Everything else fails
match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
Nothing
+-------------
+match_co :: RuleEnv
+ -> RuleSubst
+ -> Coercion
+ -> Coercion
+ -> Maybe RuleSubst
+match_co renv subst (CoVarCo cv) co
+ = match_var renv subst cv (Coercion co)
+match_co _ _ co1 _
+ = pprTrace "match_co baling out" (ppr co1) Nothing
+
+-------------
rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv
rnMatchBndr2 renv subst x1 x2
= renv { rv_lcl = rnBndr2 rn_env x1 x2
ruleCheck _ (Var _) = emptyBag
ruleCheck _ (Lit _) = emptyBag
ruleCheck _ (Type _) = emptyBag
+ruleCheck _ (Coercion _) = emptyBag
ruleCheck env (App f a) = ruleCheckApp env (App f a) []
ruleCheck env (Note _ e) = ruleCheck env e
ruleCheck env (Cast e _) = ruleCheck env e
import HscTypes ( ModGuts(..) )
import WwLib ( mkWorkerArgs )
import DataCon
-import Coercion
+import Coercion hiding( substTy, substCo )
import Rules
-import Type hiding( substTy )
+import Type hiding ( substTy )
import Id
import MkCore ( mkImpossibleExpr )
import Var
import DmdAnal ( both )
import Serialized ( deserializeWithData )
import Util
+import Pair
import UniqSupply
import Outputable
import FastString
scSubstTy :: ScEnv -> Type -> Type
scSubstTy env ty = substTy (sc_subst env) ty
+scSubstCo :: ScEnv -> Coercion -> Coercion
+scSubstCo env co = substCo (sc_subst env) co
+
zapScSubst :: ScEnv -> ScEnv
zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
varsToCoreExprs alt_bndrs
- zap v | isTyCoVar v = v -- See NB2 above
+ zap v | isTyVar v = v -- See NB2 above
| otherwise = zapIdOccInfo v
e' -> scExpr (zapScSubst env) e'
scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t))
+scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))
scExpr' _ e@(Lit {}) = return (nullUsage, e)
scExpr' env (Note n e) = do (usg,e') <- scExpr env e
return (usg, Note n e')
scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
- return (usg, Cast e' (scSubstTy env co))
+ return (usg, Cast e' (scSubstCo env co))
scExpr' env e@(App _ _) = scApp env (collectArgs e)
scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
(usg, e') <- scExpr env' e
; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }
scExpr' env (Let (NonRec bndr rhs) body)
- | isTyCoVar bndr -- Type-lets may be created by doBeta
+ | isTyVar bndr -- Type-lets may be created by doBeta
= scExpr' (extendScSubst env bndr rhs) body
| otherwise
spec_count' = n_pats + spec_count
; case sc_count env of
Just max | not (sc_force env) && spec_count' > max
- -> pprTrace "SpecConstr" msg $
- return (nullUsage, spec_info)
+ -> if (debugIsOn || opt_PprStyle_Debug) -- Suppress this scary message for
+ then pprTrace "SpecConstr" msg $ -- ordinary users! Trac #5125
+ return (nullUsage, spec_info)
+ else return (nullUsage, spec_info)
where
msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn)
, nest 2 (ptext (sLit "has") <+>
dmd_env = go emptyVarEnv dmds pats
go env ds (Type {} : pats) = go env ds pats
+ go env ds (Coercion {} : pats) = go env ds pats
go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
go env _ _ = env
-- at the call site
-- See Note [Shadowing] at the top
- (tvs, ids) = partition isTyCoVar qvars
+ (tvs, ids) = partition isTyVar qvars
qvars' = tvs ++ ids
-- Put the type variables first; the type of a term
-- variable may mention a type variable
argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
= return (False, arg)
+
+argToPat _env _in_scope _val_env arg@(Coercion {}) _arg_occ
+ = return (False, arg)
argToPat env in_scope val_env (Note _ arg) arg_occ
= argToPat env in_scope val_env arg arg_occ
-}
argToPat env in_scope val_env (Cast arg co) arg_occ
- | isIdentityCoercion co -- Substitution in the SpecConstr itself
- -- can lead to identity coercions
+ | isReflCo co -- Substitution in the SpecConstr itself
+ -- can lead to identity coercions
= argToPat env in_scope val_env arg arg_occ
| not (ignoreType env ty2)
= do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
{ -- Make a wild-card pattern for the coercion
uniq <- getUniqueUs
; let co_name = mkSysTvName uniq (fsLit "sg")
- co_var = mkCoVar co_name (mkCoKind ty1 ty2)
- ; return (interesting, Cast arg' (mkTyVarTy co_var)) } }
+ co_var = mkCoVar co_name (mkCoType ty1 ty2)
+ ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }
where
- (ty1, ty2) = coercionKind co
+ Pair ty1 ty2 = coercionKind co
-- as well, for let-bound constructors!
isValue env (Lam b e)
- | isTyCoVar b = case isValue env e of
+ | isTyVar b = case isValue env e of
Just _ -> Just LambdaVal
Nothing -> Nothing
| otherwise = Just LambdaVal
same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
same (Type {}) (Type {}) = True -- Note [Ignore type differences]
+ same (Coercion {}) (Coercion {}) = True
same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes
same (Cast e1 _) e2 = same e1 e2
same e1 (Note _ e2) = same e1 e2
---------------- First the easy cases --------------------
specExpr subst (Type ty) = return (Type (CoreSubst.substTy subst ty), emptyUDs)
+specExpr subst (Coercion co) = return (Coercion (CoreSubst.substCo subst co), emptyUDs)
specExpr subst (Var v) = return (specVar subst v, emptyUDs)
specExpr _ (Lit lit) = return (Lit lit, emptyUDs)
specExpr subst (Cast e co) = do
(e', uds) <- specExpr subst e
- return ((Cast e' (CoreSubst.substTy subst co)), uds)
+ return ((Cast e' (CoreSubst.substCo subst co)), uds)
specExpr subst (Note note body) = do
(body', uds) <- specExpr subst body
return (Note (specNote subst note) body', uds)
cmp Nothing Nothing = EQ
cmp Nothing (Just _) = LT
cmp (Just _) Nothing = GT
- cmp (Just t1) (Just t2) = tcCmpType t1 t2
+ cmp (Just t1) (Just t2) = cmpType t1 t2
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls c1 c2 = plusVarEnv_C unionCallInfoSet c1 c2
interestingDict (Var v) = hasSomeUnfolding (idUnfolding v)
|| isDataConWorkId v
interestingDict (Type _) = False
+interestingDict (Coercion _) = False
interestingDict (App fn (Type _)) = interestingDict fn
+interestingDict (App fn (Coercion _)) = interestingDict fn
interestingDict (Note _ a) = interestingDict a
interestingDict (Cast e _) = interestingDict e
interestingDict _ = True
import Type
import TyCon
+import MkId ( coercionTokenId )
import Id
-import Var ( Var )
import IdInfo
import DataCon
import CostCentre ( noCCS )
-- floated out a binding, in which case it will be approximate.
consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
consistentCafInfo id bind
- = WARN( not (exact || is_sat_thing) , ppr id )
+ = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
safe
where
safe = id_marked_caffy || not binding_is_caffy
decisions. Hence no black holes.
\begin{code}
-coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
-coreToStgExpr (Var v) = coreToStgApp Nothing v []
+coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
+coreToStgExpr (Var v) = coreToStgApp Nothing v []
+coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId []
coreToStgExpr expr@(App _ _)
= coreToStgApp Nothing f args
(args', fvs) <- coreToStgArgs args
return (args', fvs)
+coreToStgArgs (Coercion _ : args) -- Coercion argument; replace with place holder
+ = do { (args', fvs) <- coreToStgArgs args
+ ; return (StgVarArg coercionTokenId : args', fvs) }
+
coreToStgArgs (arg : args) = do -- Non-type argument
(stg_args, args_fvs) <- coreToStgArgs args
(arg', arg_fvs, _escs) <- coreToStgExpr arg
go (Cast e _) as = go e as
go (Note _ e) as = go e as
go (Lam b e) as
- | isTyCoVar b = go e as -- Note [Collect args]
+ | isTyVar b = go e as -- Note [Collect args]
go _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
\end{code}
#if mingw32_TARGET_OS
import Packages ( isDllName )
-
+import Type ( typePrimRep )
+import TyCon ( PrimRep(..) )
#endif
\end{code}
= isDllName this_pkg (dataConName con) || any is_dll_arg args
where
is_dll_arg ::StgArg -> Bool
- is_dll_arg (StgVarArg v) = isDllName this_pkg (idName v)
+ is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v))
+ && isDllName this_pkg (idName v)
is_dll_arg _ = False
+
+isAddrRep :: PrimRep -> Bool
+-- True of machine adddresses; these are the things that don't
+-- work across DLLs.
+-- The key point here is that VoidRep comes out False, so that
+-- a top level nullary GADT construtor is False for isDllConApp
+-- data T a where
+-- T1 :: T Int
+-- gives
+-- T1 :: forall a. (a~Int) -> T a
+-- and hence the top-level binding
+-- $WT1 :: T Int
+-- $WT1 = T1 Int (Coercion (Refl Int))
+-- The coercion argument here gets VoidRep
+isAddrRep AddrRep = True
+isAddrRep PtrRep = True
+isAddrRep _ = False
+
#else
isDllConApp _ _ _ = False
#endif
import Demand -- All of it
import CoreSyn
import PprCore
+import Coercion ( isCoVarType )
import CoreUtils ( exprIsHNF, exprIsTrivial )
import CoreArity ( exprArity )
import DataCon ( dataConTyCon, dataConRepStrictness )
setIdStrictness, idDemandInfo, idUnfolding,
idDemandInfo_maybe, setIdDemandInfo
)
-import Var ( Var )
+import Var ( Var, isTyVar )
import VarEnv
import TysWiredIn ( unboxedPairDataCon )
import TysPrim ( realWorldStatePrimTy )
import UniqFM ( addToUFM_Directly, lookupUFM_Directly,
minusUFM, filterUFM )
-import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe )
+import Type ( isUnLiftedType, eqType, splitTyConApp_maybe )
import Coercion ( coercionKind )
import Util ( mapAndUnzip, lengthIs, zipEqual )
import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive,
RecFlag(..), isRec, isMarkedStrict )
import Maybes ( orElse, expectJust )
import Outputable
+import Pair
import Data.List
import FastString
\end{code}
dmdAnal _ _ (Lit lit) = (topDmdType, Lit lit)
dmdAnal _ _ (Type ty) = (topDmdType, Type ty) -- Doesn't happen, in fact
+dmdAnal _ _ (Coercion co) = (topDmdType, Coercion co)
dmdAnal env dmd (Var var)
= (dmdTransform env var dmd, Var var)
= (dmd_ty, Cast e' co)
where
(dmd_ty, e') = dmdAnal env dmd' e
- to_co = snd (coercionKind co)
+ to_co = pSnd (coercionKind co)
dmd'
| Just (tc, _) <- splitTyConApp_maybe to_co
, isRecursiveTyCon tc = evalDmd
where
(fun_ty, fun') = dmdAnal env dmd fun
+dmdAnal sigs dmd (App fun (Coercion co))
+ = (fun_ty, App fun' (Coercion co))
+ where
+ (fun_ty, fun') = dmdAnal sigs dmd fun
+
-- Lots of the other code is there to make this
-- beautiful, compositional, application rule :-)
dmdAnal env dmd (App fun arg) -- Non-type arguments
(res_ty `bothType` arg_ty, App fun' arg')
dmdAnal env dmd (Lam var body)
- | isTyCoVar var
+ | isTyVar var
= let
(body_ty, body') = dmdAnal env dmd body
in
-- ; print len }
io_hack_reqd = con == DataAlt unboxedPairDataCon &&
- idType (head bndrs) `coreEqType` realWorldStatePrimTy
+ idType (head bndrs) `eqType` realWorldStatePrimTy
in
(final_alt_ty, (con, bndrs', rhs'))
-- The returned var is annotated with demand info
-- No effect on the argument demands
annotateBndr dmd_ty@(DmdType fv ds res) var
- | isTyCoVar var = (dmd_ty, var)
+ | isTyVar var = (dmd_ty, var)
| otherwise = (DmdType fv' ds res, setIdDemandInfo var dmd)
where
(fv', dmd) = removeFV fv var res
zapUnlifted :: Id -> Demand -> Demand
-- For unlifted-type variables, we are only
-- interested in Bot/Abs/Box Abs
-zapUnlifted _ Bot = Bot
-zapUnlifted _ Abs = Abs
-zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd
- | otherwise = dmd
+zapUnlifted id dmd
+ = case dmd of
+ _ | isCoVarType ty -> lazyDmd -- For coercions, ignore str/abs totally
+ Bot -> Bot
+ Abs -> Abs
+ _ | isUnLiftedType ty -> lazyDmd -- For unlifted types, ignore strictness
+ | otherwise -> dmd
+ where
+ ty = idType id
\end{code}
Note [Lamba-bound unfoldings]
wwExpr :: CoreExpr -> UniqSM CoreExpr
wwExpr e@(Type {}) = return e
+wwExpr e@(Coercion {}) = return e
wwExpr e@(Lit {}) = return e
wwExpr e@(Var {}) = return e
import TysPrim ( realWorldStatePrimTy )
import TysWiredIn ( tupleCon )
import Type
-import Coercion ( mkSymCoercion, splitNewTypeRepCo_maybe )
+import Coercion ( mkSymCo, splitNewTypeRepCo_maybe )
import BasicTypes ( Boxity(..) )
import Literal ( absentLiteralOf )
-import Var ( Var )
import UniqSupply
import Unique
import Util ( zipWithEqual )
= do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)
<- mkWWargs subst rep_ty arg_info
; return (wrap_args,
- \e -> Cast (wrap_fn_args e) (mkSymCoercion co),
+ \e -> Cast (wrap_fn_args e) (mkSymCo co),
\e -> work_fn_args (Cast e co),
res_ty) }
<- mkWWargs subst fun_ty' arg_info'
; return (id : wrap_args,
Lam id . wrap_fn_args,
- work_fn_args . (`App` Var id),
+ work_fn_args . (`App` varToCoreExpr id),
res_ty) }
| otherwise
Note [Freshen type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-mkWWargs may be given a type like (a~b) => <blah>
-Which really means forall (co:a~b). <blah>
-Because the name of the coercion variable, 'co', isn't mentioned in <blah>,
-nested coercion foralls may all use the same variable; and sometimes do
-see Var.mkWildCoVar.
-
-However, when we do a worker/wrapper split, we must not use shadowed names,
+Wen we do a worker/wrapper split, we must not use shadowed names,
else we'll get
- f = /\ co /\co. fw co co
-which is obviously wrong. Actually, the same is true of type variables, which
-can in principle shadow, within a type (e.g. forall a. a -> forall a. a->a).
-But type variables *are* mentioned in <blah>, so we must substitute.
+ f = /\ a /\a. fw a a
+which is obviously wrong. Type variables can can in principle shadow,
+within a type (e.g. forall a. a -> forall a. a->a). But type
+variables *are* mentioned in <blah>, so we must substitute.
That's why we carry the TvSubst through mkWWargs
-- brings into scope wrap_arg (via lets)
mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one arg
- | isTyCoVar arg
+ | isTyVar arg
= return ([arg], nop_fn, nop_fn)
| otherwise
| Just (tc, _) <- splitTyConApp_maybe arg_ty
, Just lit <- absentLiteralOf tc
= Just (Let (NonRec arg (Lit lit)))
- | arg_ty `coreEqType` realWorldStatePrimTy
+ | arg_ty `eqType` realWorldStatePrimTy
= Just (Let (NonRec arg (Var realWorldPrimId)))
| otherwise
= WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty )
import HscTypes
import FamInstEnv
+import LoadIface
import TcMType
import TcRnMonad
import TyCon
; (eps, hpt) <- getEpsAndHpt
; let { -- Fetch the iface of a given module. Must succeed as
- -- all imported modules must already have been loaded.
+ -- all directly imported modules must already have been loaded.
modIface mod =
case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
Nothing -> panic "FamInst.checkFamInstConsistency"
Just iface -> iface
; hmiModule = mi_module . hm_iface
- ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details
- ; mkFamInstEnv = extendFamInstEnvList emptyFamInstEnv
- ; hptModInsts = [ (hmiModule hmi, hmiFamInstEnv hmi)
- | hmi <- eltsUFM hpt]
- ; modInstsEnv = eps_mod_fam_inst_env eps -- external modules
- `extendModuleEnvList` -- plus
- hptModInsts -- home package modules
+ ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv
+ . md_fam_insts . hm_details
+ ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)
+ | hmi <- eltsUFM hpt]
; groups = map (dep_finsts . mi_deps . modIface)
directlyImpMods
; okPairs = listToSet $ concatMap allPairs groups
-- the difference gives us the pairs we need to check now
}
- ; mapM_ (check modInstsEnv) toCheckPairs
+ ; mapM_ (check hpt_fam_insts) toCheckPairs
}
where
allPairs [] = []
allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
- -- The modules are guaranteed to be in the environment, as they are either
- -- already loaded in the EPS or they are in the HPT.
- --
- check modInstsEnv (ModulePair m1 m2)
- = let { instEnv1 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1
- ; instEnv2 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m2
- ; insts1 = famInstEnvElts instEnv1
- }
- in
- mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1
+ check hpt_fam_insts (ModulePair m1 m2)
+ = do { env1 <- getFamInsts hpt_fam_insts m1
+ ; env2 <- getFamInsts hpt_fam_insts m2
+ ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))
+ (famInstEnvElts env1) }
+
+getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
+getFamInsts hpt_fam_insts mod
+ | Just env <- lookupModuleEnv hpt_fam_insts mod = return env
+ | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
+ ; eps <- getEps
+ ; return (expectJust "checkFamInstConsistency" $
+ lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
+ where
+ doc = ppr mod <+> ptext (sLit "is a family-instance module")
\end{code}
%************************************************************************
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
loc = getSrcLoc famInst
-\end{code}
-
-\begin{code}
tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv)
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
tcGetFamInstEnvs
= do { eps <- getEps; env <- getGblEnv
- ; return (eps_fam_inst_env eps, tcg_fam_inst_env env)
- }
-
-
+ ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
\end{code}
import TcType
import Class
import Unify
-import Coercion
import HscTypes
import Id
import Name
-import Var
+import Var ( Var, TyVar, EvVar, varType, setVarType )
import VarEnv
import VarSet
import PrelNames
instCallConstraints origin (EqPred ty1 ty2 : preds) -- Try short-cut
= do { traceTc "instCallConstraints" $ ppr (EqPred ty1 ty2)
- ; coi <- unifyType ty1 ty2
+ ; co <- unifyType ty1 ty2
; co_fn <- instCallConstraints origin preds
- ; let co = case coi of
- IdCo ty -> ty
- ACo co -> co
; return (co_fn <.> WpEvApp (EvCoercion co)) }
instCallConstraints origin (pred : preds)
= EvVarX (tidyEvVar env v) (tidyFlavor env fl)
tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
-tidyFlavor env (Given loc) = Given (tidyGivenLoc env loc)
+tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk
tidyFlavor _ fl = fl
tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
= EvVarX (substEvVar subst v) (substFlavor subst fl)
substFlavor :: TvSubst -> CtFlavor -> CtFlavor
-substFlavor subst (Given loc) = Given (substGivenLoc subst loc)
-substFlavor _ fl = fl
+substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk
+substFlavor _ fl = fl
substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
substGivenLoc subst (CtLoc skol span ctxt) = CtLoc (substSkolemInfo subst skol) span ctxt
substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty)
substSkolemInfo subst (InferSkol ids) = InferSkol (mapSnd (substTy subst) ids)
substSkolemInfo _ info = info
-\end{code}
\ No newline at end of file
+\end{code}
\begin{code}
module TcArrows ( tcProc ) where
-import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp )
+import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId )
import HsSyn
import TcMatches
import TcPat
import TcUnify
import TcRnMonad
+import TcEnv
import Coercion
+import Id( mkLocalId )
import Inst
import Name
import TysWiredIn
\begin{code}
tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr
-> TcRhoType -- Expected type of whole proc expression
- -> TcM (OutPat TcId, LHsCmdTop TcId, CoercionI)
+ -> TcM (OutPat TcId, LHsCmdTop TcId, Coercion)
tcProc pat cmd exp_ty
= newArrowScope $
do { (coi, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
; (coi1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
; let cmd_env = CmdEnv { cmd_arr = arr_ty }
- ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $
+ ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $
tcCmdTop cmd_env cmd [] res_ty
- ; let res_coi = mkTransCoI coi (mkAppTyCoI coi1 (IdCo res_ty))
- ; return (pat', cmd', res_coi) }
+ ; let res_coi = mkTransCo coi (mkAppCo coi1 (mkReflCo res_ty))
+ ; return (pat', cmd', res_coi) }
\end{code}
tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty
= setSrcSpan loc $
- do { cmd' <- tcGuardedCmd env cmd cmd_stk res_ty
+ do { cmd' <- tcCmd env cmd (cmd_stk, res_ty)
; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') }
----------------------------------------
-tcGuardedCmd :: CmdEnv -> LHsExpr Name -> CmdStack
- -> TcTauType -> TcM (LHsExpr TcId)
--- A wrapper that deals with the refinement (if any)
-tcGuardedCmd env expr stk res_ty
- = do { body <- tcCmd env expr (stk, res_ty)
- ; return body
- }
-
tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId)
-- The main recursive function
tcCmd env (L loc expr) res_ty
where
match_ctxt = MC { mc_what = CaseAlt,
mc_body = mc_body }
- mc_body body res_ty' = tcGuardedCmd env body stk res_ty'
+ mc_body body res_ty' = tcCmd env body (stk, res_ty')
tc_cmd env (HsIf mb_fun pred b1 b2) (stack_ty,res_ty)
= do { pred_ty <- newFlexiTyVarTy openTypeKind
-- Check the patterns, and the GRHSs inside
; (pats', grhss') <- setSrcSpan mtch_loc $
- tcPats LambdaExpr pats cmd_stk $
- tc_grhss grhss res_ty
+ tcPats LambdaExpr pats cmd_stk $
+ tc_grhss grhss res_ty
; let match' = L mtch_loc (Match pats' Nothing grhss')
; return (HsLam (MatchGroup [match'] res_ty))
; return (GRHSs grhss' binds') }
tc_grhs res_ty (GRHS guards body)
- = do { (guards', rhs') <- tcStmts pg_ctxt tcGuardStmt guards res_ty $
- tcGuardedCmd env body stk'
+ = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
+ \ res_ty -> tcCmd env body (stk', res_ty)
; return (GRHS guards' rhs') }
-------------------------------------------
-- Do notation
-tc_cmd env cmd@(HsDo do_or_lc stmts body _ty) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty)
= do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
- ; (stmts', body') <- tcStmts do_or_lc (tcMDoStmt tc_rhs) stmts res_ty $
- tcGuardedCmd env body []
- ; return (HsDo do_or_lc stmts' body' res_ty) }
+ ; stmts' <- tcStmts do_or_lc (tcArrDoStmt env) stmts res_ty
+ ; return (HsDo do_or_lc stmts' res_ty) }
where
- tc_rhs rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
- ; rhs' <- tcCmd env rhs ([], ty)
- ; return (rhs', ty) }
-----------------------------------------------------------------
e_res_ty
-- Check expr
- ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $
+ ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $
escapeArrowScope (tcMonoExpr expr e_ty)
-- OK, now we are in a position to unscramble
-- Check that it has the right shape:
-- ((w,s1) .. sn)
-- where the si do not mention w
- ; checkTc (corner_ty `tcEqType` mkTyVarTy w_tv &&
+ ; checkTc (corner_ty `eqType` mkTyVarTy w_tv &&
not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
(badFormFun i tup_ty')
%************************************************************************
%* *
+ Stmts
+%* *
+%************************************************************************
+
+\begin{code}
+--------------------------------
+-- Mdo-notation
+-- The distinctive features here are
+-- (a) RecStmts, and
+-- (b) no rebindable syntax
+
+tcArrDoStmt :: CmdEnv -> TcStmtChecker
+tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside
+ = do { rhs' <- tcCmd env rhs ([], res_ty)
+ ; thing <- thing_inside (panic "tcArrDoStmt")
+ ; return (LastStmt rhs' noSyntaxExpr, thing) }
+
+tcArrDoStmt env _ (ExprStmt rhs _ _ _) res_ty thing_inside
+ = do { (rhs', elt_ty) <- tc_arr_rhs env rhs
+ ; thing <- thing_inside res_ty
+ ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
+
+tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside
+ = do { (rhs', pat_ty) <- tc_arr_rhs env rhs
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
+ thing_inside res_ty
+ ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
+
+tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
+ , recS_rec_ids = recNames }) res_ty thing_inside
+ = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
+ ; let rec_ids = zipWith mkLocalId recNames rec_tys
+ ; tcExtendIdEnv rec_ids $ do
+ { (stmts', (later_ids, rec_rets))
+ <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' ->
+ -- ToDo: res_ty not really right
+ do { rec_rets <- zipWithM tcCheckId recNames rec_tys
+ ; later_ids <- tcLookupLocalIds laterNames
+ ; return (later_ids, rec_rets) }
+
+ ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
+ -- NB: The rec_ids for the recursive things
+ -- already scope over this part. This binding may shadow
+ -- some of them with polymorphic things with the same Name
+ -- (see note [RecStmt] in HsExpr)
+
+ ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids
+ , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
+ , recS_ret_ty = res_ty }, thing)
+ }}
+
+tcArrDoStmt _ _ stmt _ _
+ = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)
+
+tc_arr_rhs :: CmdEnv -> LHsExpr Name -> TcM (LHsExpr TcId, TcType)
+tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
+ ; rhs' <- tcCmd env rhs ([], ty)
+ ; return (rhs', ty) }
+\end{code}
+
+
+%************************************************************************
+%* *
Helpers
%* *
%************************************************************************
-- where F is a type function and (F a ~ [a])
-- Then unification might succeed with a coercion. But it's much
-- much simpler to require that such signatures have identical contexts
- checkTc (all isIdentityCoI cois)
+ checkTc (all isReflCo cois)
(ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
}
\end{code}
#include "HsVersions.h"
import BasicTypes
-import Type
+import Id ( evVarPred )
+import TcErrors
import TcRnTypes
import FunDeps
import qualified TcMType as TcM
import TcType
-import TcErrors
+import Type
import Coercion
import Class
import TyCon
up a bit; right now we waste a lot of energy traversing the same types
multiple times.
+
\begin{code}
+
-- Flatten a bunch of types all at once.
flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts)
-- Coercions :: Xi ~ Type
-- Preserve type synonyms if possible
-- We can tell if ty' is function-free by
-- whether there are any floated constraints
- ; if isEmptyCCan ccs then
- return (ty, ty, emptyCCan)
+ ; if isReflCo co then
+ return (ty, mkReflCo ty, emptyCCan)
else
return (xi, co, ccs) }
flatten _ v@(TyVarTy _)
- = return (v, v, emptyCCan)
+ = return (v, mkReflCo v, emptyCCan)
flatten ctxt (AppTy ty1 ty2)
= do { (xi1,co1,c1) <- flatten ctxt ty1
; (xi2,co2,c2) <- flatten ctxt ty2
- ; return (mkAppTy xi1 xi2, mkAppCoercion co1 co2, c1 `andCCan` c2) }
+ ; return (mkAppTy xi1 xi2, mkAppCo co1 co2, c1 `andCCan` c2) }
flatten ctxt (FunTy ty1 ty2)
= do { (xi1,co1,c1) <- flatten ctxt ty1
; (xi2,co2,c2) <- flatten ctxt ty2
- ; return (mkFunTy xi1 xi2, mkFunCoercion co1 co2, c1 `andCCan` c2) }
+ ; return (mkFunTy xi1 xi2, mkFunCo co1 co2, c1 `andCCan` c2) }
flatten fl (TyConApp tc tys)
-- For a normal type constructor or data family application, we just
-- recursively flatten the arguments.
| not (isSynFamilyTyCon tc)
= do { (xis,cos,ccs) <- flattenMany fl tys
- ; return (mkTyConApp tc xis, mkTyConCoercion tc cos, ccs) }
+ ; return (mkTyConApp tc xis, mkTyConAppCo tc cos, ccs) }
-- Otherwise, it's a type function application, and we have to
-- flatten it away as well, and generate a new given equality constraint
-- between the application and a newly generated flattening skolem variable.
- | otherwise
+ | otherwise
= ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated
do { (xis, cos, ccs) <- flattenMany fl tys
; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis
-- The type function might be *over* saturated
-- in which case the remaining arguments should
-- be dealt with by AppTys
- fam_ty = mkTyConApp tc xi_args
- fam_co = fam_ty -- identity
-
- ; (ret_co, rhs_var, ct) <-
- if isGiven fl then
- do { rhs_var <- newFlattenSkolemTy fam_ty
- ; cv <- newGivenCoVar fam_ty rhs_var fam_co
- ; let ct = CFunEqCan { cc_id = cv
- , cc_flavor = fl -- Given
- , cc_fun = tc
- , cc_tyargs = xi_args
- , cc_rhs = rhs_var }
- ; return $ (mkCoVarCoercion cv, rhs_var, ct) }
- else -- Derived or Wanted: make a new *unification* flatten variable
- do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
- ; cv <- newCoVar fam_ty rhs_var
- ; let ct = CFunEqCan { cc_id = cv
- , cc_flavor = mkWantedFlavor fl
- -- Always Wanted, not Derived
- , cc_fun = tc
- , cc_tyargs = xi_args
- , cc_rhs = rhs_var }
- ; return $ (mkCoVarCoercion cv, rhs_var, ct) }
-
+ fam_ty = mkTyConApp tc xi_args
+ ; (ret_co, rhs_var, ct) <-
+ do { is_cached <- lookupFlatCacheMap tc xi_args fl
+ ; case is_cached of
+ Just (rhs_var,ret_co,_fl) -> return (ret_co, rhs_var, emptyCCan)
+ Nothing
+ | isGivenOrSolved fl ->
+ do { rhs_var <- newFlattenSkolemTy fam_ty
+ ; cv <- newGivenCoVar fam_ty rhs_var (mkReflCo fam_ty)
+ ; let ct = CFunEqCan { cc_id = cv
+ , cc_flavor = fl -- Given
+ , cc_fun = tc
+ , cc_tyargs = xi_args
+ , cc_rhs = rhs_var }
+ ; let ret_co = mkCoVarCo cv
+ ; updateFlatCacheMap tc xi_args rhs_var fl ret_co
+ ; return $ (ret_co, rhs_var, singleCCan ct) }
+ | otherwise ->
+ -- Derived or Wanted: make a new *unification* flatten variable
+ do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
+ ; cv <- newCoVar fam_ty rhs_var
+ ; let ct = CFunEqCan { cc_id = cv
+ , cc_flavor = mkWantedFlavor fl
+ -- Always Wanted, not Derived
+ , cc_fun = tc
+ , cc_tyargs = xi_args
+ , cc_rhs = rhs_var }
+ ; let ret_co = mkCoVarCo cv
+ ; updateFlatCacheMap tc xi_args rhs_var fl ret_co
+ ; return $ (ret_co, rhs_var, singleCCan ct) } }
; return ( foldl AppTy rhs_var xi_rest
- , foldl AppTy (mkSymCoercion ret_co
- `mkTransCoercion` mkTyConCoercion tc cos_args) cos_rest
- , ccs `extendCCans` ct) }
-
+ , foldl AppCo (mkSymCo ret_co
+ `mkTransCo` mkTyConAppCo tc cos_args)
+ cos_rest
+ , ccs `andCCan` ct) }
flatten ctxt (PredTy pred)
= do { (pred', co, ccs) <- flattenPred ctxt pred
tv_set = mkVarSet tvs
; unless (isEmptyBag bad_eqs)
(flattenForAllErrorTcS ctxt ty bad_eqs)
- ; return (mkForAllTys tvs rho', mkForAllTys tvs co, ccs) }
+ ; return (mkForAllTys tvs rho', foldr mkForAllCo co tvs, ccs) }
---------------
flattenPred :: CtFlavor -> TcPredType -> TcS (TcPredType, Coercion, CanonicalCts)
flattenPred ctxt (ClassP cls tys)
= do { (tys', cos, ccs) <- flattenMany ctxt tys
- ; return (ClassP cls tys', mkClassPPredCo cls cos, ccs) }
+ ; return (ClassP cls tys', mkPredCo $ ClassP cls cos, ccs) }
flattenPred ctxt (IParam nm ty)
= do { (ty', co, ccs) <- flatten ctxt ty
- ; return (IParam nm ty', mkIParamPredCo nm co, ccs) }
--- TODO: Handling of coercions between EqPreds must be revisited once the New Coercion API is ready!
+ ; return (IParam nm ty', mkPredCo $ IParam nm co, ccs) }
flattenPred ctxt (EqPred ty1 ty2)
= do { (ty1', co1, ccs1) <- flatten ctxt ty1
; (ty2', co2, ccs2) <- flatten ctxt ty2
- ; return (EqPred ty1' ty2', mkEqPredCo co1 co2, ccs1 `andCCan` ccs2) }
-
+ ; return (EqPred ty1' ty2', mkPredCo $ EqPred co1 co2, ccs1 `andCCan` ccs2) }
\end{code}
%************************************************************************
canWanteds = fmap unionWorkLists . mapM (\(EvVarX ev loc) -> mkCanonical (Wanted loc) ev)
canGivens :: GivenLoc -> [EvVar] -> TcS WorkList
-canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc)) givens
+canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc GivenOrig)) givens
; return (unionWorkLists ccs) }
mkCanonicals :: CtFlavor -> [EvVar] -> TcS WorkList
canon_one fev wl = do { wl' <- mkCanonicalFEV fev
; return (unionWorkList wl' wl) }
+
mkCanonical :: CtFlavor -> EvVar -> TcS WorkList
mkCanonical fl ev = case evVarPred ev of
ClassP clas tys -> canClassToWorkList fl ev clas tys
canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList
canClassToWorkList fl v cn tys
= do { (xis,cos,ccs) <- flattenMany fl tys -- cos :: xis ~ tys
- ; let no_flattening_happened = isEmptyCCan ccs
- dict_co = mkTyConCoercion (classTyCon cn) cos
- ; v_new <- if no_flattening_happened then return v
- else if isGiven fl then return v
+ ; let no_flattening_happened = all isReflCo cos
+ dict_co = mkTyConAppCo (classTyCon cn) cos
+ ; v_new <- if no_flattening_happened then return v
+ else if isGivenOrSolved fl then return v
-- The cos are all identities if fl=Given,
-- hence nothing to do
else do { v' <- newDictVar cn xis -- D xis
; when (isWanted fl) $ setDictBind v (EvCast v' dict_co)
- ; when (isGiven fl) $ setDictBind v' (EvCast v (mkSymCoercion dict_co))
+ ; when (isGivenOrSolved fl) $ setDictBind v' (EvCast v (mkSymCo dict_co))
-- NB: No more setting evidence for derived now
; return v' }
Here's an example that demonstrates why we chose to NOT add
superclasses during simplification: [Comes from ticket #4497]
-
+
class Num (RealOf t) => Normed t
type family RealOf x
= return emptyWorkList -- Deriveds don't yield more superclasses because we will
-- add them transitively in the case of wanteds.
- | isGiven orig_flavor
- = do { let sc_theta = immSuperClasses cls xis
- flavor = orig_flavor
- ; sc_vars <- mapM newEvVar sc_theta
- ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
- ; mkCanonicals flavor sc_vars }
-
- | isEmptyVarSet (tyVarsOfTypes xis)
+ | Just gk <- isGiven_maybe orig_flavor
+ = case gk of
+ GivenOrig -> do { let sc_theta = immSuperClasses cls xis
+ flavor = orig_flavor
+ ; sc_vars <- mapM newEvVar sc_theta
+ ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
+ ; mkCanonicals flavor sc_vars }
+ GivenSolved -> return emptyWorkList
+ -- Seems very dangerous to add the superclasses for dictionaries that may be
+ -- partially solved because we may end up with evidence loops.
+
+ | isEmptyVarSet (tyVarsOfTypes xis)
= return emptyWorkList -- Wanteds with no variables yield no deriveds.
-- See Note [Improvement from Ground Wanteds]
canEq :: CtFlavor -> EvVar -> Type -> Type -> TcS CanonicalCts
canEq fl cv ty1 ty2
- | tcEqType ty1 ty2 -- Dealing with equality here avoids
+ | eqType ty1 ty2 -- Dealing with equality here avoids
-- later spurious occurs checks for a~a
- = do { when (isWanted fl) (setCoBind cv ty1)
+ = do { when (isWanted fl) (setCoBind cv (mkReflCo ty1))
; return emptyCCan }
-- If one side is a variable, orient and flatten,
; canEqLeaf untch fl cv (classify ty1) (classify ty2) }
-- NB: don't use VarCls directly because tv1 or tv2 may be scolems!
-canEq fl cv (TyConApp fn tys) ty2
- | isSynFamilyTyCon fn, length tys == tyConArity fn
- = do { untch <- getUntouchables
- ; canEqLeaf untch fl cv (FunCls fn tys) (classify ty2) }
-canEq fl cv ty1 (TyConApp fn tys)
- | isSynFamilyTyCon fn, length tys == tyConArity fn
- = do { untch <- getUntouchables
- ; canEqLeaf untch fl cv (classify ty1) (FunCls fn tys) }
-
-canEq fl cv s1 s2
- | Just (t1a,t1b,t1c) <- splitCoPredTy_maybe s1,
- Just (t2a,t2b,t2c) <- splitCoPredTy_maybe s2
- = do { (v1,v2,v3)
- <- if isWanted fl then -- Wanted
- do { v1 <- newCoVar t1a t2a
- ; v2 <- newCoVar t1b t2b
- ; v3 <- newCoVar t1c t2c
- ; let res_co = mkCoPredCo (mkCoVarCoercion v1)
- (mkCoVarCoercion v2) (mkCoVarCoercion v3)
- ; setCoBind cv res_co
- ; return (v1,v2,v3) }
- else if isGiven fl then -- Given
- let co_orig = mkCoVarCoercion cv
- coa = mkCsel1Coercion co_orig
- cob = mkCsel2Coercion co_orig
- coc = mkCselRCoercion co_orig
- in do { v1 <- newGivenCoVar t1a t2a coa
- ; v2 <- newGivenCoVar t1b t2b cob
- ; v3 <- newGivenCoVar t1c t2c coc
- ; return (v1,v2,v3) }
- else -- Derived
- do { v1 <- newDerivedId (EqPred t1a t2a)
- ; v2 <- newDerivedId (EqPred t1b t2b)
- ; v3 <- newDerivedId (EqPred t1c t2c)
- ; return (v1,v2,v3) }
- ; cc1 <- canEq fl v1 t1a t2a
- ; cc2 <- canEq fl v2 t1b t2b
- ; cc3 <- canEq fl v3 t1c t2c
- ; return (cc1 `andCCan` cc2 `andCCan` cc3) }
-
-
-- Split up an equality between function types into two equalities.
canEq fl cv (FunTy s1 t1) (FunTy s2 t2)
= do { (argv, resv) <-
do { argv <- newCoVar s1 s2
; resv <- newCoVar t1 t2
; setCoBind cv $
- mkFunCoercion (mkCoVarCoercion argv) (mkCoVarCoercion resv)
+ mkFunCo (mkCoVarCo argv) (mkCoVarCo resv)
; return (argv,resv) }
-
- else if isGiven fl then
- let [arg,res] = decomposeCo 2 (mkCoVarCoercion cv)
+ else if isGivenOrSolved fl then
+ let [arg,res] = decomposeCo 2 (mkCoVarCo cv)
in do { argv <- newGivenCoVar s1 s2 arg
; resv <- newGivenCoVar t1 t2 res
; return (argv,resv) }
; cc2 <- canEq fl resv t1 t2
; return (cc1 `andCCan` cc2) }
-canEq fl cv (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2))
- | n1 == n2
- = if isWanted fl then
- do { v <- newCoVar t1 t2
- ; setCoBind cv $ mkIParamPredCo n1 (mkCoVarCoercion cv)
- ; canEq fl v t1 t2 }
- else return emptyCCan -- DV: How to decompose given IP coercions?
-
-canEq fl cv (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2))
- | c1 == c2
- = if isWanted fl then
- do { vs <- zipWithM newCoVar tys1 tys2
- ; setCoBind cv $ mkClassPPredCo c1 (map mkCoVarCoercion vs)
- ; andCCans <$> zipWith3M (canEq fl) vs tys1 tys2
- }
- else return emptyCCan
- -- How to decompose given dictionary (and implicit parameter) coercions?
- -- You may think that the following is right:
- -- let cos = decomposeCo (length tys1) (mkCoVarCoercion cv)
- -- in zipWith3M newGivOrDerCoVar tys1 tys2 cos
- -- But this assumes that the coercion is a type constructor-based
- -- coercion, and not a PredTy (ClassP cn cos) coercion. So we chose
- -- to not decompose these coercions. We have to get back to this
- -- when we clean up the Coercion API.
+canEq fl cv (TyConApp fn tys) ty2
+ | isSynFamilyTyCon fn, length tys == tyConArity fn
+ = do { untch <- getUntouchables
+ ; canEqLeaf untch fl cv (FunCls fn tys) (classify ty2) }
+canEq fl cv ty1 (TyConApp fn tys)
+ | isSynFamilyTyCon fn, length tys == tyConArity fn
+ = do { untch <- getUntouchables
+ ; canEqLeaf untch fl cv (classify ty1) (FunCls fn tys) }
canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
- | isAlgTyCon tc1 && isAlgTyCon tc2
+ | isDecomposableTyCon tc1 && isDecomposableTyCon tc2
, tc1 == tc2
, length tys1 == length tys2
= -- Generate equalities for each of the corresponding arguments
<- if isWanted fl then
do { argsv <- zipWithM newCoVar tys1 tys2
; setCoBind cv $
- mkTyConCoercion tc1 (map mkCoVarCoercion argsv)
- ; return argsv }
-
- else if isGiven fl then
- let cos = decomposeCo (length tys1) (mkCoVarCoercion cv)
+ mkTyConAppCo tc1 (map mkCoVarCo argsv)
+ ; return argsv }
+ else if isGivenOrSolved fl then
+ let cos = decomposeCo (length tys1) (mkCoVarCo cv)
in zipWith3M newGivenCoVar tys1 tys2 cos
else -- Derived
canEq fl cv ty1 ty2
| Just (s1,t1) <- tcSplitAppTy_maybe ty1
, Just (s2,t2) <- tcSplitAppTy_maybe ty2
- = do { (cv1,cv2) <-
- if isWanted fl
- then do { cv1 <- newCoVar s1 s2
- ; cv2 <- newCoVar t1 t2
- ; setCoBind cv $
- mkAppCoercion (mkCoVarCoercion cv1) (mkCoVarCoercion cv2)
- ; return (cv1,cv2) }
-
- else if isGiven fl then
- let co1 = mkLeftCoercion $ mkCoVarCoercion cv
- co2 = mkRightCoercion $ mkCoVarCoercion cv
- in do { cv1 <- newGivenCoVar s1 s2 co1
- ; cv2 <- newGivenCoVar t1 t2 co2
- ; return (cv1,cv2) }
- else -- Derived
- do { cv1 <- newDerivedId (EqPred s1 s2)
- ; cv2 <- newDerivedId (EqPred t1 t2)
- ; return (cv1,cv2) }
-
- ; cc1 <- canEq fl cv1 s1 s2
- ; cc2 <- canEq fl cv2 t1 t2
- ; return (cc1 `andCCan` cc2) }
+ = if isWanted fl
+ then do { cv1 <- newCoVar s1 s2
+ ; cv2 <- newCoVar t1 t2
+ ; setCoBind cv $
+ mkAppCo (mkCoVarCo cv1) (mkCoVarCo cv2)
+ ; cc1 <- canEq fl cv1 s1 s2
+ ; cc2 <- canEq fl cv2 t1 t2
+ ; return (cc1 `andCCan` cc2) }
+
+ else if isDerived fl
+ then do { cv1 <- newDerivedId (EqPred s1 s2)
+ ; cv2 <- newDerivedId (EqPred t1 t2)
+ ; cc1 <- canEq fl cv1 s1 s2
+ ; cc2 <- canEq fl cv2 t1 t2
+ ; return (cc1 `andCCan` cc2) }
+
+ else return emptyCCan -- We cannot decompose given applications
+ -- because we no longer have 'left' and 'right'
canEq fl cv s1@(ForAllTy {}) s2@(ForAllTy {})
| tcIsForAllTy s1, tcIsForAllTy s2,
| cls1 `re_orient` cls2
= do { cv' <- if isWanted fl
then do { cv' <- newCoVar s2 s1
- ; setCoBind cv $ mkSymCoercion (mkCoVarCoercion cv')
+ ; setCoBind cv $ mkSymCo (mkCoVarCo cv')
; return cv' }
- else if isGiven fl then
- newGivenCoVar s2 s1 (mkSymCoercion (mkCoVarCoercion cv))
+ else if isGivenOrSolved fl then
+ newGivenCoVar s2 s1 (mkSymCo (mkCoVarCo cv))
else -- Derived
newDerivedId (EqPred s2 s1)
; canEqLeafOriented fl cv' cls2 s1 }
; (xi2, co2, ccs2) <- flatten fl s2 -- Flatten entire RHS
-- co2 :: xi2 ~ s2
; let ccs = ccs1 `andCCan` ccs2
- no_flattening_happened = isEmptyCCan ccs
- ; cv_new <- if no_flattening_happened then return cv
- else if isGiven fl then return cv
+ no_flattening_happened = all isReflCo (co2:cos1)
+ ; cv_new <- if no_flattening_happened then return cv
+ else if isGivenOrSolved fl then return cv
else if isWanted fl then
do { cv' <- newCoVar (unClassify (FunCls fn xis1)) xi2
-- cv' : F xis ~ xi2
; let -- fun_co :: F xis1 ~ F tys1
- fun_co = mkTyConCoercion fn cos1
+ fun_co = mkTyConAppCo fn cos1
-- want_co :: F tys1 ~ s2
- want_co = mkSymCoercion fun_co
- `mkTransCoercion` mkCoVarCoercion cv'
- `mkTransCoercion` co2
+ want_co = mkSymCo fun_co
+ `mkTransCo` mkCoVarCo cv'
+ `mkTransCo` co2
; setCoBind cv want_co
; return cv' }
else -- Derived
; case mxi2' of {
Nothing -> canEqFailure fl cv ;
Just xi2' ->
- do { let no_flattening_happened = isEmptyCCan ccs2
- ; cv_new <- if no_flattening_happened then return cv
- else if isGiven fl then return cv
+ do { let no_flattening_happened = isReflCo co
+ ; cv_new <- if no_flattening_happened then return cv
+ else if isGivenOrSolved fl then return cv
else if isWanted fl then
do { cv' <- newCoVar (mkTyVarTy tv) xi2' -- cv' : tv ~ xi2
- ; setCoBind cv (mkCoVarCoercion cv' `mkTransCoercion` co)
+ ; setCoBind cv (mkCoVarCo cv' `mkTransCo` co)
; return cv' }
else -- Derived
newDerivedId (EqPred (mkTyVarTy tv) xi2')
expandAway tv ty@(ForAllTy {})
= let (tvs,rho) = splitForAllTys ty
tvs_knds = map tyVarKind tvs
- in if tv `elemVarSet` tyVarsOfTypes tvs_knds then
+ in if tv `elemVarSet` tyVarsOfTypes tvs_knds then
-- Can't expand away the kinds unless we create
-- fresh variables which we don't want to do at this point.
Nothing
; mapM (do_one subst) eqs }
where
fl' = case fl of
- Given _ -> panic "mkFunDepEqns"
+ Given {} -> panic "mkFunDepEqns"
Wanted loc -> Wanted (push_ctx loc)
Derived loc -> Derived (push_ctx loc)
push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc
do_one subst (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 })
- = do { let sty1 = substTy subst ty1
- sty2 = substTy subst ty2
+ = do { let sty1 = Type.substTy subst ty1
+ sty2 = Type.substTy subst ty2
; ev <- newCoVar sty1 sty2
; return (i, mkEvVarX ev fl') }
where
do_one :: Type -> Int -> (Type,Coercion)
do_one ty n = case lookup n param_eqs of
- Just wev -> (get_fst_ty wev, mkCoVarCoercion (evVarOf wev))
- Nothing -> (ty,ty) -- Identity
+ Just wev -> (get_fst_ty wev, mkCoVarCo (evVarOf wev))
+ Nothing -> (ty, mkReflCo ty) -- Identity
get_fst_ty wev = case evVarOfPred wev of
EqPred ty1 _ -> ty1
\begin{code}
module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod, tcInstanceMethodBody,
- mkGenericDefMethBind, getGenericInstances,
+ mkGenericDefMethBind,
tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
) where
#include "HsVersions.h"
import HsSyn
-import RnHsSyn
-import RnExpr
-import Inst
-import InstEnv
-import TcPat( addInlinePrags )
import TcEnv
+import TcPat( addInlinePrags )
import TcBinds
import TcUnify
import TcHsType
import TcType
import TcRnMonad
import BuildTyCl( TcMethInfo )
-import Generics
import Class
-import TyCon
-import MkId
import Id
import Name
-import Var
import NameEnv
import NameSet
+import Var
import Outputable
-import PrelNames
import DynFlags
import ErrUtils
-import Util
-import ListSetOps
import SrcLoc
import Maybes
import BasicTypes
import FastString
import Control.Monad
-import Data.List
\end{code}
%************************************************************************
\begin{code}
-tcClassSigs :: Name -- Name of the class
+tcClassSigs :: Name -- Name of the class
-> [LSig Name]
-> LHsBinds Name
- -> TcM [TcMethInfo]
-
+ -> TcM ([TcMethInfo], -- Exactly one for each method
+ NameEnv Type) -- Types of the generic-default methods
tcClassSigs clas sigs def_methods
- = do { dm_env <- mapM (addLocM (checkDefaultBind clas op_names))
- (bagToList def_methods)
- ; mapM (tcClassSig (mkNameEnv dm_env)) op_sigs }
- where
- op_sigs = [sig | sig@(L _ (TypeSig _ _)) <- sigs]
- op_names = [n | (L _ (TypeSig (L _ n) _)) <- op_sigs]
-
-checkDefaultBind :: Name -> [Name] -> HsBindLR Name Name -> TcM (Name, DefMethSpec)
- -- Check default bindings
- -- a) must be for a class op for this class
- -- b) must be all generic or all non-generic
-checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
- = do { -- Check that the op is from this class
- checkTc (op `elem` ops) (badMethodErr clas op)
-
- -- Check that all the defns ar generic, or none are
- ; case (none_generic, all_generic) of
- (True, _) -> return (op, VanillaDM)
- (_, True) -> return (op, GenericDM)
- _ -> failWith (mixedGenericErr op)
- }
- where
- n_generic = count (isJust . maybeGenericMatch) matches
- none_generic = n_generic == 0
- all_generic = matches `lengthIs` n_generic
+ = do { gen_dm_prs <- mapM (addLocM tc_gen_sig) gen_sigs
+ ; let gen_dm_env = mkNameEnv gen_dm_prs
-checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b)
+ ; op_info <- mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
+ ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
+ ; sequence_ [ failWithTc (badMethodErr clas n)
+ | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
+ -- Value binding for non class-method (ie no TypeSig)
-tcClassSig :: NameEnv DefMethSpec -- Info about default methods;
- -> LSig Name
- -> TcM TcMethInfo
+ ; sequence_ [ failWithTc (badGenericMethod clas n)
+ | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
+ -- Generic signature without value binding
-tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
- = setSrcSpan loc $ do
- { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
- ; let dm = lookupNameEnv dm_env op_name `orElse` NoDM
- ; return (op_name, dm, op_ty) }
-tcClassSig _ s = pprPanic "tcClassSig" (ppr s)
+ ; return (op_info, gen_dm_env) }
+ where
+ vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs]
+ gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs]
+ dm_bind_names :: [Name] -- These ones have a value binding in the class decl
+ dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
+
+ tc_sig genop_env (L _ op_name, op_hs_ty)
+ = do { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
+ ; let dm | op_name `elemNameEnv` genop_env = GenericDM
+ | op_name `elem` dm_bind_names = VanillaDM
+ | otherwise = NoDM
+ ; return (op_name, dm, op_ty) }
+
+ tc_gen_sig (L _ op_name, gen_hs_ty)
+ = do { gen_op_ty <- tcHsKindedType gen_hs_ty
+ ; return (op_name, gen_op_ty) }
\end{code}
pred = mkClassPred clas (mkTyVarTys clas_tyvars)
; this_dict <- newEvVar pred
+ ; traceTc "TIM2" (ppr sigs)
; let tc_dm = tcDefMeth clas clas_tyvars
- this_dict default_binds
+ this_dict default_binds
sig_fn prag_fn
; dm_binds <- tcExtendTyVarEnv clas_tyvars $
mapM tc_dm op_items
- ; return (listToBag (catMaybes dm_binds)) }
+ ; return (unionManyBags dm_binds) }
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
-> SigFun -> PragFun -> ClassOpItem
- -> TcM (Maybe (LHsBind Id))
+ -> TcM (LHsBinds TcId)
-- Generate code for polymorphic default methods only (hence DefMeth)
-- (Generic default methods have turned into instance decls by now.)
-- This is incompatible with Hugs, which expects a polymorphic
-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
= case dm_info of
- NoDefMeth -> return Nothing
- GenDefMeth -> return Nothing
- DefMeth dm_name -> do
- { let sel_name = idName sel_id
- ; local_dm_name <- newLocalName sel_name
- -- Base the local_dm_name on the selector name, because
- -- type errors from tcInstanceMethodBody come from here
-
- -- See Note [Silly default-method bind]
- -- (possibly out of date)
-
- ; let meth_bind = findMethodBind sel_name binds_in
- `orElse` pprPanic "tcDefMeth" (ppr sel_id)
- -- dm_info = DefMeth dm_name only if there is a binding in binds_in
-
- dm_sig_fn _ = sig_fn sel_name
- dm_id = mkDefaultMethodId sel_id dm_name
- local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars)
- local_dm_id = mkLocalId local_dm_name local_dm_type
- prags = prag_fn sel_name
-
- ; dm_id_w_inline <- addInlinePrags dm_id prags
- ; spec_prags <- tcSpecPrags dm_id prags
-
- ; warnTc (not (null spec_prags))
- (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
- <+> quotes (ppr sel_name))
-
- ; liftM Just $
- tcInstanceMethodBody (ClsSkol clas)
- tyvars
- [this_dict]
- dm_id_w_inline local_dm_id
- dm_sig_fn IsDefaultMethod meth_bind }
+ NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
+ ; return emptyBag }
+ DefMeth dm_name -> tc_dm dm_name
+ GenDefMeth dm_name -> tc_dm dm_name
+ where
+ sel_name = idName sel_id
+ prags = prag_fn sel_name
+ dm_sig_fn _ = sig_fn sel_name
+ dm_bind = findMethodBind sel_name binds_in
+ `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+
+ -- Eg. class C a where
+ -- op :: forall b. Eq b => a -> [b] -> a
+ -- gen_op :: a -> a
+ -- generic gen_op :: D a => a -> a
+ -- The "local_dm_ty" is precisely the type in the above
+ -- type signatures, ie with no "forall a. C a =>" prefix
+
+ tc_dm dm_name
+ = do { dm_id <- tcLookupId dm_name
+ ; local_dm_name <- newLocalName sel_name
+ -- Base the local_dm_name on the selector name, because
+ -- type errors from tcInstanceMethodBody come from here
+
+ ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
+ local_dm_id = mkLocalId local_dm_name local_dm_ty
+
+ ; dm_id_w_inline <- addInlinePrags dm_id prags
+ ; spec_prags <- tcSpecPrags dm_id prags
+
+ ; warnTc (not (null spec_prags))
+ (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
+ <+> quotes (ppr sel_name))
+
+ ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
+ dm_id_w_inline local_dm_id dm_sig_fn
+ IsDefaultMethod dm_bind
+
+ ; return (unitBag tc_bind) }
---------------
tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
-
+ ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id)))
; (ev_binds, (tc_bind, _))
<- checkConstraints skol_info tyvars dfun_ev_vars $
tcExtendIdEnv [local_meth_id] $
op Unit = ...
\begin{code}
-mkGenericDefMethBind :: Class -> [Type] -> Id -> TcM (LHsBind Name)
-mkGenericDefMethBind clas inst_tys sel_id
+mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
+mkGenericDefMethBind clas inst_tys sel_id dm_name
= -- A generic default method
- -- If the method is defined generically, we can only do the job if the
- -- instance declaration is for a single-parameter type class with
- -- a type constructor applied to type arguments in the instance decl
- -- (checkTc, so False provokes the error)
- do { checkTc (isJust maybe_tycon)
- (badGenericInstance sel_id (notSimple inst_tys))
- ; checkTc (tyConHasGenerics tycon)
- (badGenericInstance sel_id (notGeneric tycon))
-
- ; dflags <- getDOpts
+ -- If the method is defined generically, we only have to call the
+ -- dm_name.
+ do { dflags <- getDOpts
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
(vcat [ppr clas <+> ppr inst_tys,
nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
- -- Rename it before returning it
- ; (rn_rhs, _) <- rnLExpr rhs
; return (noLoc $ mkFunBind (noLoc (idName sel_id))
- [mkSimpleMatch [] rn_rhs]) }
+ [mkSimpleMatch [] rhs]) }
where
- rhs = mkGenericRhs sel_id clas_tyvar tycon
-
- -- The tycon is only used in the generic case, and in that
- -- case we require that the instance decl is for a single-parameter
- -- type class with type variable arguments:
- -- instance (...) => C (T a b)
- clas_tyvar = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
- Just tycon = maybe_tycon
- maybe_tycon = case inst_tys of
- [ty] -> case tcSplitTyConApp_maybe ty of
- Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
- _ -> Nothing
- _ -> Nothing
-
-
----------------------------
-getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name]
-getGenericInstances class_decls
- = do { gen_inst_infos <- mapM (addLocM get_generics) class_decls
- ; let { gen_inst_info = concat gen_inst_infos }
-
- -- Return right away if there is no generic stuff
- ; if null gen_inst_info then return []
- else do
-
- -- Otherwise print it out
- { dumpDerivingInfo $ hang (ptext (sLit "Generic instances"))
- 2 (vcat (map pprInstInfoDetails gen_inst_info))
- ; return gen_inst_info }}
-
-get_generics :: TyClDecl Name -> TcM [InstInfo Name]
-get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
- | null generic_binds
- = return [] -- The comon case: no generic default methods
-
- | otherwise -- A source class decl with generic default methods
- = recoverM (return []) $
- tcAddDeclCtxt decl $ do
- clas <- tcLookupLocatedClass class_name
-
- -- Group by type, and
- -- make an InstInfo out of each group
- let
- groups = groupWith listToBag generic_binds
-
- inst_infos <- mapM (mkGenericInstance clas) groups
-
- -- Check that there is only one InstInfo for each type constructor
- -- The main way this can fail is if you write
- -- f {| a+b |} ... = ...
- -- f {| x+y |} ... = ...
- -- Then at this point we'll have an InstInfo for each
- --
- -- The class should be unary, which is why simpleInstInfoTyCon should be ok
- let
- tc_inst_infos :: [(TyCon, InstInfo Name)]
- tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
-
- bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
- group `lengthExceeds` 1]
- get_uniq (tc,_) = getUnique tc
-
- mapM_ (addErrTc . dupGenericInsts) bad_groups
-
- -- Check that there is an InstInfo for each generic type constructor
- let
- missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
-
- checkTc (null missing) (missingGenericInstances missing)
-
- return inst_infos
- where
- generic_binds :: [(HsType Name, LHsBind Name)]
- generic_binds = getGenericBinds def_methods
-get_generics decl = pprPanic "get_generics" (ppr decl)
-
-
----------------------------------
-getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
- -- Takes a group of method bindings, finds the generic ones, and returns
- -- them in finite map indexed by the type parameter in the definition.
-getGenericBinds binds = concat (map getGenericBind (bagToList binds))
-
-getGenericBind :: LHsBindLR Name Name -> [(HsType Name, LHsBindLR Name Name)]
-getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
- = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
- where
- wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
-getGenericBind _
- = []
-
-groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
-groupWith _ [] = []
-groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
- where
- vs = map snd this
- (this,rest) = partition same_t prs
- same_t (t', _v) = t `eqPatType` t'
-
-eqPatLType :: LHsType Name -> LHsType Name -> Bool
-eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
-
-eqPatType :: HsType Name -> HsType Name -> Bool
--- A very simple equality function, only for
--- type patterns in generic function definitions.
-eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2
-eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2
-eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 && unLoc op1 == unLoc op2
-eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2
-eqPatType (HsParTy t1) t2 = unLoc t1 `eqPatType` t2
-eqPatType t1 (HsParTy t2) = t1 `eqPatType` unLoc t2
-eqPatType _ _ = False
-
----------------------------------
-mkGenericInstance :: Class
- -> (HsType Name, LHsBinds Name)
- -> TcM (InstInfo Name)
-
-mkGenericInstance clas (hs_ty, binds) = do
- -- Make a generic instance declaration
- -- For example: instance (C a, C b) => C (a+b) where { binds }
-
- -- Extract the universally quantified type variables
- -- and wrap them as forall'd tyvars, so that kind inference
- -- works in the standard way
- let
- sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $
- extractHsTyVars (noLoc hs_ty)
- hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
-
- -- Type-check the instance type, and check its form
- forall_inst_ty <- tcHsSigType GenPatCtxt hs_forall_ty
- let
- (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
-
- checkTc (validGenericInstanceType inst_ty)
- (badGenericInstanceType binds)
-
- -- Make the dictionary function.
- span <- getSrcSpanM
- overlap_flag <- getOverlapFlag
- dfun_name <- newDFunName clas [inst_ty] span
- let
- inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
- dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
- ispec = mkLocalInstance dfun_id overlap_flag
-
- return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False })
+ rhs = nlHsVar dm_name
\end{code}
-
%************************************************************************
%* *
Error messages
= hsep [ptext (sLit "Class"), quotes (ppr clas),
ptext (sLit "does not have a method"), quotes (ppr op)]
+badGenericMethod :: Outputable a => a -> Name -> SDoc
+badGenericMethod clas op
+ = hsep [ptext (sLit "Class"), quotes (ppr clas),
+ ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
+
badATErr :: Class -> Name -> SDoc
badATErr clas at
= hsep [ptext (sLit "Class"), quotes (ppr clas),
omittedATWarn :: Name -> SDoc
omittedATWarn at
= ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
-
-badGenericInstance :: Var -> SDoc -> SDoc
-badGenericInstance sel_id because
- = sep [ptext (sLit "Can't derive generic code for") <+> quotes (ppr sel_id),
- because]
-
-notSimple :: [Type] -> SDoc
-notSimple inst_tys
- = vcat [ptext (sLit "because the instance type(s)"),
- nest 2 (ppr inst_tys),
- ptext (sLit "is not a simple type of form (T a1 ... an)")]
-
-notGeneric :: TyCon -> SDoc
-notGeneric tycon
- = vcat [ptext (sLit "because the instance type constructor") <+> quotes (ppr tycon) <+>
- ptext (sLit "was not compiled with -XGenerics")]
-
+{-
badGenericInstanceType :: LHsBinds Name -> SDoc
badGenericInstanceType binds
= vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
]
where
ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
-
-mixedGenericErr :: Name -> SDoc
-mixedGenericErr op
- = ptext (sLit "Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
+-}
+badDmPrag :: Id -> Sig Name -> TcM ()
+badDmPrag sel_id prag
+ = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method")
+ <+> quotes (ppr sel_id)
+ <+> ptext (sLit "lacks an accompanying binding"))
\end{code}
import NameSet
import TyCon
import TcType
+import BuildTyCl
+import BasicTypes
import Var
import VarSet
import PrelNames
import SrcLoc
+import UniqSupply
import Util
import ListSetOps
import Outputable
ds_cls = c, ds_tys = tys, ds_theta = rhs })
= parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
<+> equals <+> ppr rhs)
+
+instance Outputable DerivSpec where
+ ppr = pprDerivSpec
\end{code}
tcDeriving :: [LTyClDecl Name] -- All type constructors
-> [LInstDecl Name] -- All instance declarations
-> [LDerivDecl Name] -- All stand-alone deriving declarations
- -> TcM ([InstInfo Name], -- The generated "instance decls"
- HsValBinds Name, -- Extra generated top-level bindings
- DefUses)
+ -> TcM ([InstInfo Name] -- The generated "instance decls"
+ ,HsValBinds Name -- Extra generated top-level bindings
+ ,DefUses
+ ,[TyCon] -- Extra generated top-level types
+ ,[TyCon]) -- Extra generated type family instances
tcDeriving tycl_decls inst_decls deriv_decls
- = recoverM (return ([], emptyValBindsOut, emptyDUs)) $
+ = recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $
do { -- Fish the "deriving"-related information out of the TcEnv
-- And make the necessary "equations".
is_boot <- tcIsHsBoot
; traceTc "tcDeriving" (ppr is_boot)
- ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+ ; (early_specs, genericsExtras)
+ <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
+ ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras
; overlap_flag <- getOverlapFlag
; let (infer_specs, given_specs) = splitEithers early_specs
; insts2 <- mapM (genInst False overlap_flag) final_specs
- -- Generate the generic to/from functions from each type declaration
- ; gen_binds <- mkGenericBinds is_boot tycl_decls
- ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
+ -- We no longer generate the old generic to/from functions
+ -- from each type declaration, so this is emptyBag
+ ; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls
+
+ ; (inst_info, rn_binds, rn_dus)
+ <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts)
+ ; dflags <- getDOpts
+ ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+ (ddump_deriving inst_info rn_binds repMetaTys repTyCons metaInsts))
+{-
; when (not (null inst_info)) $
dumpDerivingInfo (ddump_deriving inst_info rn_binds)
-
- ; return (inst_info, rn_binds, rn_dus) }
+-}
+ ; return ( inst_info, rn_binds, rn_dus
+ , concat (map metaTyCons2TyCons repMetaTys), repTyCons) }
where
- ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
- ddump_deriving inst_infos extra_binds
- = hang (ptext (sLit "Derived instances"))
- 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
- $$ ppr extra_binds)
+ ddump_deriving :: [InstInfo Name] -> HsValBinds Name
+ -> [MetaTyCons] -- ^ Empty data constructors
+ -> [TyCon] -- ^ Rep type family instances
+ -> [[(InstInfo RdrName, DerivAuxBinds)]]
+ -- ^ Instances for the repMetaTys
+ -> SDoc
+ ddump_deriving inst_infos extra_binds repMetaTys repTyCons metaInsts
+ = hang (ptext (sLit "Derived instances"))
+ 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
+ $$ ppr extra_binds)
+ $$ hangP "Generic representation" (
+ hangP "Generated datatypes for meta-information"
+ (vcat (map ppr repMetaTys))
+ -- The Outputable instance for TyCon unfortunately only prints the name...
+ $$ hangP "Representation types"
+ (vcat (map ppr repTyCons))
+ $$ hangP "Meta-information instances"
+ (vcat (map (pprInstInfoDetails . fst) (concat metaInsts))))
+
+ hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
+
renameDeriv :: Bool -> LHsBinds RdrName
-> [(InstInfo RdrName, DerivAuxBinds)]
-- scope (yuk), and rename the method binds
ASSERT( null sigs )
bindLocalNames (map Var.varName tyvars) $
- do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
+ do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) binds
; let binds' = VanillaInst rn_binds [] standalone_deriv
; return (inst_info { iBinds = binds' }, fvs) }
where
(tyvars,_, clas,_) = instanceHead inst
clas_nm = className clas
-
------------------------------------------
-mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
-mkGenericBinds is_boot tycl_decls
- | is_boot
- = return emptyBag
- | otherwise
- = do { tcs <- mapM tcLookupTyCon [ tcdName d
- | L _ d <- tycl_decls, isDataDecl d ]
- ; return (unionManyBags [ mkTyConGenericBinds tc
- | tc <- tcs, tyConHasGenerics tc ]) }
- -- We are only interested in the data type declarations,
- -- and then only in the ones whose 'has-generics' flag is on
- -- The predicate tyConHasGenerics finds both of these
\end{code}
Note [Newtype deriving and unused constructors]
@makeDerivSpecs@ fishes around to find the info about needed derived instances.
\begin{code}
+-- Make the "extras" for the generic representation
+mkGenDerivExtras :: TyCon
+ -> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])
+mkGenDerivExtras tc = do
+ { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc
+ ; metaInsts <- genDtMeta (tc, metaTyCons)
+ ; return (metaTyCons, rep0TyInst, metaInsts) }
+
makeDerivSpecs :: Bool
-> [LTyClDecl Name]
- -> [LInstDecl Name]
+ -> [LInstDecl Name]
-> [LDerivDecl Name]
- -> TcM [EarlyDerivSpec]
-
+ -> TcM ( [EarlyDerivSpec]
+ , [(MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])])
makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
- | is_boot -- No 'deriving' at all in hs-boot files
- = do { mapM_ add_deriv_err deriv_locs
- ; return [] }
+ | is_boot -- No 'deriving' at all in hs-boot files
+ = do { mapM_ add_deriv_err deriv_locs
+ ; return ([],[]) }
| otherwise
- = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
- ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
- ; return (eqns1 ++ eqns2) }
+ = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata
+ ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
+
+ -- Generic representation stuff: we might need to add some "extras"
+ -- to the instances
+ ; xDerRep <- getDOpts >>= return . xopt Opt_DeriveGeneric
+ ; generic_extras_deriv <- if not xDerRep
+ -- No extras if the flag is off
+ then (return [])
+ else do {
+ let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ]
+ -- Select only those types that derive Generic
+ ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata
+ , getClassName c == Just genClassName ]
+ ; let sel_deriv_decls = catMaybes [ getTypeName t
+ | L _ (DerivDecl (L _ t)) <- deriv_decls
+ , getClassName t == Just genClassName ]
+ ; derTyDecls <- mapM tcLookupTyCon $
+ filter (needsExtras xDerRep
+ (sel_tydata ++ sel_deriv_decls)) allTyNames
+ -- We need to generate the extras to add to what has
+ -- already been derived
+ ; {- pprTrace "sel_tydata" (ppr sel_tydata) $
+ pprTrace "sel_deriv_decls" (ppr sel_deriv_decls) $
+ pprTrace "derTyDecls" (ppr derTyDecls) $
+ pprTrace "deriv_decls" (ppr deriv_decls) $ -}
+ mapM mkGenDerivExtras derTyDecls }
+
+ -- Merge and return
+ ; return ( eqns1 ++ eqns2, generic_extras_deriv) }
where
+ -- We need extras if the flag DeriveGeneric is on and this type is
+ -- deriving Generic
+ needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata
+
+ -- Extracts the name of the class in the deriving
+ getClassName :: HsType Name -> Maybe Name
+ getClassName (HsForAllTy _ _ _ (L _ n)) = getClassName n
+ getClassName (HsPredTy (HsClassP n _)) = Just n
+ getClassName _ = Nothing
+
+ -- Extracts the name of the type in the deriving
+ -- This function (and also getClassName above) is not really nice, and I
+ -- might not have covered all possible cases. I wonder if there is no easier
+ -- way to extract class and type name from a LDerivDecl...
+ getTypeName :: HsType Name -> Maybe Name
+ getTypeName (HsForAllTy _ _ _ (L _ n)) = getTypeName n
+ getTypeName (HsTyVar n) = Just n
+ getTypeName (HsOpTy _ (L _ n) _) = Just n
+ getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n
+ getTypeName (HsAppTy (L _ n) _) = getTypeName n
+ getTypeName (HsParTy (L _ n)) = getTypeName n
+ getTypeName (HsKindSig (L _ n) _) = getTypeName n
+ getTypeName _ = Nothing
+
extractTyDataPreds decls
= [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
all_tydata :: [(LHsType Name, LTyClDecl Name)]
- -- Derived predicate paired with its data type declaration
+ -- Derived predicate paired with its data type declaration
all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls)
deriv_locs = map (getLoc . snd) all_tydata
- ++ map getLoc deriv_decls
+ ++ map getLoc deriv_decls
add_deriv_err loc = setSrcSpan loc $
- addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
- 2 (ptext (sLit "Use an instance declaration instead")))
+ addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
+ 2 (ptext (sLit "Use an instance declaration instead")))
------------------------------------------------------------------
deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
-- generated method definitions should succeed. This set will be simplified
-- before being used in the instance declaration
inferConstraints _ cls inst_tys rep_tc rep_tc_args
+ -- Generic constraints are easy
+ | cls `hasKey` genClassKey
+ = []
+ -- The others are a bit more complicated
+ | otherwise
= ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
stupid_constraints ++ extra_constraints
++ sc_constraints ++ con_arg_constraints
cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
| cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
cond_functorOK False)
+ | cls_key == genClassKey = Just (cond_RepresentableOk `andCond`
+ checkFlag Opt_DeriveGeneric)
| otherwise = Nothing
where
cls_key = getUnique cls
Nothing -> Nothing -- c1 succeeds
Just x -> case c2 tc of -- c1 fails
Nothing -> Nothing
- Just y -> Just (x $$ ptext (sLit " and") $$ y)
+ Just y -> Just (x $$ ptext (sLit " or") $$ y)
-- Both fail
andCond :: Condition -> Condition -> Condition
check_con con
| isVanillaDataCon con
, all isTauTy (dataConOrigArgTys con) = Nothing
- | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type")))
+ | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type")))
no_cons_why :: TyCon -> SDoc
no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
- ptext (sLit "has no data constructors")
+ ptext (sLit "must have at least one data constructor")
+
+cond_RepresentableOk :: Condition
+cond_RepresentableOk (_,t) = canDoGenerics t
cond_enumOrProduct :: Condition
cond_enumOrProduct = cond_isEnumeration `orCond`
where
bad_cons = [ con | con <- tyConDataCons tc
, any isUnLiftedType (dataConOrigArgTys con) ]
- why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type"))
+ why = badCon (head bad_cons) (ptext (sLit "must have only arguments of lifted type"))
cond_isEnumeration :: Condition
cond_isEnumeration (_, rep_tc)
| otherwise = Just why
where
why = sep [ quotes (pprSourceTyCon rep_tc) <+>
- ptext (sLit "is not an enumeration type")
+ ptext (sLit "must be an enumeration type")
, ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ]
-- See Note [Enumeration types] in TyCon
| otherwise = Just why
where
why = quotes (pprSourceTyCon rep_tc) <+>
- ptext (sLit "does not have precisely one constructor")
+ ptext (sLit "must have precisely one constructor")
cond_typeableOK :: Condition
-- OK for Typeable class
| otherwise = Nothing
where
too_many = quotes (pprSourceTyCon tc) <+>
- ptext (sLit "has too many arguments")
+ ptext (sLit "must have 7 or fewer arguments")
bad_kind = quotes (pprSourceTyCon tc) <+>
- ptext (sLit "has arguments of kind other than `*'")
+ ptext (sLit "must only have arguments of kind `*'")
functorLikeClassKeys :: [Unique]
functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
cond_functorOK allowFunctions (_, rep_tc)
| null tc_tvs
= Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
- <+> ptext (sLit "has no parameters"))
+ <+> ptext (sLit "must have some type parameters"))
| not (null bad_stupid_theta)
= Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
- <+> ptext (sLit "has a class context") <+> pprTheta bad_stupid_theta)
+ <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta)
| otherwise
= msum (map check_con data_cons) -- msum picks the first 'Just', if any
, ft_bad_app = Just (badCon con wrong_arg)
, ft_forall = \_ x -> x }
- existential = ptext (sLit "has existential arguments")
- covariant = ptext (sLit "uses the type variable in a function argument")
- functions = ptext (sLit "contains function types")
- wrong_arg = ptext (sLit "uses the type variable in an argument other than the last")
+ existential = ptext (sLit "must not have existential arguments")
+ covariant = ptext (sLit "must not use the type variable in a function argument")
+ functions = ptext (sLit "must not contain function types")
+ wrong_arg = ptext (sLit "must not use the type variable in an argument other than the last")
checkFlag :: ExtensionFlag -> Condition
checkFlag flag (dflags, _)
non_iso_class :: Class -> Bool
--- *Never* derive Read,Show,Typeable,Data by isomorphism,
+-- *Never* derive Read, Show, Typeable, Data, Generic by isomorphism,
-- even with -XGeneralizedNewtypeDeriving
non_iso_class cls
- = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++
- typeableClassKeys)
+ = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
+ , genClassKey] ++ typeableClassKeys)
typeableClassKeys :: [Unique]
typeableClassKeys = map getUnique typeableClassNames
; let tv_set = mkVarSet tyvars
weird_preds = [pred | pred <- deriv_rhs
- , not (tyVarsOfPred pred `subVarSet` tv_set)]
+ , not (tyVarsOfPred pred `subVarSet` tv_set)]
; mapM_ (addErrTc . badDerivedPred) weird_preds
; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
where
inst_spec = mkInstance oflag theta spec
co1 = case tyConFamilyCoercion_maybe rep_tycon of
- Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
+ Just co_con -> mkAxInstCo co_con rep_tc_args
Nothing -> id_co
-- Not a family => rep_tycon = main tycon
- co2 = case newTyConCo_maybe rep_tycon of
- Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
- Nothing -> id_co -- The newtype is transparent; no need for a cast
- co = co1 `mkTransCoI` co2
- id_co = IdCo (mkTyConApp rep_tycon rep_tc_args)
+ co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args
+ co = co1 `mkTransCo` co2
+ id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args)
-- Example: newtype instance N [a] = N1 (Tree a)
-- deriving instance Eq b => Eq (N [(b,b)])
Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
where
gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
- gen_list = [(eqClassKey, gen_Eq_binds)
- ,(ordClassKey, gen_Ord_binds)
- ,(enumClassKey, gen_Enum_binds)
- ,(boundedClassKey, gen_Bounded_binds)
- ,(ixClassKey, gen_Ix_binds)
- ,(showClassKey, gen_Show_binds fix_env)
- ,(readClassKey, gen_Read_binds fix_env)
- ,(dataClassKey, gen_Data_binds)
- ,(functorClassKey, gen_Functor_binds)
- ,(foldableClassKey, gen_Foldable_binds)
- ,(traversableClassKey, gen_Traversable_binds)
+ gen_list = [(eqClassKey, gen_Eq_binds)
+ ,(ordClassKey, gen_Ord_binds)
+ ,(enumClassKey, gen_Enum_binds)
+ ,(boundedClassKey, gen_Bounded_binds)
+ ,(ixClassKey, gen_Ix_binds)
+ ,(showClassKey, gen_Show_binds fix_env)
+ ,(readClassKey, gen_Read_binds fix_env)
+ ,(dataClassKey, gen_Data_binds)
+ ,(functorClassKey, gen_Functor_binds)
+ ,(foldableClassKey, gen_Foldable_binds)
+ ,(traversableClassKey, gen_Traversable_binds)
+ ,(genClassKey, genGenericBinds)
]
\end{code}
+%************************************************************************
+%* *
+\subsection[TcDeriv-generic-binds]{Bindings for the new generic deriving mechanism}
+%* *
+%************************************************************************
+
+For the generic representation we need to generate:
+\begin{itemize}
+\item A Generic instance
+\item A Rep type instance
+\item Many auxiliary datatypes and instances for them (for the meta-information)
+\end{itemize}
+
+@genGenericBinds@ does (1)
+@genGenericRepExtras@ does (2) and (3)
+@genGenericAll@ does all of them
+
+\begin{code}
+genGenericBinds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+genGenericBinds _ tc = (mkBindsRep tc, [ {- No DerivAuxBinds -} ])
+
+genGenericRepExtras :: TyCon -> TcM (MetaTyCons, TyCon)
+genGenericRepExtras tc =
+ do uniqS <- newUniqueSupply
+ let
+ -- Uniques for everyone
+ (uniqD:uniqs) = uniqsFromSupply uniqS
+ (uniqsC,us) = splitAt (length tc_cons) uniqs
+ uniqsS :: [[Unique]] -- Unique supply for the S datatypes
+ uniqsS = mkUniqsS tc_arits us
+ mkUniqsS [] _ = []
+ mkUniqsS (n:t) us = case splitAt n us of
+ (us1,us2) -> us1 : mkUniqsS t us2
+
+ tc_name = tyConName tc
+ tc_cons = tyConDataCons tc
+ tc_arits = map dataConSourceArity tc_cons
+
+ tc_occ = nameOccName tc_name
+ d_occ = mkGenD tc_occ
+ c_occ m = mkGenC tc_occ m
+ s_occ m n = mkGenS tc_occ m n
+ mod_name = nameModule (tyConName tc)
+ d_name = mkExternalName uniqD mod_name d_occ wiredInSrcSpan
+ c_names = [ mkExternalName u mod_name (c_occ m) wiredInSrcSpan
+ | (u,m) <- zip uniqsC [0..] ]
+ s_names = [ [ mkExternalName u mod_name (s_occ m n) wiredInSrcSpan
+ | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ]
+
+ mkTyCon name = ASSERT( isExternalName name )
+ buildAlgTyCon name [] [] mkAbstractTyConRhs
+ NonRecursive False NoParentTyCon Nothing
+
+ metaDTyCon <- mkTyCon d_name
+ metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ]
+ metaSTyCons <- mapM sequence
+ [ [ mkTyCon s_name
+ | s_name <- s_namesC ] | s_namesC <- s_names ]
+
+ let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
+
+ rep0_tycon <- tc_mkRepTyCon tc metaDts
+
+ -- pprTrace "rep0" (ppr rep0_tycon) $
+ return (metaDts, rep0_tycon)
+{-
+genGenericAll :: TyCon
+ -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon)
+genGenericAll tc =
+ do (metaDts, rep0_tycon) <- genGenericRepExtras tc
+ clas <- tcLookupClass genClassName
+ dfun_name <- new_dfun_name clas tc
+ let
+ mkInstRep = (InstInfo { iSpec = inst, iBinds = binds }
+ , [ {- No DerivAuxBinds -} ])
+ inst = mkLocalInstance dfun NoOverlap
+ binds = VanillaInst (mkBindsRep tc) [] False
+
+ tvs = tyConTyVars tc
+ tc_ty = mkTyConApp tc (mkTyVarTys tvs)
+
+ dfun = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty]
+ return (mkInstRep, metaDts, rep0_tycon)
+-}
+genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)]
+genDtMeta (tc,metaDts) =
+ do dClas <- tcLookupClass datatypeClassName
+ d_dfun_name <- new_dfun_name dClas tc
+ cClas <- tcLookupClass constructorClassName
+ c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
+ sClas <- tcLookupClass selectorClassName
+ s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc
+ | _ <- x ]
+ | x <- metaS metaDts ])
+ fix_env <- getFixityEnv
+
+ let
+ (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
+
+ -- Datatype
+ d_metaTycon = metaD metaDts
+ d_inst = mkLocalInstance d_dfun NoOverlap
+ d_binds = VanillaInst dBinds [] False
+ d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas
+ [ mkTyConTy d_metaTycon ]
+ d_mkInst = (InstInfo { iSpec = d_inst, iBinds = d_binds }, [])
+
+ -- Constructor
+ c_metaTycons = metaC metaDts
+ c_insts = [ mkLocalInstance (c_dfun c ds) NoOverlap
+ | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
+ c_binds = [ VanillaInst c [] False | c <- cBinds ]
+ c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas
+ [ mkTyConTy c ]
+ c_mkInst = [ (InstInfo { iSpec = is, iBinds = bs }, [])
+ | (is,bs) <- myZip1 c_insts c_binds ]
+
+ -- Selector
+ s_metaTycons = metaS metaDts
+ s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) NoOverlap))
+ (myZip2 s_metaTycons s_dfun_names)
+ s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ]
+ s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas
+ [ mkTyConTy s ]
+ s_mkInst = map (map (\(is,bs) -> (InstInfo {iSpec=is, iBinds=bs}, [])))
+ (myZip2 s_insts s_binds)
+
+ myZip1 :: [a] -> [b] -> [(a,b)]
+ myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2
+
+ myZip2 :: [[a]] -> [[b]] -> [[(a,b)]]
+ myZip2 l1 l2 =
+ ASSERT (and (zipWith (>=) (map length l1) (map length l2)))
+ [ zip x1 x2 | (x1,x2) <- zip l1 l2 ]
+
+ return (d_mkInst : c_mkInst ++ concat s_mkInst)
+\end{code}
+
%************************************************************************
%* *
}
tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
--- Find the instance of a data famliy
+-- Find the instance of a data family
-- Note [Looking up family instances for deriving]
tcLookupDataFamInst tycon tys
| not (isFamilyTyCon tycon)
\begin{code}
tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
-- Just pop the new rules into the EPS and envt resp
- -- All the rules come from an interface file, not soruce
+ -- All the rules come from an interface file, not source
-- Nevertheless, some may be for this module, if we read
-- its interface instead of its source code
tcExtendRules lcl_rules thing_inside
-- witness dictionary is identical to the argument
-- dictionary. Hence no bindings, no pragmas.
- CoercionI -- The coercion maps from newtype to the representation type
+ Coercion -- The coercion maps from newtype to the representation type
-- (mentioning type variables bound by the forall'd iSpec variables)
-- E.g. newtype instance N [a] = N1 (Tree a)
-- co : N [a] ~ Tree a
pprInstInfo :: InstInfo a -> SDoc
pprInstInfo info = hang (ptext (sLit "instance"))
2 (sep [ ifPprDebug (pprForAll tvs)
- , pprThetaArrow theta, ppr tau
+ , pprThetaArrowTy theta, ppr tau
, ptext (sLit "where")])
where
(tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info))
\end{code}
Make a name for the representation tycon of a family instance. It's an
-*external* name, like otber top-level names, and hence must be made with
+*external* name, like other top-level names, and hence must be made with
newGlobalBinder.
\begin{code}
import TcType
import TypeRep
import Type( isTyVarTy )
-
+import Unify ( tcMatchTys )
import Inst
import InstEnv
-
import TyCon
import Name
import NameEnv
-import Id ( idType )
+import Id ( idType, evVarPred )
import Var
import VarSet
import VarEnv
-- because they are unconditionally wrong
-- Moreover, if any of the insolubles are givens, stop right there
-- ignoring nested errors, because the code is inaccessible
- = do { let (given, other) = partitionBag (isGiven . evVarX) insols
+ = do { let (given, other) = partitionBag (isGivenOrSolved . evVarX) insols
insol_implics = filterBag ic_insol implics
; if isEmptyBag given
then do { mapBagM_ (reportInsoluble ctxt) other
| otherwise
= pprPanic "reportInsoluble" (pprEvVarWithType ev)
where
- inaccessible_msg | Given loc <- flav
+ inaccessible_msg | Given loc GivenOrig <- flav
+ -- If a GivenSolved then we should not report inaccessible code
= hang (ptext (sLit "Inaccessible code in"))
2 (ppr (ctLocOrigin loc))
| otherwise = empty
where
first_loc = evVarX (head ev_vars)
ppr_one (EvVarX v loc)
- = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
+ = parens (pprPredTy (evVarPred v)) <+> pprArisingAt loc
addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
ty1 ty2
-- If the types in the error message are the same as the types we are unifying,
-- don't add the extra expected/actual message
- | act `tcEqType` ty1 && exp `tcEqType` ty2 = empty
- | exp `tcEqType` ty1 && act `tcEqType` ty2 = empty
+ | act `eqType` ty1 && exp `eqType` ty2 = empty
+ | exp `eqType` ty1 && act `eqType` ty2 = empty
| otherwise = mkExpectedActualMsg act exp
getWantedEqExtra orig _ _ = pprArising orig
couldNotDeduce givens (wanteds, orig)
= vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
2 (pprArising orig)
- , vcat pp_givens ]
- where
- pp_givens
- = case givens of
+ , vcat (pp_givens givens)]
+
+pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
+pp_givens givens
+ = case givens of
[] -> []
(g:gs) -> ppr_given (ptext (sLit "from the context")) g
: map (ppr_given (ptext (sLit "or from"))) gs
-
- ppr_given herald (gs,loc)
- = hang (herald <+> pprEvVarTheta gs)
- 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
- , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
+ where ppr_given herald (gs,loc)
+ = hang (herald <+> pprEvVarTheta gs)
+ 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
+ , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
-- Add on extra info about the types themselves
mk_overlap_msg (matches, unifiers)
= ASSERT( not (null matches) )
vcat [ addArising orig (ptext (sLit "Overlapping instances for")
- <+> pprPred pred)
+ <+> pprPredTy pred)
, sep [ptext (sLit "Matching instances") <> colon,
nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
+
+ , if not (null overlapping_givens) then
+ sep [ptext (sLit "Matching givens (or their superclasses)") <> colon, nest 2 (vcat overlapping_givens)]
+ else empty
+
+ , if null overlapping_givens && isSingleton matches && null unifiers then
+ -- Intuitively, some given matched the wanted in their flattened or rewritten (from given equalities)
+ -- form but the matcher can't figure that out because the constraints are non-flat and non-rewritten
+ -- so we simply report back the whole given context. Accelerate Smart.hs showed this problem.
+ sep [ptext (sLit "There exists a (perhaps superclass) match") <> colon, nest 2 (vcat (pp_givens givens))]
+ else empty
+
, if not (isSingleton matches)
then -- Two or more matches
empty
ASSERT( not (null unifiers) )
parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
- ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
- ptext (sLit "when compiling the other instance declarations")])]
+ if null (overlapping_givens) then
+ vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
+ ptext (sLit "when compiling the other instance declarations")]
+ else empty])]
where
ispecs = [ispec | (ispec, _) <- matches]
+ givens = getUserGivens ctxt
+ overlapping_givens = unifiable_givens givens
+
+ unifiable_givens [] = []
+ unifiable_givens (gg:ggs)
+ | Just ggdoc <- matchable gg
+ = ggdoc : unifiable_givens ggs
+ | otherwise
+ = unifiable_givens ggs
+
+ matchable (evvars,gloc)
+ = case ev_vars_matching of
+ [] -> Nothing
+ _ -> Just $ hang (pprTheta ev_vars_matching)
+ 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
+ , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
+ where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
+ ev_var_matches (ClassP clas' tys')
+ | clas' == clas
+ , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
+ = True
+ ev_var_matches (ClassP clas' tys') =
+ any ev_var_matches (immSuperClasses clas' tys')
+ ev_var_matches _ = False
+
+
reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP
----------------------
\begin{code}
setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
-setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Given loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing
\end{code}
%************************************************************************
import Coercion
import Var
import VarSet
+import VarEnv
import TysWiredIn
import TysPrim( intPrimTy )
import PrimOp( tagToEnumKey )
import Util
import ListSetOps
import Maybes
+import ErrUtils
import Outputable
import FastString
import Control.Monad
; co_res <- unifyType op_res_ty res_ty
; op_id <- tcLookupId op_name
; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id))
- ; return $ mkHsWrapCoI co_res $
- OpApp (mkLHsWrapCoI co_arg1 arg1') op' fix arg2' }
+ ; return $ mkHsWrapCo co_res $
+ OpApp (mkLHsWrapCo co_arg1 arg1') op' fix arg2' }
| otherwise
= do { traceTc "Non Application rule" (ppr op)
; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty
; co_res <- unifyType op_res_ty res_ty
; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys
- ; return $ mkHsWrapCoI co_res $
- OpApp arg1' (mkLHsWrapCoI co_fn op') fix arg2' }
+ ; return $ mkHsWrapCo co_res $
+ OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' }
-- Right sections, equivalent to \ x -> x `op` expr, or
-- \ x -> op x expr
; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty
; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty
; arg2' <- tcArg op (arg2, arg2_ty, 2)
- ; return $ mkHsWrapCoI co_res $
- SectionR (mkLHsWrapCoI co_fn op') arg2' }
+ ; return $ mkHsWrapCo co_res $
+ SectionR (mkLHsWrapCo co_fn op') arg2' }
tcExpr (SectionL arg1 op) res_ty
= do { (op', op_ty) <- tcInferFun op
; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty
; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty
; arg1' <- tcArg op (arg1, arg1_ty, 1)
- ; return $ mkHsWrapCoI co_res $
- SectionL arg1' (mkLHsWrapCoI co_fn op') }
+ ; return $ mkHsWrapCo co_res $
+ SectionL arg1' (mkLHsWrapCo co_fn op') }
tcExpr (ExplicitTuple tup_args boxity) res_ty
| all tupArgPresent tup_args
= do { let tup_tc = tupleTyCon boxity (length tup_args)
; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
; tup_args1 <- tcTupArgs tup_args arg_tys
- ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
+ ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
| otherwise
= -- The tup_args are a mixture of Present and Missing (for tuple sections)
-- Handle tuple sections where
; tup_args1 <- tcTupArgs tup_args arg_tys
- ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
+ ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
tcExpr (ExplicitList _ exprs) res_ty
= do { (coi, elt_ty) <- matchExpectedListTy res_ty
; exprs' <- mapM (tc_elt elt_ty) exprs
- ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
+ ; return $ mkHsWrapCo coi (ExplicitList elt_ty exprs') }
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty
= do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
; exprs' <- mapM (tc_elt elt_ty) exprs
- ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
+ ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') }
where
tc_elt elt_ty expr = tcPolyExpr expr elt_ty
\end{code}
-- and it maintains uniformity with other rebindable syntax
; return (HsIf (Just fun') pred' b1' b2') }
-tcExpr (HsDo do_or_lc stmts body _) res_ty
- = tcDoStmts do_or_lc stmts body res_ty
+tcExpr (HsDo do_or_lc stmts _) res_ty
+ = tcDoStmts do_or_lc stmts res_ty
tcExpr (HsProc pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty
- ; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
+ ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
tcExpr e@(HsArrApp _ _ _ _ _) _
= failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e),
; co_res <- unifyType actual_res_ty res_ty
; rbinds' <- tcRecordBinds data_con arg_tys rbinds
- ; return $ mkHsWrapCoI co_res $
+ ; return $ mkHsWrapCo co_res $
RecordCon (L loc con_id) con_expr rbinds' }
\end{code}
-- Take apart a representative constructor
con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
- (con1_tvs, _, _, _, _, con1_arg_tys, _) = dataConFullSig con1
+ (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1
con1_flds = dataConFieldLabels con1
con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
- ; let rec_res_ty = substTy result_inst_env con1_res_ty
- con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
+ ; let rec_res_ty = TcType.substTy result_inst_env con1_res_ty
+ con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys
scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys
- scrut_ty = substTy scrut_subst con1_res_ty
+ scrut_ty = TcType.substTy scrut_subst con1_res_ty
; co_res <- unifyType rec_res_ty res_ty
-- Step 7: make a cast for the scrutinee, in the case that it's from a type family
; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
- = WpCast $ mkTyConApp co_con scrut_inst_tys
+ = WpCast $ mkAxInstCo co_con scrut_inst_tys
| otherwise
= idHsWrapper
-- Phew!
- ; return $ mkHsWrapCoI co_res $
+ ; return $ mkHsWrapCo co_res $
RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
relevant_cons scrut_inst_tys result_inst_tys }
where
; expr' <- tcPolyExpr expr elt_ty
; enum_from <- newMethodFromName (ArithSeqOrigin seq)
enumFromName elt_ty
- ; return $ mkHsWrapCoI coi (ArithSeq enum_from (From expr')) }
+ ; return $ mkHsWrapCo coi (ArithSeq enum_from (From expr')) }
tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
= do { (coi, elt_ty) <- matchExpectedListTy res_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenName elt_ty
- ; return $ mkHsWrapCoI coi
+ ; return $ mkHsWrapCo coi
(ArithSeq enum_from_then (FromThen expr1' expr2')) }
tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
enumFromToName elt_ty
- ; return $ mkHsWrapCoI coi
+ ; return $ mkHsWrapCo coi
(ArithSeq enum_from_to (FromTo expr1' expr2')) }
tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (ArithSeqOrigin seq)
enumFromThenToName elt_ty
- ; return $ mkHsWrapCoI coi
+ ; return $ mkHsWrapCo coi
(ArithSeq eft (FromThenTo expr1' expr2' expr3')) }
tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
; expr2' <- tcPolyExpr expr2 elt_ty
; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
(enumFromToPName basePackageId) elt_ty -- !!!FIXME: chak
- ; return $ mkHsWrapCoI coi
+ ; return $ mkHsWrapCo coi
(PArrSeq enum_from_to (FromTo expr1' expr2')) }
tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
; expr3' <- tcPolyExpr expr3 elt_ty
; eft <- newMethodFromName (PArrSeqOrigin seq)
(enumFromThenToPName basePackageId) elt_ty -- !!!FIXME: chak
- ; return $ mkHsWrapCoI coi
+ ; return $ mkHsWrapCo coi
(PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
tcExpr (PArrSeq _ _) _
-- Typecheck the result, thereby propagating
-- info (if any) from result into the argument types
-- Both actual_res_ty and res_ty are deeply skolemised
- ; co_res <- addErrCtxt (funResCtxt fun) $
+ ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $
unifyType actual_res_ty res_ty
-- Typecheck the arguments
; args1 <- tcArgs fun args expected_arg_tys
-- Assemble the result
- ; let fun2 = mkLHsWrapCoI co_fun fun1
- app = mkLHsWrapCoI co_res (foldl mkHsApp fun2 args1)
+ ; let fun2 = mkLHsWrapCo co_fun fun1
+ app = mkLHsWrapCo co_res (foldl mkHsApp fun2 args1)
; return (unLoc app) }
; (co_fun, expected_arg_tys, actual_res_ty)
<- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
; args1 <- tcArgs fun args expected_arg_tys
- ; let fun2 = mkLHsWrapCoI co_fun fun1
+ ; let fun2 = mkLHsWrapCo co_fun fun1
app = foldl mkHsApp fun2 args1
; return (unLoc app, actual_res_ty) }
----------------
unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType
- -> TcM (CoercionI, [TcSigmaType], TcRhoType)
+ -> TcM (Coercion, [TcSigmaType], TcRhoType)
-- A wrapper for matchExpectedFunTys
unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty
where
; let theta' = substTheta subst theta
; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta'))
; wrap <- instCall orig tys theta'
- ; return (mkHsWrap wrap (HsVar id), substTy subst tau) }
+ ; return (mkHsWrap wrap (HsVar id), TcType.substTy subst tau) }
where
(tvs, theta, tau) = tcSplitSigmaTy (idType id)
\end{code}
; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
rep_ty = mkTyConApp rep_tc rep_args
- ; return (mkHsWrapCoI coi $ HsApp fun' arg') }
+ ; return (mkHsWrapCo coi $ HsApp fun' arg') }
where
doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
, ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
doc3 = ptext (sLit "No family instance for this type")
get_rep_ty :: TcType -> TyCon -> [TcType]
- -> TcM (CoercionI, TyCon, [TcType])
+ -> TcM (Coercion, TyCon, [TcType])
-- Converts a family type (eg F [a]) to its rep type (eg FList a)
-- and returns a coercion between the two
get_rep_ty ty tc tc_args
| not (isFamilyTyCon tc)
- = return (IdCo ty, tc, tc_args)
+ = return (mkReflCo ty, tc, tc_args)
| otherwise
= do { mb_fam <- tcLookupFamInst tc tc_args
; case mb_fam of
Nothing -> failWithTc (tagToEnumError ty doc3)
Just (rep_tc, rep_args)
- -> return ( ACo (mkSymCoercion (mkTyConApp co_tc rep_args))
+ -> return ( mkSymCo (mkAxInstCo co_tc rep_args)
, rep_tc, rep_args )
where
co_tc = expectJust "tcTagToEnum" $
quotes (ppr fun) <> text ", namely"])
2 (quotes (ppr arg))
-funResCtxt :: LHsExpr Name -> SDoc
-funResCtxt fun
- = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun)
+funResCtxt :: LHsExpr Name -> TcType -> TcType
+ -> TidyEnv -> TcM (TidyEnv, Message)
+-- When we have a mis-match in the return type of a function
+-- try to give a helpful message about too many/few arguments
+funResCtxt fun fun_res_ty res_ty env0
+ = do { fun_res' <- zonkTcType fun_res_ty
+ ; res' <- zonkTcType res_ty
+ ; let n_fun = length (fst (tcSplitFunTys fun_res'))
+ n_res = length (fst (tcSplitFunTys res'))
+ what | n_fun > n_res = ptext (sLit "few")
+ | otherwise = ptext (sLit "many")
+ extra | n_fun == n_res = empty
+ | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
+ <+> ptext (sLit "is applied to too") <+> what
+ <+> ptext (sLit "arguments")
+ msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun)
+ ; return (env0, msg $$ extra) }
badFieldTypes :: [(Name,TcType)] -> SDoc
badFieldTypes prs
module checks to see if a foreign declaration has got a legal type.
\begin{code}
-module TcForeign
- (
- tcForeignImports
+module TcForeign
+ (
+ tcForeignImports
, tcForeignExports
- ) where
+ ) where
#include "HsVersions.h"
-- Defines a binding
isForeignImport :: LForeignDecl name -> Bool
isForeignImport (L _ (ForeignImport _ _ _)) = True
-isForeignImport _ = False
+isForeignImport _ = False
-- Exports a binding
isForeignExport :: LForeignDecl name -> Bool
isForeignExport (L _ (ForeignExport _ _ _)) = True
-isForeignExport _ = False
+isForeignExport _ = False
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Imports}
-%* *
+%* *
%************************************************************************
\begin{code}
tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
- = addErrCtxt (foreignDeclCtxt fo) $
- do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
- ; let
- -- Drop the foralls before inspecting the
- -- structure of the foreign type.
- (_, t_ty) = tcSplitForAllTys sig_ty
- (arg_tys, res_ty) = tcSplitFunTys t_ty
- id = mkLocalId nm sig_ty
- -- Use a LocalId to obey the invariant that locally-defined
- -- things are LocalIds. However, it does not need zonking,
- -- (so TcHsSyn.zonkForeignExports ignores it).
-
- ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
- -- Can't use sig_ty here because sig_ty :: Type and
- -- we need HsType Id hence the undefined
- ; return (id, ForeignImport (L loc id) undefined imp_decl') }
+ = addErrCtxt (foreignDeclCtxt fo) $
+ do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+ ; let
+ -- Drop the foralls before inspecting the
+ -- structure of the foreign type.
+ (_, t_ty) = tcSplitForAllTys sig_ty
+ (arg_tys, res_ty) = tcSplitFunTys t_ty
+ id = mkLocalId nm sig_ty
+ -- Use a LocalId to obey the invariant that locally-defined
+ -- things are LocalIds. However, it does not need zonking,
+ -- (so TcHsSyn.zonkForeignExports ignores it).
+
+ ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
+ -- Can't use sig_ty here because sig_ty :: Type and
+ -- we need HsType Id hence the undefined
+ ; return (id, ForeignImport (L loc id) undefined imp_decl') }
tcFImport d = pprPanic "tcFImport" (ppr d)
\end{code}
do { checkCg checkCOrAsmOrLlvmOrInterp
; checkSafety safety
; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
- ; return idecl } -- NB check res_ty not sig_ty!
- -- In case sig_ty is (forall a. ForeignPtr a)
+ ; return idecl } -- NB check res_ty not sig_ty!
+ -- In case sig_ty is (forall a. ForeignPtr a)
tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do
- -- Foreign wrapper (former f.e.d.)
- -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
- -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
- -- as ft -> IO Addr is accepted, too. The use of the latter two forms
- -- is DEPRECATED, though.
+ -- Foreign wrapper (former f.e.d.)
+ -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
+ -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well
+ -- as ft -> IO Addr is accepted, too. The use of the latter two forms
+ -- is DEPRECATED, though.
checkCg checkCOrAsmOrLlvmOrInterp
checkCConv cconv
checkSafety safety
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Exports}
-%* *
+%* *
%************************************************************************
\begin{code}
-tcForeignExports :: [LForeignDecl Name]
- -> TcM (LHsBinds TcId, [LForeignDecl TcId])
+tcForeignExports :: [LForeignDecl Name]
+ -> TcM (LHsBinds TcId, [LForeignDecl TcId])
tcForeignExports decls
= foldlM combine (emptyLHsBinds, []) (filter isForeignExport decls)
where
return (b `consBag` binds, f:fs)
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
-tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
- addErrCtxt (foreignDeclCtxt fo) $ do
+tcFExport fo@(ForeignExport (L loc nm) hs_ty spec)
+ = addErrCtxt (foreignDeclCtxt fo) $ do
- sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
- rhs <- tcPolyExpr (nlHsVar nm) sig_ty
+ sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+ rhs <- tcPolyExpr (nlHsVar nm) sig_ty
- tcCheckFEType sig_ty spec
+ tcCheckFEType sig_ty spec
- -- we're exporting a function, but at a type possibly more
- -- constrained than its declared/inferred type. Hence the need
- -- to create a local binding which will call the exported function
- -- at a particular type (and, maybe, overloading).
+ -- we're exporting a function, but at a type possibly more
+ -- constrained than its declared/inferred type. Hence the need
+ -- to create a local binding which will call the exported function
+ -- at a particular type (and, maybe, overloading).
- -- We need to give a name to the new top-level binding that
- -- is *stable* (i.e. the compiler won't change it later),
- -- because this name will be referred to by the C code stub.
- id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
- return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
+ -- We need to give a name to the new top-level binding that
+ -- is *stable* (i.e. the compiler won't change it later),
+ -- because this name will be referred to by the C code stub.
+ id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
+ return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
tcFExport d = pprPanic "tcFExport" (ppr d)
\end{code}
%************************************************************************
-%* *
+%* *
\subsection{Miscellaneous}
-%* *
+%* *
%************************************************************************
\begin{code}
go ty = check (pred ty) (illegalForeignTyErr argument ty)
------------ Checking result types for foreign calls ----------------------
--- Check that the type has the form
+-- Check that the type has the form
-- (IO t) or (t) , and that t satisfies the given predicate.
--
checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
mustBeIO = False
checkForeignRes non_io_result_ok pred_res_ty ty
- -- (IO t) is ok, and so is any newtype wrapping thereof
+ -- (IO t) is ok, and so is any newtype wrapping thereof
| Just (_, res_ty, _) <- tcSplitIOType_maybe ty,
pred_res_ty res_ty
= return ()
-
+
| otherwise
- = check (non_io_result_ok && pred_res_ty ty)
- (illegalForeignTyErr result ty)
+ = check (non_io_result_ok && pred_res_ty ty)
+ (illegalForeignTyErr result ty)
\end{code}
\begin{code}
checkCOrAsmOrLlvm HscAsm = Nothing
checkCOrAsmOrLlvm HscLlvm = Nothing
checkCOrAsmOrLlvm _
- = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
+ = Just (text "requires via-C, llvm (-fllvm) or native code generation (-fvia-C)")
checkCOrAsmOrLlvmOrInterp :: HscTarget -> Maybe SDoc
checkCOrAsmOrLlvmOrInterp HscC = Nothing
checkCOrAsmOrLlvmOrInterp HscLlvm = Nothing
checkCOrAsmOrLlvmOrInterp HscInterpreted = Nothing
checkCOrAsmOrLlvmOrInterp _
- = Just (text "requires interpreted, C, Llvm or native code generation")
+ = Just (text "requires interpreted, C, Llvm or native code generation")
checkCOrAsmOrLlvmOrDotNetOrInterp :: HscTarget -> Maybe SDoc
checkCOrAsmOrLlvmOrDotNetOrInterp HscC = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp HscLlvm = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp HscInterpreted = Nothing
checkCOrAsmOrLlvmOrDotNetOrInterp _
- = Just (text "requires interpreted, C, Llvm or native code generation")
+ = Just (text "requires interpreted, C, Llvm or native code generation")
checkCg :: (HscTarget -> Maybe SDoc) -> TcM ()
checkCg check = do
- dflags <- getDOpts
- let target = hscTarget dflags
- case target of
- HscNothing -> return ()
- _ ->
- case check target of
- Nothing -> return ()
- Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
+ dflags <- getDOpts
+ let target = hscTarget dflags
+ case target of
+ HscNothing -> return ()
+ _ ->
+ case check target of
+ Nothing -> return ()
+ Just err -> addErrTc (text "Illegal foreign declaration:" <+> err)
\end{code}
-
+
Calling conventions
\begin{code}
checkCConv :: CCallConv -> TcM ()
-checkCConv CCallConv = return ()
+checkCConv CCallConv = return ()
#if i386_TARGET_ARCH
-checkCConv StdCallConv = return ()
+checkCConv StdCallConv = return ()
#else
-- This is a warning, not an error. see #3336
-checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform,"$$ text "treating as ccall")
+checkCConv StdCallConv = addWarnTc (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
#endif
checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
-checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
+checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
\end{code}
Deprecated "threadsafe" calls
\begin{code}
check :: Bool -> Message -> TcM ()
-check True _ = return ()
+check True _ = return ()
check _ the_err = addErrTc the_err
illegalForeignTyErr :: SDoc -> Type -> SDoc
illegalForeignTyErr arg_or_res ty
- = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
+ = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res,
ptext (sLit "type in foreign declaration:")])
2 (hsep [ppr ty])
result = text "result"
badCName :: CLabelString -> Message
-badCName target
- = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
+badCName target
+ = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")]
foreignDeclCtxt :: ForeignDecl Name -> SDoc
foreignDeclCtxt fo
= hang (ptext (sLit "When checking declaration:"))
2 (ppr fo)
\end{code}
-
import HscTypes
import PrelInfo
import MkCore ( eRROR_ID )
-import PrelNames
+import PrelNames hiding (error_RDR)
import PrimOp
import SrcLoc
import TyCon
import TysPrim
import TysWiredIn
import Type
-import Var( TyVar )
import TypeRep
import VarSet
import State
single_con_range
= mk_easy_FunBind loc range_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
- nlHsDo ListComp stmts con_expr
+ noLoc (mkHsComp ListComp stmts con_expr)
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
read_nullary_cons
= case nullary_cons of
[] -> []
- [con] -> [nlHsDo DoExpr (match_con con) (result_expr con [])]
+ [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
_ -> [nlHsApp (nlHsVar choose_RDR)
(nlList (map mk_pair nullary_cons))]
-- NB For operators the parens around (:=:) are matched by the
------------------------------------------------------------------------
-- Helpers
------------------------------------------------------------------------
- mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
- mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
- bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
- con_app con as = nlHsVarApps (getRdrName con) as -- con as
- result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
+ mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
+ mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
+ , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
+ bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
+ con_app con as = nlHsVarApps (getRdrName con) as -- con as
+ result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
text "for primitive type" <+> ppr ty)
| otherwise = head res
where
- res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
+ res = [id | (ty',id) <- tbl, ty `eqType` ty']
-----------------------------------------------------------------------
import PrelNames
import TcType
import TcMType
+import Coercion
import TysPrim
import TysWiredIn
import DataCon
import Var
import VarSet
import VarEnv
+import DynFlags( DynFlag(..) )
import Literal
import BasicTypes
import Maybes
import SrcLoc
-import DynFlags( DynFlag(..) )
import Bag
import FastString
import Outputable
+-- import Data.Traversable( traverse )
\end{code}
\begin{code}
| isIntTy ty && inIntRange i = Just (HsLit (HsInt i))
| isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
| isIntegerTy ty = Just (HsLit (HsInteger i ty))
- | otherwise = shortCutLit (HsFractional (fromInteger i)) ty
+ | otherwise = shortCutLit (HsFractional (integralFractionalLit i)) ty
-- The 'otherwise' case is important
-- Consider (3 :: Float). Syntactically it looks like an IntLit,
-- so we'll call shortCutIntLit, but of course it's a float
zonkLExpr new_env expr `thenM` \ new_expr ->
returnM (HsLet new_binds new_expr)
-zonkExpr env (HsDo do_or_lc stmts body ty)
- = zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
- zonkLExpr new_env body `thenM` \ new_body ->
+zonkExpr env (HsDo do_or_lc stmts ty)
+ = zonkStmts env stmts `thenM` \ (_, new_stmts) ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (HsDo do_or_lc new_stmts new_body new_ty)
+ returnM (HsDo do_or_lc new_stmts new_ty)
zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
; (env2, c2') <- zonkCoFn env1 c2
; return (env2, WpCompose c1' c2') }
-zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co
+zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co
; return (env, WpCast co') }
zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev
; return (env', WpEvLam ev') }
; return (env2, s' : ss') }
zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
-zonkStmt env (ParStmt stmts_w_bndrs)
+zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op)
= mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
let
new_binders = concat (map snd new_stmts_w_bndrs)
env1 = extendZonkEnv env new_binders
in
- return (env1, ParStmt new_stmts_w_bndrs)
+ zonkExpr env1 mzip_op `thenM` \ new_mzip ->
+ zonkExpr env1 bind_op `thenM` \ new_bind ->
+ zonkExpr env1 return_op `thenM` \ new_return ->
+ return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind new_return)
where
zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) ->
returnM (new_stmts, zonkIdOccs env1 bndrs)
zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
, recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
- , recS_rec_rets = rets })
+ , recS_rec_rets = rets, recS_ret_ty = ret_ty })
= do { new_rvs <- zonkIdBndrs env rvs
; new_lvs <- zonkIdBndrs env lvs
+ ; new_ret_ty <- zonkTcTypeToType env ret_ty
; new_ret_id <- zonkExpr env ret_id
; new_mfix_id <- zonkExpr env mfix_id
; new_bind_id <- zonkExpr env bind_id
RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
, recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
, recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
- , recS_rec_rets = new_rets }) }
+ , recS_rec_rets = new_rets, recS_ret_ty = new_ret_ty }) }
-zonkStmt env (ExprStmt expr then_op ty)
+zonkStmt env (ExprStmt expr then_op guard_op ty)
= zonkLExpr env expr `thenM` \ new_expr ->
zonkExpr env then_op `thenM` \ new_then ->
+ zonkExpr env guard_op `thenM` \ new_guard ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
- returnM (env, ExprStmt new_expr new_then new_ty)
+ returnM (env, ExprStmt new_expr new_then new_guard new_ty)
-zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr)
- = do { (env', stmts') <- zonkStmts env stmts
- ; let binders' = zonkIdOccs env' binders
- ; usingExpr' <- zonkLExpr env' usingExpr
- ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr
- ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') }
-
-zonkStmt env (GroupStmt stmts binderMap by using)
+zonkStmt env (LastStmt expr ret_op)
+ = zonkLExpr env expr `thenM` \ new_expr ->
+ zonkExpr env ret_op `thenM` \ new_ret ->
+ returnM (env, LastStmt new_expr new_ret)
+
+zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
+ , trS_by = by, trS_form = form, trS_using = using
+ , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op })
= do { (env', stmts') <- zonkStmts env stmts
; binderMap' <- mappM (zonkBinderMapEntry env') binderMap
- ; by' <- fmapMaybeM (zonkLExpr env') by
- ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using
+ ; by' <- fmapMaybeM (zonkLExpr env') by
+ ; using' <- zonkLExpr env using
+ ; return_op' <- zonkExpr env' return_op
+ ; bind_op' <- zonkExpr env' bind_op
+ ; liftM_op' <- zonkExpr env' liftM_op
; let env'' = extendZonkEnv env' (map snd binderMap')
- ; return (env'', GroupStmt stmts' binderMap' by' using') }
+ ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
+ , trS_by = by', trS_form = form, trS_using = using'
+ , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
where
zonkBinderMapEntry env (oldBinder, newBinder) = do
let oldBinder' = zonkIdOcc env oldBinder
; new_fail <- zonkExpr env fail_op
; return (env1, BindStmt new_pat new_expr new_bind new_fail) }
-zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id))
-zonkMaybeLExpr _ Nothing = return Nothing
-zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just)
-
-
-------------------------------------------------------------------------
zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
zonkRecFields env (HsRecFields flds dd)
zonk_it env v
| isId v = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') }
- | isCoVar v = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') }
| otherwise = ASSERT( isImmutableTyVar v) return (env, v)
\end{code}
zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v )
return (EvId (zonkIdOcc env v))
-zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcTypeToType env co
+zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcCoToCo env co
; return (EvCoercion co') }
zonkEvTerm env (EvCast v co) = ASSERT( isId v)
- do { co' <- zonkTcTypeToType env co
+ do { co' <- zonkTcCoToCo env co
; return (EvCast (zonkIdOcc env v) co') }
zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
zonkEvTerm env (EvDFunApp df tys tms)
zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv)
; writeMetaTyVar tv ty
; return ty }
-\end{code}
\ No newline at end of file
+
+zonkTcCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
+zonkTcCoToCo env co
+ = go co
+ where
+ go (CoVarCo cv) = return (CoVarCo (zonkEvVarOcc env cv))
+ go (Refl ty) = do { ty' <- zonkTcTypeToType env ty
+ ; return (Refl ty') }
+ go (TyConAppCo tc cos) = do { cos' <- mapM go cos; return (mkTyConAppCo tc cos') }
+ go (AxiomInstCo ax cos) = do { cos' <- mapM go cos; return (AxiomInstCo ax cos') }
+ go (AppCo co1 co2) = do { co1' <- go co1; co2' <- go co2
+ ; return (mkAppCo co1' co2') }
+ go (UnsafeCo t1 t2) = do { t1' <- zonkTcTypeToType env t1
+ ; t2' <- zonkTcTypeToType env t2
+ ; return (mkUnsafeCo t1' t2') }
+ go (SymCo co) = do { co' <- go co; return (mkSymCo co') }
+ go (NthCo n co) = do { co' <- go co; return (mkNthCo n co') }
+ go (TransCo co1 co2) = do { co1' <- go co1; co2' <- go co2
+ ; return (mkTransCo co1' co2') }
+ go (InstCo co ty) = do { co' <- go co; ty' <- zonkTcTypeToType env ty
+ ; return (mkInstCo co' ty') }
+ go (ForAllCo tv co) = ASSERT( isImmutableTyVar tv )
+ do { co' <- go co; return (mkForAllCo tv co') }
+\end{code}
import Class
import Name
import NameSet
-import PrelNames
import TysWiredIn
import BasicTypes
import SrcLoc
ty' <- kcLiftedType ty
return (HsModalBoxType ecn ty', liftedTypeKind)
-kc_hs_type (HsNumTy n)
- = return (HsNumTy n, liftedTypeKind)
-
kc_hs_type (HsKindSig ty k) = do
ty' <- kc_check_lhs_type ty (EK k EkKindSig)
return (HsKindSig ty' k, k)
tau_ty2 <- dsHsType ty2
setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2])
-ds_type (HsNumTy n)
- = ASSERT(n==1) do
- tc <- tcLookupTyCon genUnitTyConName
- return (mkTyConApp tc [])
-
ds_type ty@(HsAppTy _ _)
= ds_app ty []
[(Name, TcType)], -- The new bit of type environment, binding
-- the scoped type variables
HsWrapper) -- Coercion due to unification with actual ty
- -- Of shape: res_ty ~ sig_ty
+ -- Of shape: res_ty ~ sig_ty
tcPatSig ctxt sig res_ty
= do { (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig
-- sig_tvs are the type variables free in 'sig',
-- and hence is rigid, so use it to zap the res_ty
wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty
; return (sig_ty, [], wrap)
-
- } else do {
+ } else do {
-- Type signature binds at least one scoped type variable
-- A pattern binding cannot bind scoped type variables
; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs)
-- Now do a subsumption check of the pattern signature against res_ty
- ; sig_tvs' <- tcInstSigTyVars sig_tvs
+ ; sig_tvs' <- tcInstSigTyVars sig_tvs
; let sig_ty' = substTyWith sig_tvs sig_tv_tys' sig_ty
sig_tv_tys' = mkTyVarTys sig_tvs'
- ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty'
+ ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty'
-- Check that each is bound to a distinct type variable,
-- and one that is not already in scope
- ; binds_in_scope <- getScopedTyVarBinds
+ ; binds_in_scope <- getScopedTyVarBinds
; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys'
; check binds_in_scope tv_binds
-- Phew!
- ; return (sig_ty', tv_binds, wrap)
- } }
+ ; return (sig_ty', tv_binds, wrap)
+ } }
where
check _ [] = return ()
check in_scope ((n,ty):rest) = do { check_one in_scope n ty
-- Must not bind to the same type variable
-- as some other in-scope type variable
where
- dups = [n' | (n',ty') <- in_scope, tcEqType ty' ty]
+ dups = [n' | (n',ty') <- in_scope, eqType ty' ty]
\end{code}
import TcRnMonad
import TcMType
import TcType
+import BuildTyCl
import Inst
import InstEnv
import FamInst
import FamInstEnv
-import MkCore ( nO_METHOD_BINDING_ERROR_ID )
import TcDeriv
import TcEnv
import RnSource ( addTcgDUs )
import TcHsType
import TcUnify
+import MkCore ( nO_METHOD_BINDING_ERROR_ID )
import Type
import Coercion
import TyCon
import DataCon
import Class
import Var
+import Pair
import VarSet
import CoreUtils ( mkPiTypes )
import CoreUnfold ( mkDFunUnfolding )
Instead, we simply rely on the fact that casts are cheap:
$df :: forall a. C a => C [a]
- {-# INLINE df #} -- NB: INLINE this
+ {-# INLINE df #-} -- NB: INLINE this
$df = /\a. \d. MkC [a] ($cop_list a d)
= $cop_list |> forall a. C a -> (sym (Co:C [a]))
; let { (local_info,
at_tycons_s) = unzip local_info_tycons
; at_idx_tycons = concat at_tycons_s ++ idx_tycons
- ; clas_decls = filter (isClassDecl . unLoc) tycl_decls
- ; implicit_things = concatMap implicitTyThings at_idx_tycons
- ; aux_binds = mkRecSelBinds at_idx_tycons
- }
+ ; implicit_things = concatMap implicitTyConThings at_idx_tycons
+ ; aux_binds = mkRecSelBinds at_idx_tycons }
-- (2) Add the tycons of indexed types and their implicit
-- tythings to the global environment
- ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
+ ; tcExtendGlobalEnv (map ATyCon at_idx_tycons ++ implicit_things) $ do {
- -- (3) Instances from generic class declarations
- ; generic_inst_info <- getGenericInstances clas_decls
-- Next, construct the instance environment so far, consisting
-- of
-- (a) local instance decls
- -- (b) generic instances
- -- (c) local family instance decls
+ -- (b) local family instance decls
; addInsts local_info $
- addInsts generic_inst_info $
addFamInsts at_idx_tycons $ do {
- -- (4) Compute instances from "deriving" clauses;
+ -- (3) Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance
-- decl, so it needs to know about all the instances possible
-- NB: class instance declarations can contain derivings as
-- part of associated data type declarations
- failIfErrsM -- If the addInsts stuff gave any errors, don't
- -- try the deriving stuff, becuase that may give
- -- more errors still
- ; (deriv_inst_info, deriv_binds, deriv_dus)
+ failIfErrsM -- If the addInsts stuff gave any errors, don't
+ -- try the deriving stuff, because that may give
+ -- more errors still
+ ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts)
<- tcDeriving tycl_decls inst_decls deriv_decls
- ; gbl_env <- addInsts deriv_inst_info getGblEnv
+
+ -- Extend the global environment also with the generated datatypes for
+ -- the generic representation
+ ; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts)
+ ; gbl_env <- tcExtendGlobalEnv all_tycons $
+ tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $
+ addFamInsts deriv_ty_insts $
+ addInsts deriv_inst_info getGblEnv
; return ( addTcgDUs gbl_env deriv_dus,
- generic_inst_info ++ deriv_inst_info ++ local_info,
+ deriv_inst_info ++ local_info,
aux_binds `plusHsValBinds` deriv_binds)
}}}
addInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
-addFamInsts :: [TyThing] -> TcM a -> TcM a
+addFamInsts :: [TyCon] -> TcM a -> TcM a
addFamInsts tycons thing_inside
- = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
- where
- mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
- mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
- (ppr tything)
+ = tcExtendLocalFamInstEnv (map mkLocalFamInst tycons) thing_inside
\end{code}
\begin{code}
tcLocalInstDecl1 :: LInstDecl Name
- -> TcM (InstInfo Name, [TyThing])
+ -> TcM (InstInfo Name, [TyCon])
-- A source-file instance declaration
-- Type-check all the stuff before the "where"
--
checkValidAndMissingATs :: Class
-> ([TyVar], [TcType]) -- instance types
-> [(LTyClDecl Name, -- source form of AT
- TyThing)] -- Core form of AT
+ TyCon)] -- Core form of AT
-> TcM ()
checkValidAndMissingATs clas inst_tys ats
= do { -- Issue a warning for each class AT that is not defined in this
; mapM_ (checkIndexes clas inst_tys) ats
}
- checkIndexes clas inst_tys (hsAT, ATyCon tycon)
+ checkIndexes clas inst_tys (hsAT, tycon)
-- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
= checkIndexes' clas inst_tys hsAT
(tyConTyVars tycon,
snd . fromJust . tyConFamInst_maybe $ tycon)
- checkIndexes _ _ _ = panic "checkIndexes"
checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
= let atName = tcdName . unLoc $ hsAT
| isTyVarTy ty = return ()
| otherwise = addErrTc $ mustBeVarArgErr ty
checkIndex ty (Just instTy)
- | ty `tcEqType` instTy = return ()
- | otherwise = addErrTc $ wrongATArgErr ty instTy
+ | ty `eqType` instTy = return ()
+ | otherwise = addErrTc $ wrongATArgErr ty instTy
listToNameSet = addListToNameSet emptyNameSet
tv1 `sameLexeme` tv2 =
nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
in
- extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
+ TcType.extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
+\end{code}
+
+
+%************************************************************************
+%* *
+ Type checking family instances
+%* *
+%************************************************************************
+
+Family instances are somewhat of a hybrid. They are processed together with
+class instance heads, but can contain data constructors and hence they share a
+lot of kinding and type checking code with ordinary algebraic data types (and
+GADTs).
+
+\begin{code}
+tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyCon
+tcFamInstDecl top_lvl (L loc decl)
+ = -- Prime error recovery, set source location
+ setSrcSpan loc $
+ tcAddDeclCtxt decl $
+ do { -- type family instances require -XTypeFamilies
+ -- and can't (currently) be in an hs-boot file
+ ; type_families <- xoptM Opt_TypeFamilies
+ ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
+ ; checkTc type_families $ badFamInstDecl (tcdLName decl)
+ ; checkTc (not is_boot) $ badBootFamInstDeclErr
+
+ -- Perform kind and type checking
+ ; tc <- tcFamInstDecl1 decl
+ ; checkValidTyCon tc -- Remember to check validity;
+ -- no recursion to worry about here
+
+ -- Check that toplevel type instances are not for associated types.
+ ; when (isTopLevel top_lvl && isAssocFamily tc)
+ (addErr $ assocInClassErr (tcdName decl))
+
+ ; return tc }
+
+isAssocFamily :: TyCon -> Bool -- Is an assocaited type
+isAssocFamily tycon
+ = case tyConFamInst_maybe tycon of
+ Nothing -> panic "isAssocFamily: no family?!?"
+ Just (fam, _) -> isTyConAssoc fam
+
+assocInClassErr :: Name -> SDoc
+assocInClassErr name
+ = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
+ ptext (sLit "must be inside a class instance")
+
+
+
+tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
+
+ -- "type instance"
+tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
+ = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
+ do { -- check that the family declaration is for a synonym
+ checkTc (isFamilyTyCon family) (notFamily family)
+ ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
+
+ ; -- (1) kind check the right-hand side of the type equation
+ ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
+ -- ToDo: the ExpKind could be better
+
+ -- we need the exact same number of type parameters as the family
+ -- declaration
+ ; let famArity = tyConArity family
+ ; checkTc (length k_typats == famArity) $
+ wrongNumberOfParmsErr famArity
+
+ -- (2) type check type equation
+ ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
+ ; t_typats <- mapM tcHsKindedType k_typats
+ ; t_rhs <- tcHsKindedType k_rhs
+
+ -- (3) check the well-formedness of the instance
+ ; checkValidTypeInst t_typats t_rhs
+
+ -- (4) construct representation tycon
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
+ ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
+ (typeKind t_rhs)
+ NoParentTyCon (Just (family, t_typats))
+ }}
+
+ -- "newtype instance" and "data instance"
+tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
+ tcdCons = cons})
+ = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
+ do { -- check that the family declaration is for the right kind
+ checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
+ ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
+
+ ; -- (1) kind check the data declaration as usual
+ ; k_decl <- kcDataDecl decl k_tvs
+ ; let k_ctxt = tcdCtxt k_decl
+ k_cons = tcdCons k_decl
+
+ -- result kind must be '*' (otherwise, we have too few patterns)
+ ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
+
+ -- (2) type check indexed data type declaration
+ ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
+ ; unbox_strict <- doptM Opt_UnboxStrictFields
+
+ -- kind check the type indexes and the context
+ ; t_typats <- mapM tcHsKindedType k_typats
+ ; stupid_theta <- tcHsKindedContext k_ctxt
+
+ -- (3) Check that
+ -- (a) left-hand side contains no type family applications
+ -- (vanilla synonyms are fine, though, and we checked for
+ -- foralls earlier)
+ ; mapM_ checkTyFamFreeness t_typats
+
+ ; dataDeclChecks tc_name new_or_data stupid_theta k_cons
+
+ -- (4) construct representation tycon
+ ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
+ ; let ex_ok = True -- Existentials ok for type families!
+ ; fixM (\ rep_tycon -> do
+ { let orig_res_ty = mkTyConApp fam_tycon t_typats
+ ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
+ (t_tvs, orig_res_ty) k_cons
+ ; tc_rhs <-
+ case new_or_data of
+ DataType -> return (mkDataTyConRhs data_cons)
+ NewType -> ASSERT( not (null data_cons) )
+ mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
+ ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
+ h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
+ -- We always assume that indexed types are recursive. Why?
+ -- (1) Due to their open nature, we can never be sure that a
+ -- further instance might not introduce a new recursive
+ -- dependency. (2) They are always valid loop breakers as
+ -- they involve a coercion.
+ })
+ }}
+ where
+ h98_syntax = case cons of -- All constructors have same shape
+ L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
+ _ -> True
+
+tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
+
+-- Kind checking of indexed types
+-- -
+
+-- Kind check type patterns and kind annotate the embedded type variables.
+--
+-- * Here we check that a type instance matches its kind signature, but we do
+-- not check whether there is a pattern for each type index; the latter
+-- check is only required for type synonym instances.
+
+kcIdxTyPats :: TyClDecl Name
+ -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
+ -- ^^kinded tvs ^^kinded ty pats ^^res kind
+ -> TcM a
+kcIdxTyPats decl thing_inside
+ = kcHsTyVars (tcdTyVars decl) $ \tvs ->
+ do { let tc_name = tcdLName decl
+ ; fam_tycon <- tcLookupLocatedTyCon tc_name
+ ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
+ ; hs_typats = fromJust $ tcdTyPats decl }
+
+ -- we may not have more parameters than the kind indicates
+ ; checkTc (length kinds >= length hs_typats) $
+ tooManyParmsErr (tcdLName decl)
+
+ -- type functions can have a higher-kinded result
+ ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
+ ; typats <- zipWithM kcCheckLHsType hs_typats
+ [ EK kind (EkArg (ppr tc_name) n)
+ | (kind,n) <- kinds `zip` [1..]]
+ ; thing_inside tvs typats resultKind fam_tycon
+ }
\end{code}
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
do { -- Instantiate the instance decl with skolem constants
; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
+ -- We instantiate the dfun_id with superSkolems.
+ -- See Note [Subtle interaction of recursion and overlap]
+ -- and Note [Binding when looking up instances]
; let (clas, inst_tys) = tcSplitDFunHead inst_head
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
listToBag meth_binds)
}
where
- skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap]
+ skol_info = InstSkol
dfun_ty = idType dfun_id
dfun_id = instanceDFunId ispec
loc = getSrcSpan dfun_id
; return (sc_dict, DFunConstArg (Var sc_dict)) }
where
find _ [] = Nothing
- find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i)
- | otherwise = find (i+1) evs
+ find i (ev:evs) | pred `eqPred` evVarPred ev = Just (ev, i)
+ | otherwise = find (i+1) evs
------------------------------
tcSpecInstPrags :: DFunId -> InstBindings Name
----------------------
tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
+
+ tc_default sel_id (GenDefMeth dm_name)
+ = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
+ ; tc_body sel_id False {- Not generated code? -} meth_bind }
+{-
tc_default sel_id GenDefMeth -- Derivable type classes stuff
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
; tc_body sel_id False {- Not generated code? -} meth_bind }
-
+-}
tc_default sel_id NoDefMeth -- No default method at all
= do { warnMissingMethod sel_id
; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
Just (init_inst_tys, _) = snocView inst_tys
- rep_ty = fst (coercionKind co) -- [p]
+ rep_ty = pFst (coercionKind co) -- [p]
rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
-- co : [p] ~ T p
- co = substTyWith inst_tvs (mkTyVarTys tyvars) $
- case coi of { IdCo ty -> ty ;
- ACo co -> mkSymCoercion co }
+ co = substCoWithTys inst_tvs (mkTyVarTys tyvars) $
+ mkSymCo coi
----------------
tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
----------------
mk_op_wrapper :: Id -> EvVar -> HsWrapper
mk_op_wrapper sel_id rep_d
- = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
+ = WpCast (liftCoSubstWith sel_tvs (map mkReflCo init_inst_tys ++ [co])
+ local_meth_ty)
<.> WpEvApp (EvId rep_d)
<.> mkWpTyApps (init_inst_tys ++ [rep_ty])
where
, ptext (sLit "Found") <+> quotes (ppr ty)
<+> ptext (sLit "but expected") <+> quotes (ppr instTy)
]
+
+tooManyParmsErr :: Located Name -> SDoc
+tooManyParmsErr tc_name
+ = ptext (sLit "Family instance has too many parameters:") <+>
+ quotes (ppr tc_name)
+
+tooFewParmsErr :: Arity -> SDoc
+tooFewParmsErr arity
+ = ptext (sLit "Family instance has too few parameters; expected") <+>
+ ppr arity
+
+wrongNumberOfParmsErr :: Arity -> SDoc
+wrongNumberOfParmsErr exp_arity
+ = ptext (sLit "Number of parameters must match family declaration; expected")
+ <+> ppr exp_arity
+
+badBootFamInstDeclErr :: SDoc
+badBootFamInstDeclErr
+ = ptext (sLit "Illegal family instance in hs-boot file")
+
+notFamily :: TyCon -> SDoc
+notFamily tycon
+ = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
+ , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
+
+wrongKindOfFamily :: TyCon -> SDoc
+wrongKindOfFamily family
+ = ptext (sLit "Wrong category of family instance; declaration was for a")
+ <+> kindOfFamily
+ where
+ kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
+ | isAlgTyCon family = ptext (sLit "data type")
+ | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
\end{code}
import TcCanonical
import VarSet
import Type
+import Unify
import Id
import Var
import Outputable
import TcRnTypes
+import TcMType ( isSilentEvVar )
import TcErrors
import TcSMonad
import Bag
will be marked as solved right before being pushed into the inert set.
See note [Touchables and givens].
- 8 No Given constraint mentions a touchable unification variable,
- except if the
+ 8 No Given constraint mentions a touchable unification variable, but
+ Given/Solved may do so.
+
+ 9 Given constraints will also have their superclasses in the inert set,
+ but Given/Solved will not.
Note that 6 and 7 are /not/ enforced by canonicalization but rather by
insertion in the inert list, ie by TcInteract.
, inert_funeqs = solved_funeqs }
in (is_solved, unsolved)
- where (unsolved_eqs, solved_eqs) = Bag.partitionBag (not.isGivenCt) eqs
+ where (unsolved_eqs, solved_eqs) = Bag.partitionBag (not.isGivenOrSolvedCt) eqs
(unsolved_ips, solved_ips) = extractUnsolvedCMap (inert_ips is)
(unsolved_dicts, solved_dicts) = extractUnsolvedCMap (inert_dicts is)
(unsolved_funeqs, solved_funeqs) = extractUnsolvedCMap (inert_funeqs is)
map mk_given evs
; return inert_ret }
where
- flav = Given gloc
+ flav = Given gloc GivenOrig
mk_given ev = mkEvVarX ev flav
solveInteractWanted :: InertSet -> [WantedEvVar] -> TcS InertSet
discharge_ct :: CanonicalCt -> TcS Bool -> TcS Bool
discharge_ct ct _rest
- | evVarPred (cc_id ct) `tcEqPred` the_pred
+ | evVarPred (cc_id ct) `eqPred` the_pred
, cc_flavor ct `canSolve` fl
- = do { when (isWanted fl) $ set_ev_bind ev (cc_id ct)
+ = do { when (isWanted fl) $ setEvBind ev (evVarTerm (cc_id ct))
-- Deriveds need no evidence
-- For Givens, we already have evidence, and we don't need it twice
; return True }
- where
- set_ev_bind x y
- | EqPred {} <- evVarPred y = setEvBind x (EvCoercion (mkCoVarCoercion y))
- | otherwise = setEvBind x (EvId y)
discharge_ct _ct rest = rest
\end{code}
, sr_stop = ContinueWith workItem }
SPSolved workItem'
- | not (isGivenCt workItem)
+ | not (isGivenOrSolvedCt workItem)
-- Original was wanted or derived but we have now made him
-- given so we have to interact him with the inerts due to
-- its status change. This in turn may produce more work.
-- See Note [Touchables and givens]
trySpontaneousSolve :: WorkItem -> TcS SPSolveResult
trySpontaneousSolve workItem@(CTyEqCan { cc_id = cv, cc_flavor = gw, cc_tyvar = tv1, cc_rhs = xi })
- | isGiven gw
+ | isGivenOrSolved gw
= return SPCantSolve
| Just tv2 <- tcGetTyVar_maybe xi
= do { tch1 <- isTouchableMetaTyVar tv1
]
; setWantedTyBind tv xi
- ; cv_given <- newGivenCoVar (mkTyVarTy tv) xi xi
+ ; let refl_xi = mkReflCo xi
+ ; cv_given <- newGivenCoVar (mkTyVarTy tv) xi refl_xi
- ; when (isWanted wd) (setCoBind cv xi)
+ ; when (isWanted wd) (setCoBind cv refl_xi)
-- We don't want to do this for Derived, that's why we use 'when (isWanted wd)'
-
; return $ SPSolved (CTyEqCan { cc_id = cv_given
- , cc_flavor = mkGivenFlavor wd UnkSkol
+ , cc_flavor = mkSolvedFlavor wd UnkSkol
, cc_tyvar = tv, cc_rhs = xi }) }
\end{code}
doInteractWithInert
inertItem@(CDictCan { cc_id = d1, cc_flavor = fl1, cc_class = cls1, cc_tyargs = tys1 })
workItem@(CDictCan { cc_id = d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 })
- | cls1 == cls2 && (and $ zipWith tcEqType tys1 tys2)
+ | cls1 == cls2 && eqTypes tys1 tys2
= solveOneFromTheOther "Cls/Cls" (EvId d1,fl1) workItem
- | cls1 == cls2 && (not (isGiven fl1 && isGiven fl2))
+ | cls1 == cls2 && (not (isGivenOrSolved fl1 && isGivenOrSolved fl2))
= -- See Note [When improvement happens]
do { let pty1 = ClassP cls1 tys1
pty2 = ClassP cls2 tys2
; case m of
Nothing -> noInteraction workItem
Just (rewritten_tys2, cos2, fd_work)
- | tcEqTypes tys1 rewritten_tys2
+ | eqTypes tys1 rewritten_tys2
-> -- Solve him on the spot in this case
case fl2 of
Given {} -> pprPanic "Unexpected given" (ppr inertItem $$ ppr workItem)
workListFromNonEq workItem' `unionWorkList` fd_work }
where
- dict_co = mkTyConCoercion (classTyCon cls1) cos2
+ dict_co = mkTyConAppCo (classTyCon cls1) cos2
}
-- Class constraint and given equality: use the equality to rewrite
-- so we just generate a fresh coercion variable that isn't used anywhere.
doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 })
workItem@(CIPCan { cc_flavor = wfl, cc_ip_nm = nm2, cc_ip_ty = ty2 })
- | nm1 == nm2 && isGiven wfl && isGiven ifl
+ | nm1 == nm2 && isGivenOrSolved wfl && isGivenOrSolved ifl
= -- See Note [Overriding implicit parameters]
-- Dump the inert item, override totally with the new one
-- Do not require type equality
-- we must *override* the outer one with the inner one
mkIRContinue "IP/IP override" workItem DropInert emptyWorkList
- | nm1 == nm2 && ty1 `tcEqType` ty2
+ | nm1 == nm2 && ty1 `eqType` ty2
= solveOneFromTheOther "IP/IP" (EvId id1,ifl) workItem
| nm1 == nm2
= -- See Note [When improvement happens]
do { co_var <- newCoVar ty2 ty1 -- See Note [Efficient Orientation]
- ; let flav = Wanted (combineCtLoc ifl wfl)
- ; cans <- mkCanonical flav co_var
- ; mkIRContinue "IP/IP fundep" workItem KeepInert cans }
+ ; let flav = Wanted (combineCtLoc ifl wfl)
+ ; cans <- mkCanonical flav co_var
+ ; case wfl of
+ Given {} -> pprPanic "Unexpected given IP" (ppr workItem)
+ Derived {} -> pprPanic "Unexpected derived IP" (ppr workItem)
+ Wanted {} ->
+ do { setIPBind (cc_id workItem) $
+ EvCast id1 (mkSymCo (mkCoVarCo co_var))
+ ; mkIRStopK "IP/IP interaction (solved)" cans }
+ }
-- Never rewrite a given with a wanted equality, and a type function
-- equality can never rewrite an equality. We rewrite LHS *and* RHS
, cc_tyargs = args1, cc_rhs = xi1 })
workItem@(CFunEqCan { cc_id = cv2, cc_flavor = fl2, cc_fun = tc2
, cc_tyargs = args2, cc_rhs = xi2 })
+ | tc1 == tc2 && and (zipWith eqType args1 args2)
+ , Just GivenSolved <- isGiven_maybe fl1
+ = mkIRContinue "Funeq/Funeq" workItem DropInert emptyWorkList
+ | tc1 == tc2 && and (zipWith eqType args1 args2)
+ , Just GivenSolved <- isGiven_maybe fl2
+ = mkIRStopK "Funeq/Funeq" emptyWorkList
+
| fl1 `canSolve` fl2 && lhss_match
- = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2)
+ = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCo cv1,xi1) (cv2,fl2,xi2)
; mkIRStopK "FunEq/FunEq" cans }
| fl2 `canSolve` fl1 && lhss_match
- = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1)
+ = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCo cv2,xi2) (cv1,fl1,xi1)
; mkIRContinue "FunEq/FunEq" workItem DropInert cans }
where
- lhss_match = tc1 == tc2 && and (zipWith tcEqType args1 args2)
+ lhss_match = tc1 == tc2 && eqTypes args1 args2
doInteractWithInert (CTyEqCan { cc_id = cv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 })
workItem@(CTyEqCan { cc_id = cv2, cc_flavor = fl2, cc_tyvar = tv2, cc_rhs = xi2 })
-- Check for matching LHS
| fl1 `canSolve` fl2 && tv1 == tv2
- = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2)
+ = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCo cv1,xi1) (cv2,fl2,xi2)
; mkIRStopK "Eq/Eq lhs" cans }
| fl2 `canSolve` fl1 && tv1 == tv2
- = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1)
+ = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCo cv2,xi2) (cv1,fl1,xi1)
; mkIRContinue "Eq/Eq lhs" workItem DropInert cans }
-- Check for rewriting RHS
-- Equational Rewriting
rewriteDict :: (CoVar, TcTyVar, Xi) -> (DictId, CtFlavor, Class, [Xi]) -> TcS CanonicalCt
rewriteDict (cv,tv,xi) (dv,gw,cl,xis)
- = do { let cos = substTysWith [tv] [mkCoVarCoercion cv] xis -- xis[tv] ~ xis[xi]
+ = do { let cos = map (liftCoSubstWith [tv] [mkCoVarCo cv]) xis -- xis[tv] ~ xis[xi]
args = substTysWith [tv] [xi] xis
con = classTyCon cl
- dict_co = mkTyConCoercion con cos
+ dict_co = mkTyConAppCo con cos
; dv' <- newDictVar cl args
; case gw of
- Wanted {} -> setDictBind dv (EvCast dv' (mkSymCoercion dict_co))
+ Wanted {} -> setDictBind dv (EvCast dv' (mkSymCo dict_co))
Given {} -> setDictBind dv' (EvCast dv dict_co)
Derived {} -> return () -- Derived dicts we don't set any evidence
rewriteIP :: (CoVar,TcTyVar,Xi) -> (EvVar,CtFlavor, IPName Name, TcType) -> TcS CanonicalCt
rewriteIP (cv,tv,xi) (ipid,gw,nm,ty)
- = do { let ip_co = substTyWith [tv] [mkCoVarCoercion cv] ty -- ty[tv] ~ t[xi]
- ty' = substTyWith [tv] [xi] ty
+ = do { let ip_co = liftCoSubstWith [tv] [mkCoVarCo cv] ty -- ty[tv] ~ t[xi]
+ ty' = substTyWith [tv] [xi] ty
; ipid' <- newIPVar nm ty'
; case gw of
- Wanted {} -> setIPBind ipid (EvCast ipid' (mkSymCoercion ip_co))
+ Wanted {} -> setIPBind ipid (EvCast ipid' (mkSymCo ip_co))
Given {} -> setIPBind ipid' (EvCast ipid ip_co)
Derived {} -> return () -- Derived ips: we don't set any evidence
rewriteFunEq :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TyCon, [Xi], Xi) -> TcS CanonicalCt
rewriteFunEq (cv1,tv,xi1) (cv2,gw, tc,args,xi2) -- cv2 :: F args ~ xi2
- = do { let arg_cos = substTysWith [tv] [mkCoVarCoercion cv1] args
- args' = substTysWith [tv] [xi1] args
- fun_co = mkTyConCoercion tc arg_cos -- fun_co :: F args ~ F args'
+ = do { let co_subst = liftCoSubstWith [tv] [mkCoVarCo cv1]
+ arg_cos = map co_subst args
+ args' = substTysWith [tv] [xi1] args
+ fun_co = mkTyConAppCo tc arg_cos -- fun_co :: F args ~ F args'
xi2' = substTyWith [tv] [xi1] xi2
- xi2_co = substTyWith [tv] [mkCoVarCoercion cv1] xi2 -- xi2_co :: xi2 ~ xi2'
+ xi2_co = co_subst xi2 -- xi2_co :: xi2 ~ xi2'
; cv2' <- newCoVar (mkTyConApp tc args') xi2'
; case gw of
- Wanted {} -> setCoBind cv2 (fun_co `mkTransCoercion`
- mkCoVarCoercion cv2' `mkTransCoercion`
- mkSymCoercion xi2_co)
- Given {} -> setCoBind cv2' (mkSymCoercion fun_co `mkTransCoercion`
- mkCoVarCoercion cv2 `mkTransCoercion`
+ Wanted {} -> setCoBind cv2 (fun_co `mkTransCo`
+ mkCoVarCo cv2' `mkTransCo`
+ mkSymCo xi2_co)
+ Given {} -> setCoBind cv2' (mkSymCo fun_co `mkTransCo`
+ mkCoVarCo cv2 `mkTransCo`
xi2_co)
Derived {} -> return ()
rewriteEqRHS (cv1,tv1,xi1) (cv2,gw,tv2,xi2)
| Just tv2' <- tcGetTyVar_maybe xi2'
, tv2 == tv2' -- In this case xi2[xi1/tv1] = tv2, so we have tv2~tv2
- = do { when (isWanted gw) (setCoBind cv2 (mkSymCoercion co2'))
+ = do { when (isWanted gw) (setCoBind cv2 (mkSymCo co2'))
; return emptyWorkList }
| otherwise
= do { cv2' <- newCoVar (mkTyVarTy tv2) xi2'
; case gw of
- Wanted {} -> setCoBind cv2 $ mkCoVarCoercion cv2' `mkTransCoercion`
- mkSymCoercion co2'
- Given {} -> setCoBind cv2' $ mkCoVarCoercion cv2 `mkTransCoercion`
+ Wanted {} -> setCoBind cv2 $ mkCoVarCo cv2' `mkTransCo`
+ mkSymCo co2'
+ Given {} -> setCoBind cv2' $ mkCoVarCo cv2 `mkTransCo`
co2'
Derived {} -> return ()
; canEqToWorkList gw cv2' (mkTyVarTy tv2) xi2' }
where
xi2' = substTyWith [tv1] [xi1] xi2
- co2' = substTyWith [tv1] [mkCoVarCoercion cv1] xi2 -- xi2 ~ xi2[xi1/tv1]
+ co2' = liftCoSubstWith [tv1] [mkCoVarCo cv1] xi2 -- xi2 ~ xi2[xi1/tv1]
rewriteEqLHS :: WhichComesFromInert -> (Coercion,Xi) -> (CoVar,CtFlavor,Xi) -> TcS WorkList
-- Used to ineract two equalities of the following form:
= do { cv2' <- newCoVar xi2 xi1
; case gw of
Wanted {} -> setCoBind cv2 $
- co1 `mkTransCoercion` mkSymCoercion (mkCoVarCoercion cv2')
+ co1 `mkTransCo` mkSymCo (mkCoVarCo cv2')
Given {} -> setCoBind cv2' $
- mkSymCoercion (mkCoVarCoercion cv2) `mkTransCoercion` co1
+ mkSymCo (mkCoVarCo cv2) `mkTransCo` co1
Derived {} -> return ()
; mkCanonical gw cv2' }
= do { cv2' <- newCoVar xi1 xi2
; case gw of
Wanted {} -> setCoBind cv2 $
- co1 `mkTransCoercion` mkCoVarCoercion cv2'
+ co1 `mkTransCo` mkCoVarCo cv2'
Given {} -> setCoBind cv2' $
- mkSymCoercion co1 `mkTransCoercion` mkCoVarCoercion cv2
+ mkSymCo co1 `mkTransCo` mkCoVarCo cv2
Derived {} -> return ()
; mkCanonical gw cv2' }
rewriteFrozen (cv1, tv1, xi1) (cv2, fl2)
= do { cv2' <- newCoVar ty2a' ty2b' -- ty2a[xi1/tv1] ~ ty2b[xi1/tv1]
; case fl2 of
- Wanted {} -> setCoBind cv2 $ co2a' `mkTransCoercion`
- mkCoVarCoercion cv2' `mkTransCoercion`
- mkSymCoercion co2b'
+ Wanted {} -> setCoBind cv2 $ co2a' `mkTransCo`
+ mkCoVarCo cv2' `mkTransCo`
+ mkSymCo co2b'
- Given {} -> setCoBind cv2' $ mkSymCoercion co2a' `mkTransCoercion`
- mkCoVarCoercion cv2 `mkTransCoercion`
+ Given {} -> setCoBind cv2' $ mkSymCo co2a' `mkTransCo`
+ mkCoVarCo cv2 `mkTransCo`
co2b'
Derived {} -> return ()
ty2a' = substTyWith [tv1] [xi1] ty2a
ty2b' = substTyWith [tv1] [xi1] ty2b
- co2a' = substTyWith [tv1] [mkCoVarCoercion cv1] ty2a -- ty2a ~ ty2a[xi1/tv1]
- co2b' = substTyWith [tv1] [mkCoVarCoercion cv1] ty2b -- ty2b ~ ty2b[xi1/tv1]
+ co2a' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2a -- ty2a ~ ty2a[xi1/tv1]
+ co2b' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2b -- ty2b ~ ty2b[xi1/tv1]
solveOneFromTheOther :: String -> (EvTerm, CtFlavor) -> CanonicalCt -> TcS InteractResult
-- First argument inert, second argument work-item. They both represent
-- so it's safe to continue on from this point
= mkIRContinue ("Solved[DI] " ++ info) workItem DropInert emptyWorkList
+ | Just GivenSolved <- isGiven_maybe ifl, isGivenOrSolved wfl
+ -- Same if the inert is a GivenSolved -- just get rid of it
+ = mkIRContinue ("Solved[SI] " ++ info) workItem DropInert emptyWorkList
+
| otherwise
= ASSERT( ifl `canSolve` wfl )
-- Because of Note [The Solver Invariant], plus Derived dealt with
-- only reacted with functional dependencies
-- arising from top-level instances.
-topReactionsStage :: SimplifierStage
-topReactionsStage depth workItem inerts
- = do { tir <- tryTopReact workItem
- ; case tir of
- NoTopInt ->
- return $ SR { sr_inerts = inerts
- , sr_new_work = emptyWorkList
- , sr_stop = ContinueWith workItem }
- SomeTopInt tir_new_work tir_new_inert ->
+topReactionsStage :: SimplifierStage
+topReactionsStage depth workItem inerts
+ = do { tir <- tryTopReact inerts workItem
+ -- NB: we pass the inerts as well. See Note [Instance and Given overlap]
+ ; case tir of
+ NoTopInt ->
+ return $ SR { sr_inerts = inerts
+ , sr_new_work = emptyWorkList
+ , sr_stop = ContinueWith workItem }
+ SomeTopInt tir_new_work tir_new_inert ->
do { bumpStepCountTcS
; traceFireTcS depth (ptext (sLit "Top react")
<+> vcat [ ptext (sLit "Work =") <+> ppr workItem
, ptext (sLit "New =") <+> ppr tir_new_work ])
- ; return $ SR { sr_inerts = inerts
+ ; return $ SR { sr_inerts = inerts
, sr_new_work = tir_new_work
, sr_stop = tir_new_inert
} }
}
-tryTopReact :: WorkItem -> TcS TopInteractResult
-tryTopReact workitem
+tryTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
+tryTopReact inerts workitem
= do { -- A flag controls the amount of interaction allowed
-- See Note [Simplifying RULE lhs constraints]
ctxt <- getTcSContext
; if allowedTopReaction (simplEqsOnly ctxt) workitem
then do { traceTcS "tryTopReact / calling doTopReact" (ppr workitem)
- ; doTopReact workitem }
+ ; doTopReact inerts workitem }
else return NoTopInt
}
allowedTopReaction eqs_only (CDictCan {}) = not eqs_only
allowedTopReaction _ _ = True
-doTopReact :: WorkItem -> TcS TopInteractResult
+doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
-- The work item does not react with the inert set, so try interaction with top-level instances
-- NB: The place to add superclasses in *not* in doTopReact stage. Instead superclasses are
-- added in the worklist as part of the canonicalisation process.
-- Given dictionary
-- See Note [Given constraint that matches an instance declaration]
-doTopReact (CDictCan { cc_flavor = Given {} })
+doTopReact _inerts (CDictCan { cc_flavor = Given {} })
= return NoTopInt -- NB: Superclasses already added since it's canonical
-- Derived dictionary: just look for functional dependencies
-doTopReact workItem@(CDictCan { cc_flavor = fl@(Derived loc)
- , cc_class = cls, cc_tyargs = xis })
+doTopReact _inerts workItem@(CDictCan { cc_flavor = fl@(Derived loc)
+ , cc_class = cls, cc_tyargs = xis })
= do { instEnvs <- getInstEnvs
; let fd_eqns = improveFromInstEnv instEnvs
(ClassP cls xis, pprArisingAt loc)
, tir_new_inert = ContinueWith workItem' } }
-- Wanted dictionary
-doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
- , cc_class = cls, cc_tyargs = xis })
+doTopReact inerts workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
+ , cc_class = cls, cc_tyargs = xis })
= do { -- See Note [MATCHING-SYNONYMS]
- ; lkp_inst_res <- matchClassInst cls xis loc
+ ; lkp_inst_res <- matchClassInst inerts cls xis loc
; case lkp_inst_res of
NoInstance ->
do { traceTcS "doTopReact/ no class instance for" (ppr dv)
; case m of
Nothing -> return NoTopInt
Just (xis',cos,fd_work) ->
- do { let dict_co = mkTyConCoercion (classTyCon cls) cos
+ do { let dict_co = mkTyConAppCo (classTyCon cls) cos
; dv'<- newDictVar cls xis'
; setDictBind dv (EvCast dv' dict_co)
; let workItem' = CDictCan { cc_id = dv', cc_flavor = fl,
-- matches already so we won't get any more info
-- from functional dependencies
| null wtvs
- -> do { traceTcS "doTopReact/ found nullary class instance for" (ppr dv)
+ -> do { traceTcS "doTopReact/found nullary class instance for" (ppr dv)
; setDictBind dv ev_term
-- Solved in one step and no new wanted work produced.
-- i.e we directly matched a top-level instance
, tir_new_inert = Stop } }
| otherwise
- -> do { traceTcS "doTopReact/ found nullary class instance for" (ppr dv)
+ -> do { traceTcS "doTopReact/found non-nullary class instance for" (ppr dv)
; setDictBind dv ev_term
-- Solved and new wanted work produced, you may cache the
- -- (tentatively solved) dictionary as Given! (used to be: Derived)
- ; let solved = workItem { cc_flavor = given_fl }
- given_fl = Given (setCtLocOrigin loc UnkSkol)
+ -- (tentatively solved) dictionary as Solved given.
+ ; let solved = workItem { cc_flavor = solved_fl }
+ solved_fl = mkSolvedFlavor fl UnkSkol
; inst_work <- canWanteds wtvs
; return $ SomeTopInt { tir_new_work = inst_work
, tir_new_inert = ContinueWith solved } }
}
-- Type functions
-doTopReact (CFunEqCan { cc_id = cv, cc_flavor = fl
- , cc_fun = tc, cc_tyargs = args, cc_rhs = xi })
+doTopReact _inerts (CFunEqCan { cc_flavor = fl })
+ | Just GivenSolved <- isGiven_maybe fl
+ = return NoTopInt -- If Solved, no more interactions should happen
+
+-- Otherwise, it's a Given, Derived, or Wanted
+doTopReact _inerts workItem@(CFunEqCan { cc_id = cv, cc_flavor = fl
+ , cc_fun = tc, cc_tyargs = args, cc_rhs = xi })
= ASSERT (isSynFamilyTyCon tc) -- No associated data families have reached that far
do { match_res <- matchFam tc args -- See Note [MATCHING-SYNONYMS]
; case match_res of
- MatchInstNo
- -> return NoTopInt
+ MatchInstNo -> return NoTopInt
MatchInstSingle (rep_tc, rep_tys)
-> do { let Just coe_tc = tyConFamilyCoercion_maybe rep_tc
Just rhs_ty = tcView (mkTyConApp rep_tc rep_tys)
-- RHS of a type function, so that it never
-- appears in an error message
-- See Note [Type synonym families] in TyCon
- coe = mkTyConApp coe_tc rep_tys
- ; cv' <- case fl of
- Wanted {} -> do { cv' <- newCoVar rhs_ty xi
- ; setCoBind cv $
- coe `mkTransCoercion`
- mkCoVarCoercion cv'
- ; return cv' }
- Given {} -> newGivenCoVar xi rhs_ty $
- mkSymCoercion (mkCoVarCoercion cv) `mkTransCoercion` coe
- Derived {} -> newDerivedId (EqPred xi rhs_ty)
- ; can_cts <- mkCanonical fl cv'
- ; return $ SomeTopInt can_cts Stop }
+ coe = mkAxInstCo coe_tc rep_tys
+ ; case fl of
+ Wanted {} -> do { cv' <- newCoVar rhs_ty xi
+ ; setCoBind cv $ coe `mkTransCo` mkCoVarCo cv'
+ ; can_cts <- mkCanonical fl cv'
+ ; let solved = workItem { cc_flavor = solved_fl }
+ solved_fl = mkSolvedFlavor fl UnkSkol
+ ; if isEmptyWorkList can_cts then
+ return (SomeTopInt can_cts Stop) -- No point in caching
+ else return $
+ SomeTopInt { tir_new_work = can_cts
+ , tir_new_inert = ContinueWith solved }
+ }
+ Given {} -> do { cv' <- newGivenCoVar xi rhs_ty $
+ mkSymCo (mkCoVarCo cv) `mkTransCo` coe
+ ; can_cts <- mkCanonical fl cv'
+ ; return $
+ SomeTopInt { tir_new_work = can_cts
+ , tir_new_inert = Stop }
+ }
+ Derived {} -> do { cv' <- newDerivedId (EqPred xi rhs_ty)
+ ; can_cts <- mkCanonical fl cv'
+ ; return $
+ SomeTopInt { tir_new_work = can_cts
+ , tir_new_inert = Stop }
+ }
+ }
_
-> panicTcS $ text "TcSMonad.matchFam returned multiple instances!"
}
-- Any other work item does not react with any top-level equations
-doTopReact _workItem = return NoTopInt
+doTopReact _inerts _workItem = return NoTopInt
\end{code}
= NoInstance
| GenInst [WantedEvVar] EvTerm
-matchClassInst :: Class -> [Type] -> WantedLoc -> TcS LookupInstResult
-matchClassInst clas tys loc
+matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult
+matchClassInst inerts clas tys loc
= do { let pred = mkClassPred clas tys
; mb_result <- matchClass clas tys
+ ; untch <- getUntouchables
; case mb_result of
MatchInstNo -> return NoInstance
- MatchInstMany -> return NoInstance -- defer any reactions of a multitude until
+ MatchInstMany -> return NoInstance -- defer any reactions of a multitude until
-- we learn more about the reagent
- MatchInstSingle (dfun_id, mb_inst_tys) ->
+ MatchInstSingle (_,_)
+ | given_overlap untch ->
+ do { traceTcS "Delaying instance application" $
+ vcat [ text "Workitem=" <+> pprPredTy (ClassP clas tys)
+ , text "Silents and their superclasses=" <+> ppr silents_and_their_scs
+ , text "All given dictionaries=" <+> ppr all_given_dicts ]
+ ; return NoInstance -- see Note [Instance and Given overlap]
+ }
+
+ MatchInstSingle (dfun_id, mb_inst_tys) ->
do { checkWellStagedDFun pred dfun_id loc
-- It's possible that not all the tyvars are in
-- (presumably there's a functional dependency in class C)
-- Hence mb_inst_tys :: Either TyVar TcType
- ; tys <- instDFunTypes mb_inst_tys
+ ; tys <- instDFunTypes mb_inst_tys
; let (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
; if null theta then
return (GenInst [] (EvDFunApp dfun_id tys []))
; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) }
}
}
+ where given_overlap :: TcsUntouchables -> Bool
+ given_overlap untch
+ = foldlBag (\r d -> r || matchable untch d) False all_given_dicts
+
+ matchable untch (CDictCan { cc_class = clas', cc_tyargs = sys, cc_flavor = fl })
+ | Just GivenOrig <- isGiven_maybe fl
+ , clas' == clas
+ , does_not_originate_in_a_silent clas' sys
+ = case tcUnifyTys (\tv -> if isTouchableMetaTyVar_InRange untch tv &&
+ tv `elemVarSet` tyVarsOfTypes tys
+ then BindMe else Skolem) tys sys of
+ -- We can't learn anything more about any variable at this point, so the only
+ -- cause of overlap can be by an instantiation of a touchable unification
+ -- variable. Hence we only bind touchable unification variables. In addition,
+ -- we use tcUnifyTys instead of tcMatchTys to rule out cyclic substitutions.
+ Nothing -> False
+ Just _ -> True
+ | otherwise = False -- No overlap with a solved, already been taken care of
+ -- by the overlap check with the instance environment.
+ matchable _tys ct = pprPanic "Expecting dictionary!" (ppr ct)
+
+ does_not_originate_in_a_silent clas sys
+ -- UGLY: See Note [Silent parameters overlapping]
+ = null $ filter (eqPred (ClassP clas sys)) silents_and_their_scs
+
+ silents_and_their_scs
+ = foldlBag (\acc rvnt -> case rvnt of
+ CDictCan { cc_id = d, cc_class = c, cc_tyargs = s }
+ | isSilentEvVar d -> (ClassP c s) : (transSuperClasses c s) ++ acc
+ _ -> acc) [] all_given_dicts
+
+ -- TODO:
+ -- When silent parameters will go away we should simply select from
+ -- the given map of the inert set.
+ all_given_dicts = Map.fold unionBags emptyCCan (cts_given $ inert_dicts inerts)
+
\end{code}
+
+Note [Silent parameters overlapping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+DV 12/05/2011:
+The long-term goal is to completely remove silent superclass
+parameters when checking instance declarations. But until then we must
+make sure that we never prevent the application of an instance
+declaration because of a potential match from a silent parameter --
+after all we are supposed to have solved that silent parameter from
+some instance, anyway! In effect silent parameters behave more like
+Solved than like Given.
+
+A concrete example appears in typecheck/SilentParametersOverlapping.hs
+
+Note [Instance and Given overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Assume that we have an inert set that looks as follows:
+ [Given] D [Int]
+And an instance declaration:
+ instance C a => D [a]
+A new wanted comes along of the form:
+ [Wanted] D [alpha]
+
+One possibility is to apply the instance declaration which will leave us
+with an unsolvable goal (C alpha). However, later on a new constraint may
+arise (for instance due to a functional dependency between two later dictionaries),
+that will add the equality (alpha ~ Int), in which case our ([Wanted] D [alpha])
+will be transformed to [Wanted] D [Int], which could have been discharged by the given.
+
+The solution is that in matchClassInst and eventually in topReact, we get back with
+a matching instance, only when there is no Given in the inerts which is unifiable to
+this particular dictionary.
+
+The end effect is that, much as we do for overlapping instances, we delay choosing a
+class instance if there is a possibility of another instance OR a given to match our
+constraint later on. This fixes bugs #4981 and #5002.
+
+This is arguably not easy to appear in practice due to our aggressive prioritization
+of equality solving over other constraints, but it is possible. I've added a test case
+in typecheck/should-compile/GivenOverlapping.hs
+
+Moreover notice that our goals here are different than the goals of the top-level
+overlapping checks. There we are interested in validating the following principle:
+
+ If we inline a function f at a site where the same global instance environment
+ is available as the instance environment at the definition site of f then we
+ should get the same behaviour.
+
+But for the Given Overlap check our goal is just related to completeness of
+constraint solving.
+
+
+
+
--------------------------------
-- Creating new evidence variables
newEvVar, newCoVar, newEvVars,
- writeWantedCoVar, readWantedCoVar,
newIP, newDict, newSilentGiven, isSilentEvVar,
newWantedEvVar, newWantedEvVars,
-- Checking type validity
Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
SourceTyCtxt(..), checkValidTheta,
- checkValidInstance,
- checkValidTypeInst, checkTyFamFreeness,
+ checkValidInstHead, checkValidInstance,
+ checkInstTermination, checkValidTypeInst, checkTyFamFreeness,
arityErr,
growPredTyVars, growThetaTyVars, validDerivPred,
--------------------------------
-- Zonking
zonkType, mkZonkTcTyVar, zonkTcPredType,
- zonkTcTypeCarefully,
- skolemiseUnboundMetaTyVar,
+ zonkTcTypeCarefully, skolemiseUnboundMetaTyVar,
zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar,
zonkQuantifiedTyVar, zonkQuantifiedTyVars,
zonkTcType, zonkTcTypes, zonkTcThetaType,
import TypeRep
import TcType
import Type
-import Coercion
import Class
import TyCon
import Var
newCoVar :: TcType -> TcType -> TcM CoVar
newCoVar ty1 ty2
- = do { name <- newName (mkTyVarOccFS (fsLit "co"))
+ = do { name <- newName (mkVarOccFS (fsLit "co"))
; return (mkCoVar name (mkPredTy (EqPred ty1 ty2))) }
newIP :: IPName Name -> TcType -> TcM IpId
readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
readMutVar (metaTvRef tyvar)
-readWantedCoVar :: CoVar -> TcM MetaDetails
-readWantedCoVar covar = ASSERT2( isMetaTyVar covar, ppr covar )
- readMutVar (metaTvRef covar)
-
isFilledMetaTyVar :: TyVar -> TcM Bool
-- True of a filled-in (Indirect) meta type variable
isFilledMetaTyVar tv
= WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar )
return ()
-writeWantedCoVar :: CoVar -> Coercion -> TcM ()
-writeWantedCoVar cv co = writeMetaTyVar cv co
-
--------------------
writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
-- Here the tyvar is for error checking only;
zonkWantedEvVar (EvVarX v l) = do { v' <- zonkEvVar v; return (EvVarX v' l) }
zonkFlavor :: CtFlavor -> TcM CtFlavor
-zonkFlavor (Given loc) = do { loc' <- zonkGivenLoc loc; return (Given loc') }
-zonkFlavor fl = return fl
+zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) }
+zonkFlavor fl = return fl
zonkGivenLoc :: GivenLoc -> TcM GivenLoc
-- GivenLocs may have unification variables inside them!
-- The two interesting cases!
go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar
- | otherwise = liftM TyVarTy $
- zonkTyVar zonk_tc_tyvar tyvar
+ | otherwise = return (TyVarTy tyvar)
-- Ordinary (non Tc) tyvars occur inside quantified types
go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do
ty' <- go ty
- tyvar' <- zonkTyVar zonk_tc_tyvar tyvar
+ tyvar' <- return tyvar
return (ForAllTy tyvar' ty')
go_pred (ClassP c tys) = do tys' <- mapM go tys
; case cts of
Flexi -> unbound_var_fn tyvar
Indirect ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty }
-
--- Zonk the kind of a non-TC tyvar in case it is a coercion variable
--- (their kind contains types).
-zonkTyVar :: (TcTyVar -> TcM Type) -- What to do for a TcTyVar
- -> TyVar -> TcM TyVar
-zonkTyVar zonk_tc_tyvar tv
- | isCoVar tv
- = do { kind <- zonkType zonk_tc_tyvar (tyVarKind tv)
- ; return $ setTyVarKind tv kind }
- | otherwise = return tv
\end{code}
warnTc (notNull dups) (dupPredWarn dups)
mapM_ (check_pred_ty dflags ctxt) theta
where
- (_,dups) = removeDups tcCmpPred theta
+ (_,dups) = removeDups cmpPred theta
-------------------------
check_pred_ty :: DynFlags -> SourceTyCtxt -> PredType -> TcM ()
ambigErr :: PredType -> SDoc
ambigErr pred
- = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPred pred),
+ = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPredTy pred),
nest 2 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$
ptext (sLit "must be reachable from the type after the '=>'"))]
\end{code}
2 (ppr pred)
badPredTyErr, eqPredTyErr, predTyVarErr :: PredType -> SDoc
-badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPred pred
-eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPred pred
+badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPredTy pred
+eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPredTy pred
$$
parens (ptext (sLit "Use -XTypeFamilies to permit this"))
predTyVarErr pred = sep [ptext (sLit "Non type-variable argument"),
- nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)]
+ nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)]
dupPredWarn :: [[PredType]] -> SDoc
-dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
+dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPredTy (map head dups)
arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc
arityErr kind name n m
predUndecErr :: PredType -> SDoc -> SDoc
predUndecErr pred msg = sep [msg,
- nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)]
+ nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)]
nomoreMsg, smallerMsg, undecidableMsg :: SDoc
nomoreMsg = ptext (sLit "Variable occurs more often in a constraint than in the instance head")
TcMatches: Typecheck some @Matches@
\begin{code}
+{-# OPTIONS_GHC -w #-} -- debugging
module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
- TcMatchCtxt(..),
- tcStmts, tcDoStmts, tcBody,
- tcDoStmt, tcMDoStmt, tcGuardStmt
+ TcMatchCtxt(..), TcStmtChecker,
+ tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
+ tcDoStmt, tcGuardStmt
) where
-import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcCheckId,
+import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId,
tcMonoExpr, tcMonoExprNC, tcPolyExpr )
import HsSyn
+import BasicTypes
import TcRnMonad
import TcEnv
import TcPat
import Id
import TyCon
import TysPrim
-import Coercion ( mkSymCoI )
+import Coercion ( isReflCo, mkSymCo )
import Outputable
-import BasicTypes ( Arity )
import Util
import SrcLoc
import FastString
+-- Create chunkified tuple tybes for monad comprehensions
+import MkCore
+
import Control.Monad
#include "HsVersions.h"
matchFunTys herald arity res_ty thing_inside
= do { (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty
; res <- thing_inside pat_tys res_ty
- ; return (coiToHsWrapper (mkSymCoI coi), res) }
+ ; return (coToHsWrapper (mkSymCo coi), res) }
\end{code}
%************************************************************************
tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId)
tcGRHS ctxt res_ty (GRHS guards rhs)
- = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
+ = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
mc_body ctxt rhs
; return (GRHS guards' rhs') }
where
\begin{code}
tcDoStmts :: HsStmtContext Name
-> [LStmt Name]
- -> LHsExpr Name
-> TcRhoType
-> TcM (HsExpr TcId) -- Returns a HsDo
-tcDoStmts ListComp stmts body res_ty
+tcDoStmts ListComp stmts res_ty
= do { (coi, elt_ty) <- matchExpectedListTy res_ty
- ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
- elt_ty $
- tcBody body
- ; return $ mkHsWrapCoI coi
- (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
+ ; let list_ty = mkListTy elt_ty
+ ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty
+ ; return $ mkHsWrapCo coi (HsDo ListComp stmts' list_ty) }
-tcDoStmts PArrComp stmts body res_ty
+tcDoStmts PArrComp stmts res_ty
= do { (coi, elt_ty) <- matchExpectedPArrTy res_ty
- ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
- elt_ty $
- tcBody body
- ; return $ mkHsWrapCoI coi
- (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
+ ; let parr_ty = mkPArrTy elt_ty
+ ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty
+ ; return $ mkHsWrapCo coi (HsDo PArrComp stmts' parr_ty) }
+
+tcDoStmts DoExpr stmts res_ty
+ = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
+ ; return (HsDo DoExpr stmts' res_ty) }
-tcDoStmts DoExpr stmts body res_ty
- = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $
- tcBody body
- ; return (HsDo DoExpr stmts' body' res_ty) }
+tcDoStmts MDoExpr stmts res_ty
+ = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
+ ; return (HsDo MDoExpr stmts' res_ty) }
-tcDoStmts MDoExpr stmts body res_ty
- = do { (stmts', body') <- tcStmts MDoExpr tcDoStmt stmts res_ty $
- tcBody body
- ; return (HsDo MDoExpr stmts' body' res_ty) }
+tcDoStmts MonadComp stmts res_ty
+ = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
+ ; return (HsDo MonadComp stmts' res_ty) }
-tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
+tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
tcBody body res_ty
-> TcStmtChecker -- NB: higher-rank type
-> [LStmt Name]
-> TcRhoType
- -> (TcRhoType -> TcM thing)
- -> TcM ([LStmt TcId], thing)
+ -> TcM [LStmt TcId]
+tcStmts ctxt stmt_chk stmts res_ty
+ = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
+ const (return ())
+ ; return stmts' }
+
+tcStmtsAndThen :: HsStmtContext Name
+ -> TcStmtChecker -- NB: higher-rank type
+ -> [LStmt Name]
+ -> TcRhoType
+ -> (TcRhoType -> TcM thing)
+ -> TcM ([LStmt TcId], thing)
-- Note the higher-rank type. stmt_chk is applied at different
-- types in the equations for tcStmts
-tcStmts _ _ [] res_ty thing_inside
+tcStmtsAndThen _ _ [] res_ty thing_inside
= do { thing <- thing_inside res_ty
; return ([], thing) }
-- LetStmts are handled uniformly, regardless of context
-tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
+tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
= do { (binds', (stmts',thing)) <- tcLocalBinds binds $
- tcStmts ctxt stmt_chk stmts res_ty thing_inside
+ tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
; return (L loc (LetStmt binds') : stmts', thing) }
-- For the vanilla case, handle the location-setting part
-tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
+tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
= do { (stmt', (stmts', thing)) <-
- setSrcSpan loc $
- addErrCtxt (pprStmtInCtxt ctxt stmt) $
- stmt_chk ctxt stmt res_ty $ \ res_ty' ->
- popErrCtxt $
- tcStmts ctxt stmt_chk stmts res_ty' $
+ setSrcSpan loc $
+ addErrCtxt (pprStmtInCtxt ctxt stmt) $
+ stmt_chk ctxt stmt res_ty $ \ res_ty' ->
+ popErrCtxt $
+ tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
thing_inside
; return (L loc stmt' : stmts', thing) }
---------------------------------
--- Pattern guards
+---------------------------------------------------
+-- Pattern guards
+---------------------------------------------------
+
tcGuardStmt :: TcStmtChecker
-tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
+tcGuardStmt _ (ExprStmt guard _ _ _) res_ty thing_inside
= do { guard' <- tcMonoExpr guard boolTy
; thing <- thing_inside res_ty
- ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
+ ; return (ExprStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) }
tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
= pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
---------------------------------
--- List comprehensions and PArrays
+---------------------------------------------------
+-- List comprehensions and PArrays
+-- (no rebindable syntax)
+---------------------------------------------------
+
+-- Dealt with separately, rather than by tcMcStmt, because
+-- a) PArr isn't (yet) an instance of Monad, so the generality seems overkill
+-- b) We have special desugaring rules for list comprehensions,
+-- which avoid creating intermediate lists. They in turn
+-- assume that the bind/return operations are the regular
+-- polymorphic ones, and in particular don't have any
+-- coercion matching stuff in them. It's hard to avoid the
+-- potential for non-trivial coercions in tcMcStmt
tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
-> TcStmtChecker
+tcLcStmt _ _ (LastStmt body _) elt_ty thing_inside
+ = do { body' <- tcMonoExprNC body elt_ty
+ ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
+ ; return (LastStmt body' noSyntaxExpr, thing) }
+
-- A generator, pat <- rhs
-tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
+tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside
= do { pat_ty <- newFlexiTyVarTy liftedTypeKind
; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
- thing_inside res_ty
+ thing_inside elt_ty
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-- A boolean guard
-tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
+tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside
= do { rhs' <- tcMonoExpr rhs boolTy
- ; thing <- thing_inside res_ty
- ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
+ ; thing <- thing_inside elt_ty
+ ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
+
+-- ParStmt: See notes with tcMcStmt
+tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
+ = do { (pairs', thing) <- loop bndr_stmts_s
+ ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) }
+ where
+ -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
+ loop [] = do { thing <- thing_inside elt_ty
+ ; return ([], thing) } -- matching in the branches
+
+ loop ((stmts, names) : pairs)
+ = do { (stmts', (ids, pairs', thing))
+ <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
+ do { ids <- tcLookupLocalIds names
+ ; (pairs', thing) <- loop pairs
+ ; return (ids, pairs', thing) }
+ ; return ( (stmts', ids) : pairs', thing ) }
+
+tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
+ , trS_bndrs = bindersMap
+ , trS_by = by, trS_using = using }) elt_ty thing_inside
+ = do { let (bndr_names, n_bndr_names) = unzip bindersMap
+ unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
+ -- The inner 'stmts' lack a LastStmt, so the element type
+ -- passed in to tcStmtsAndThen is never looked at
+ ; (stmts', (bndr_ids, by'))
+ <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
+ { by' <- case by of
+ Nothing -> return Nothing
+ Just e -> do { e_ty <- tcInferRho e; return (Just e_ty) }
+ ; bndr_ids <- tcLookupLocalIds bndr_names
+ ; return (bndr_ids, by') }
+
+ ; let m_app ty = mkTyConApp m_tc [ty]
+
+ --------------- Typecheck the 'using' function -------------
+ -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm)
+ -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm)
+
+ -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm
+ ; let n_app = case form of
+ ThenForm -> (\ty -> ty)
+ _ -> m_app
+
+ by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present
+ by_arrow = case by' of
+ Nothing -> \ty -> ty
+ Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty
+
+ tup_ty = mkBigCoreVarTupTy bndr_ids
+ poly_arg_ty = m_app alphaTy
+ poly_res_ty = m_app (n_app alphaTy)
+ using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $
+ poly_arg_ty `mkFunTy` poly_res_ty
+
+ ; using' <- tcPolyExpr using using_poly_ty
+ ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using'
+
+ -- 'stmts' returns a result of type (m1_ty tuple_ty),
+ -- typically something like [(Int,Bool,Int)]
+ -- We don't know what tuple_ty is yet, so we use a variable
+ ; let mk_n_bndr :: Name -> TcId -> TcId
+ mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))
+
+ -- Ensure that every old binder of type `b` is linked up with its
+ -- new binder which should have type `n b`
+ -- See Note [GroupStmt binder map] in HsExpr
+ n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
+ bindersMap' = bndr_ids `zip` n_bndr_ids
+
+ -- Type check the thing in the environment with
+ -- these new binders and return the result
+ ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
+
+ ; return (emptyTransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
+ , trS_by = fmap fst by', trS_using = final_using
+ , trS_form = form }, thing) }
+
+tcLcStmt _ _ stmt _ _
+ = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
+
+
+---------------------------------------------------
+-- Monad comprehensions
+-- (supports rebindable syntax)
+---------------------------------------------------
+
+tcMcStmt :: TcStmtChecker
+
+tcMcStmt _ (LastStmt body return_op) res_ty thing_inside
+ = do { a_ty <- newFlexiTyVarTy liftedTypeKind
+ ; return_op' <- tcSyntaxOp MCompOrigin return_op
+ (a_ty `mkFunTy` res_ty)
+ ; body' <- tcMonoExprNC body a_ty
+ ; thing <- thing_inside (panic "tcMcStmt: thing_inside")
+ ; return (LastStmt body' return_op', thing) }
+
+-- Generators for monad comprehensions ( pat <- rhs )
+--
+-- [ body | q <- gen ] -> gen :: m a
+-- q :: a
+--
+
+tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
+ = do { rhs_ty <- newFlexiTyVarTy liftedTypeKind
+ ; pat_ty <- newFlexiTyVarTy liftedTypeKind
+ ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+
+ -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
+ ; bind_op' <- tcSyntaxOp MCompOrigin bind_op
+ (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
+
+ -- If (but only if) the pattern can fail, typecheck the 'fail' operator
+ ; fail_op' <- if isIrrefutableHsPat pat
+ then return noSyntaxExpr
+ else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty)
+
+ ; rhs' <- tcMonoExprNC rhs rhs_ty
+ ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
+ thing_inside new_res_ty
+
+ ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
+
+-- Boolean expressions.
+--
+-- [ body | stmts, expr ] -> expr :: m Bool
+--
+tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside
+ = do { -- Deal with rebindable syntax:
+ -- guard_op :: test_ty -> rhs_ty
+ -- then_op :: rhs_ty -> new_res_ty -> res_ty
+ -- Where test_ty is, for example, Bool
+ test_ty <- newFlexiTyVarTy liftedTypeKind
+ ; rhs_ty <- newFlexiTyVarTy liftedTypeKind
+ ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+ ; rhs' <- tcMonoExpr rhs test_ty
+ ; guard_op' <- tcSyntaxOp MCompOrigin guard_op
+ (mkFunTy test_ty rhs_ty)
+ ; then_op' <- tcSyntaxOp MCompOrigin then_op
+ (mkFunTys [rhs_ty, new_res_ty] res_ty)
+ ; thing <- thing_inside new_res_ty
+ ; return (ExprStmt rhs' then_op' guard_op' rhs_ty, thing) }
+
+-- Grouping statements
+--
+-- [ body | stmts, then group by e ]
+-- -> e :: t
+-- [ body | stmts, then group by e using f ]
+-- -> e :: t
+-- f :: forall a. (a -> t) -> m a -> m (m a)
+-- [ body | stmts, then group using f ]
+-- -> f :: forall a. m a -> m (m a)
+
+-- We type [ body | (stmts, group by e using f), ... ]
+-- f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
+--
+-- We type the functions as follows:
+-- f <optional by> :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm)
+-- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm)
+-- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm)
+-- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm)
+--
+tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
+ , trS_by = by, trS_using = using, trS_form = form
+ , trS_ret = return_op, trS_bind = bind_op
+ , trS_fmap = fmap_op }) res_ty thing_inside
+ = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
+ ; m1_ty <- newFlexiTyVarTy star_star_kind
+ ; m2_ty <- newFlexiTyVarTy star_star_kind
+ ; tup_ty <- newFlexiTyVarTy liftedTypeKind
+ ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any)
+
+ -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm
+ ; n_app <- case form of
+ ThenForm -> return (\ty -> ty)
+ _ -> do { n_ty <- newFlexiTyVarTy star_star_kind
+ ; return (n_ty `mkAppTy`) }
+ ; let by_arrow :: Type -> Type
+ -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present)
+ -- or res ('by' absent)
+ by_arrow = case by of
+ Nothing -> \res -> res
+ Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res
+
+ poly_arg_ty = m1_ty `mkAppTy` alphaTy
+ using_arg_ty = m1_ty `mkAppTy` tup_ty
+ poly_res_ty = m2_ty `mkAppTy` n_app alphaTy
+ using_res_ty = m2_ty `mkAppTy` n_app tup_ty
+ using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $
+ poly_arg_ty `mkFunTy` poly_res_ty
+
+ -- 'stmts' returns a result of type (m1_ty tuple_ty),
+ -- typically something like [(Int,Bool,Int)]
+ -- We don't know what tuple_ty is yet, so we use a variable
+ ; let (bndr_names, n_bndr_names) = unzip bindersMap
+ ; (stmts', (bndr_ids, by', return_op')) <-
+ tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts using_arg_ty $ \res_ty' -> do
+ { by' <- case by of
+ Nothing -> return Nothing
+ Just e -> do { e' <- tcMonoExpr e by_e_ty; return (Just e') }
+
+ -- Find the Ids (and hence types) of all old binders
+ ; bndr_ids <- tcLookupLocalIds bndr_names
+
+ -- 'return' is only used for the binders, so we know its type.
+ -- return :: (a,b,c,..) -> m (a,b,c,..)
+ ; return_op' <- tcSyntaxOp MCompOrigin return_op $
+ (mkBigCoreVarTupTy bndr_ids) `mkFunTy` res_ty'
+
+ ; return (bndr_ids, by', return_op') }
+
+ --------------- Typecheck the 'bind' function -------------
+ -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
+ ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+ ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
+ using_res_ty `mkFunTy` (n_app tup_ty `mkFunTy` new_res_ty)
+ `mkFunTy` res_ty
+
+ --------------- Typecheck the 'fmap' function -------------
+ ; fmap_op' <- case form of
+ ThenForm -> return noSyntaxExpr
+ _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
+ mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $
+ (alphaTy `mkFunTy` betaTy)
+ `mkFunTy` (n_app alphaTy)
+ `mkFunTy` (n_app betaTy)
+
+ --------------- Typecheck the 'using' function -------------
+ -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
+
+ ; using' <- tcPolyExpr using using_poly_ty
+ ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using'
+
+ --------------- Bulding the bindersMap ----------------
+ ; let mk_n_bndr :: Name -> TcId -> TcId
+ mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id))
+
+ -- Ensure that every old binder of type `b` is linked up with its
+ -- new binder which should have type `n b`
+ -- See Note [GroupStmt binder map] in HsExpr
+ n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
+ bindersMap' = bndr_ids `zip` n_bndr_ids
+
+ -- Type check the thing in the environment with
+ -- these new binders and return the result
+ ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside new_res_ty)
+
+ ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
+ , trS_by = by', trS_using = final_using
+ , trS_ret = return_op', trS_bind = bind_op'
+ , trS_fmap = fmap_op', trS_form = form }, thing) }
-- A parallel set of comprehensions
-- [ (g x, h x) | ... ; let g v = ...
-- ensure that g,h and x,y don't duplicate, and simply grow the environment.
-- So the binders of the first parallel group will be in scope in the second
-- group. But that's fine; there's no shadowing to worry about.
-
-tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
- = do { (pairs', thing) <- loop bndr_stmts_s
- ; return (ParStmt pairs', thing) }
- where
- -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
- loop [] = do { thing <- thing_inside elt_ty
- ; return ([], thing) } -- matching in the branches
-
- loop ((stmts, names) : pairs)
- = do { (stmts', (ids, pairs', thing))
- <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
- do { ids <- tcLookupLocalIds names
- ; (pairs', thing) <- loop pairs
- ; return (ids, pairs', thing) }
- ; return ( (stmts', ids) : pairs', thing ) }
-
-tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr) elt_ty thing_inside = do
- (stmts', (binders', usingExpr', maybeByExpr', thing)) <-
- tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
- let alphaListTy = mkTyConApp m_tc [alphaTy]
-
- (usingExpr', maybeByExpr') <-
- case maybeByExpr of
- Nothing -> do
- -- We must validate that usingExpr :: forall a. [a] -> [a]
- let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy)
- usingExpr' <- tcPolyExpr usingExpr using_ty
- return (usingExpr', Nothing)
- Just byExpr -> do
- -- We must infer a type such that e :: t and then check that
- -- usingExpr :: forall a. (a -> t) -> [a] -> [a]
- (byExpr', tTy) <- tcInferRhoNC byExpr
- let using_ty = mkForAllTy alphaTyVar $
- (alphaTy `mkFunTy` tTy)
- `mkFunTy` alphaListTy `mkFunTy` alphaListTy
- usingExpr' <- tcPolyExpr usingExpr using_ty
- return (usingExpr', Just byExpr')
-
- binders' <- tcLookupLocalIds binders
- thing <- thing_inside elt_ty'
-
- return (binders', usingExpr', maybeByExpr', thing)
-
- return (TransformStmt stmts' binders' usingExpr' maybeByExpr', thing)
-
-tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside
- = do { let (bndr_names, list_bndr_names) = unzip bindersMap
-
- ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <-
- tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do
- (by', using_ty) <-
- case by of
- Nothing -> -- check that using :: forall a. [a] -> [[a]]
- return (Nothing, mkForAllTy alphaTyVar $
- alphaListTy `mkFunTy` alphaListListTy)
-
- Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]]
- -- where by :: t
- do { (by_e', t_ty) <- tcInferRhoNC by_e
- ; return (Just by_e', mkForAllTy alphaTyVar $
- (alphaTy `mkFunTy` t_ty)
- `mkFunTy` alphaListTy
- `mkFunTy` alphaListListTy) }
- -- Find the Ids (and hence types) of all old binders
- bndr_ids <- tcLookupLocalIds bndr_names
-
- return (bndr_ids, by', using_ty, elt_ty')
-
- -- Ensure that every old binder of type b is linked up with
- -- its new binder which should have type [b]
- ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids
- bindersMap' = bndr_ids `zip` list_bndr_ids
- -- See Note [GroupStmt binder map] in HsExpr
-
- ; using' <- case using of
- Left e -> do { e' <- tcPolyExpr e using_ty; return (Left e') }
- Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) }
-
- -- Type check the thing in the environment with
- -- these new binders and return the result
- ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty')
- ; return (GroupStmt stmts' bindersMap' by' using', thing) }
- where
- alphaListTy = mkTyConApp m_tc [alphaTy]
- alphaListListTy = mkTyConApp m_tc [alphaListTy]
-
- mk_list_bndr :: Name -> TcId -> TcId
- mk_list_bndr list_bndr_name bndr_id
- = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id])
-
-tcLcStmt _ _ stmt _ _
- = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
-
---------------------------------
--- Do-notation
--- The main excitement here is dealing with rebindable syntax
+--
+-- Note: The `mzip` function will get typechecked via:
+--
+-- ParStmt [st1::t1, st2::t2, st3::t3]
+--
+-- mzip :: m st1
+-- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call
+-- -> m (st1, (st2, st3))
+--
+tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside
+ = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
+ ; m_ty <- newFlexiTyVarTy star_star_kind
+
+ ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $
+ (m_ty `mkAppTy` alphaTy)
+ `mkFunTy`
+ (m_ty `mkAppTy` betaTy)
+ `mkFunTy`
+ (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
+ ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
+
+ ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $
+ mkForAllTy alphaTyVar $
+ alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy)
+
+ ; (pairs', thing) <- loop m_ty bndr_stmts_s
+
+ -- Typecheck bind:
+ ; let tys = map (mkBigCoreVarTupTy . snd) pairs'
+ tuple_ty = mk_tuple_ty tys
+
+ ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
+ (m_ty `mkAppTy` tuple_ty)
+ `mkFunTy` (tuple_ty `mkFunTy` res_ty)
+ `mkFunTy` res_ty
+
+ ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) }
+
+ where
+ mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
+
+ -- loop :: Type -- m_ty
+ -- -> [([LStmt Name], [Name])]
+ -- -> TcM ([([LStmt TcId], [TcId])], thing)
+ loop _ [] = do { thing <- thing_inside res_ty
+ ; return ([], thing) } -- matching in the branches
+
+ loop m_ty ((stmts, names) : pairs)
+ = do { -- type dummy since we don't know all binder types yet
+ ty_dummy <- newFlexiTyVarTy liftedTypeKind
+ ; (stmts', (ids, pairs', thing))
+ <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' ->
+ do { ids <- tcLookupLocalIds names
+ ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreVarTupTy ids
+
+ ; check_same m_tup_ty res_ty'
+ ; check_same m_tup_ty ty_dummy
+
+ ; (pairs', thing) <- loop m_ty pairs
+ ; return (ids, pairs', thing) }
+ ; return ( (stmts', ids) : pairs', thing ) }
+
+ -- Check that the types match up.
+ -- This is a grevious hack. They always *will* match
+ -- If (>>=) and (>>) are polymorpic in the return type,
+ -- but we don't have any good way to incorporate the coercion
+ -- so for now we just check that it's the identity
+ check_same actual expected
+ = do { coi <- unifyType actual expected
+ ; unless (isReflCo coi) $
+ failWithMisMatch [UnifyOrigin { uo_expected = expected
+ , uo_actual = actual }] }
+
+tcMcStmt _ stmt _ _
+ = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
+
+
+---------------------------------------------------
+-- Do-notation
+-- (supports rebindable syntax)
+---------------------------------------------------
tcDoStmt :: TcStmtChecker
+tcDoStmt _ (LastStmt body _) res_ty thing_inside
+ = do { body' <- tcMonoExprNC body res_ty
+ ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
+ ; return (LastStmt body' noSyntaxExpr, thing) }
+
tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
= do { -- Deal with rebindable syntax:
-- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
-tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
+tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside
= do { -- Deal with rebindable syntax;
-- (>>) :: rhs_ty -> new_res_ty -> res_ty
-- See also Note [Treat rebindable syntax first]
; rhs' <- tcMonoExprNC rhs rhs_ty
; thing <- thing_inside new_res_ty
- ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
+ ; return (ExprStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }
tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
, recS_rec_ids = rec_names, recS_ret_fn = ret_op
; tcExtendIdEnv tup_ids $ do
{ stmts_ty <- newFlexiTyVarTy liftedTypeKind
; (stmts', (ret_op', tup_rets))
- <- tcStmts ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
+ <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty ->
do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
-- Unify the types of the "final" Ids (which may
-- be polymorphic) with those of "knot-tied" Ids
(mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
; thing <- thing_inside new_res_ty
--- ; lie_binds <- bindLocalMethods lie tup_ids
; let rec_ids = takeList rec_names tup_ids
; later_ids <- tcLookupLocalIds later_names
; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
, recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
- , recS_rec_rets = tup_rets }, thing)
+ , recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing)
}}
tcDoStmt _ stmt _ _
Otherwise the error shows up when cheking the rebindable syntax, and
the expected/inferred stuff is back to front (see Trac #3613).
-\begin{code}
---------------------------------
--- Mdo-notation
--- The distinctive features here are
--- (a) RecStmts, and
--- (b) no rebindable syntax
-
-tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
- -> TcStmtChecker
-tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
- = do { (rhs', pat_ty) <- tc_rhs rhs
- ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
- thing_inside res_ty
- ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
-
-tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
- = do { (rhs', elt_ty) <- tc_rhs rhs
- ; thing <- thing_inside res_ty
- ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
-
-tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
- , recS_rec_ids = recNames }) res_ty thing_inside
- = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
- ; let rec_ids = zipWith mkLocalId recNames rec_tys
- ; tcExtendIdEnv rec_ids $ do
- { (stmts', (later_ids, rec_rets))
- <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' ->
- -- ToDo: res_ty not really right
- do { rec_rets <- zipWithM tcCheckId recNames rec_tys
- ; later_ids <- tcLookupLocalIds laterNames
- ; return (later_ids, rec_rets) }
-
- ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
- -- NB: The rec_ids for the recursive things
- -- already scope over this part. This binding may shadow
- -- some of them with polymorphic things with the same Name
- -- (see note [RecStmt] in HsExpr)
-
- ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets, thing)
- }}
-
-tcMDoStmt _ _ stmt _ _
- = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
-\end{code}
-
%************************************************************************
%* *
import BasicTypes hiding (SuccessFlag(..))
import DynFlags
import SrcLoc
-import ErrUtils
import Util
import Outputable
import FastString
instance Outputable TcSigInfo where
ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
- = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrow theta <+> ppr tau
+ = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrowTy theta <+> ppr tau
\end{code}
Note [sig_tau may be polymorphic]
%************************************************************************
\begin{code}
-tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (CoercionI, TcId)
+tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (Coercion, TcId)
-- (coi, xp) = tcPatBndr penv x pat_ty
-- Then coi : pat_ty ~ typeof(xp)
--
| otherwise
= do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty
- ; return (IdCo pat_ty, bndr_id) }
+ ; return (mkReflCo pat_ty, bndr_id) }
tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty
= do { bndr <- mkLocalBinder bndr_name pat_ty
- ; return (IdCo pat_ty, bndr) }
+ ; return (mkReflCo pat_ty, bndr) }
------------
newSigLetBndr :: LetBndrSpec -> Name -> TcSigInfo -> TcM TcId
-> TcM a
-> TcM (LPat TcId, a)
tc_lpat (L span pat) pat_ty penv thing_inside
- = setSrcSpan span $
- maybeAddErrCtxt (patCtxt pat) $
- do { (pat', res) <- tc_pat penv pat pat_ty thing_inside
+ = setSrcSpan span $
+ do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty)
+ thing_inside
; return (L span pat', res) }
tc_lpats :: PatEnv
tc_pat penv (VarPat name) pat_ty thing_inside
= do { (coi, id) <- tcPatBndr penv name pat_ty
; res <- tcExtendIdEnv1 name id thing_inside
- ; return (mkHsWrapPatCoI coi (VarPat id) pat_ty, res) }
+ ; return (mkHsWrapPatCo coi (VarPat id) pat_ty, res) }
tc_pat penv (ParPat pat) pat_ty thing_inside
= do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
-- perhaps be fixed, but only with a bit more work.
--
-- If you fix it, don't forget the bindInstsOfPatIds!
- ; return (mkHsWrapPatCoI coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) }
+ ; return (mkHsWrapPatCo coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) }
tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside
= do { checkUnboxedTuple overall_pat_ty $
-- pattern must have pat_ty
; (pat', res) <- tc_lpat pat pat_ty penv thing_inside
- ; return (ViewPat (mkLHsWrapCoI expr_coi expr') pat' overall_pat_ty, res) }
+ ; return (ViewPat (mkLHsWrapCo expr_coi expr') pat' overall_pat_ty, res) }
-- Type signatures in patterns
-- See Note [Pattern coercions] below
; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) }
-tc_pat _ pat@(TypePat _) _ _
- = failWithTc (badTypePat pat)
-
------------------------
-- Lists, tuples, arrays
tc_pat penv (ListPat pats _) pat_ty thing_inside
; coi <- unifyPatType lit_ty pat_ty
-- coi is of kind: pat_ty ~ lit_ty
; res <- thing_inside
- ; return ( mkHsWrapPatCoI coi (LitPat simple_lit) pat_ty
+ ; return ( mkHsWrapPatCo coi (LitPat simple_lit) pat_ty
, res) }
------------------------
; instStupidTheta orig [mkClassPred icls [pat_ty']]
; res <- tcExtendIdEnv1 name bndr_id thing_inside
- ; return (mkHsWrapPatCoI coi pat' pat_ty, res) }
+ ; return (mkHsWrapPatCo coi pat' pat_ty, res) }
tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut
----------------
-unifyPatType :: TcType -> TcType -> TcM CoercionI
+unifyPatType :: TcType -> TcType -> TcM Coercion
-- In patterns we want a coercion from the
-- context type (expected) to the actual pattern type
-- But we don't want to reverse the args to unifyType because
-- that controls the actual/expected stuff in error messages
unifyPatType actual_ty expected_ty
= do { coi <- unifyType actual_ty expected_ty
- ; return (mkSymCoI coi) }
+ ; return (mkSymCo coi) }
\end{code}
Note [Hopping the LIE in lazy patterns]
= do { data_con <- tcLookupDataCon con_name
; let tycon = dataConTyCon data_con
-- For data families this is the representation tycon
- (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _)
+ (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
= dataConFullSig data_con
-- Instantiate the constructor type variables [a->ty]
tenv = zipTopTvSubst (univ_tvs ++ ex_tvs)
(ctxt_res_tys ++ mkTyVarTys ex_tvs')
arg_tys' = substTys tenv arg_tys
- full_theta = eq_theta ++ dict_theta
- ; if null ex_tvs && null eq_spec && null full_theta
+ ; if null ex_tvs && null eq_spec && null theta
then do { -- The common case; no class bindings etc
-- (see Note [Arrows and patterns])
(arg_pats', res) <- tcConArgs data_con arg_tys'
else do -- The general case, with existential,
-- and local equality constraints
- { let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
- theta' = substTheta tenv (eq_preds ++ full_theta)
+ { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta)
-- order is *important* as we generate the list of
-- dictionary binders from theta'
no_equalities = not (any isEqPred theta')
} }
----------------------------
-matchExpectedPatTy :: (TcRhoType -> TcM (CoercionI, a))
+matchExpectedPatTy :: (TcRhoType -> TcM (Coercion, a))
-> TcRhoType -> TcM (HsWrapper, a)
-- See Note [Matching polytyped patterns]
-- Returns a wrapper : pat_ty ~ inner_ty
matchExpectedPatTy inner_match pat_ty
| null tvs && null theta
= do { (coi, res) <- inner_match pat_ty
- ; return (coiToHsWrapper (mkSymCoI coi), res) }
+ ; return (coToHsWrapper (mkSymCo coi), res) }
-- The Sym is because the inner_match returns a coercion
-- that is the other way round to matchExpectedPatTy
| otherwise
= do { (_, tys, subst) <- tcInstTyVars tvs
; wrap1 <- instCall PatOrigin tys (substTheta subst theta)
- ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (substTy subst tau)
+ ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (TcType.substTy subst tau)
; return (wrap2 <.> wrap1 , arg_tys) }
where
(tvs, theta, tau) = tcSplitSigmaTy pat_ty
matchExpectedConTy :: TyCon -- The TyCon that this data
-- constructor actually returns
-> TcRhoType -- The type of the pattern
- -> TcM (CoercionI, [TcSigmaType])
+ -> TcM (Coercion, [TcSigmaType])
-- See Note [Matching constructor patterns]
-- Returns a coercion : T ty1 ... tyn ~ pat_ty
-- This is the same way round as matchExpectedListTy etc
; coi1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty
-- coi1 : T (ty1,ty2) ~ pat_ty
- ; let coi2 = ACo (mkTyConApp co_tc tys)
+ ; let coi2 = mkAxInstCo co_tc tys
-- coi2 : T (ty1,ty2) ~ T7 ty1 ty2
- ; return (mkTransCoI (mkSymCoI coi2) coi1, tys) }
+ ; return (mkTransCo (mkSymCo coi2) coi1, tys) }
| otherwise
= matchExpectedTyConApp data_tc pat_ty
-- coi : T tys ~ pat_ty
\end{code}
-Noate [
Note [Matching constructor patterns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose (coi, tys) = matchExpectedConType data_tc pat_ty
-}
\begin{code}
-patCtxt :: Pat Name -> Maybe Message -- Not all patterns are worth pushing a context
-patCtxt (VarPat _) = Nothing
-patCtxt (ParPat _) = Nothing
-patCtxt (AsPat _ _) = Nothing
-patCtxt pat = Just (hang (ptext (sLit "In the pattern:"))
- 2 (ppr pat))
+maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b
+-- Not all patterns are worth pushing a context
+maybeWrapPatCtxt pat tcm thing_inside
+ | not (worth_wrapping pat) = tcm thing_inside
+ | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside
+ -- Remember to pop before doing thing_inside
+ where
+ worth_wrapping (VarPat {}) = False
+ worth_wrapping (ParPat {}) = False
+ worth_wrapping (AsPat {}) = False
+ worth_wrapping _ = True
+ msg = hang (ptext (sLit "In the pattern:")) 2 (ppr pat)
-----------------------------------------------
checkExistentials :: [TyVar] -> PatEnv -> TcM ()
= hang (ptext (sLit "Illegal polymorphic type signature in pattern:"))
2 (ppr sig_ty)
-badTypePat :: Pat Name -> SDoc
-badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat
-
lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM ()
lazyUnliftedPatErr pat
= failWithTc $
import NameEnv
import NameSet
import TyCon
-import TysPrim
import SrcLoc
import HscTypes
import ListSetOps
-- interfaces, so that their rules and instance decls will be
-- found.
; loadOrphanModules (imp_orphs imports) False
- ; loadOrphanModules (imp_finsts imports) True
-- Check type-familily consistency
; traceRn (text "rn1: checking family instance consistency")
-- any mutually recursive types are done right
-- Just discard the auxiliary bindings; they are generated
-- only for Haskell source code, and should already be in Core
- (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ;
+ (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
setGblEnv tcg_env $ do {
-- Make the new type env available to stuff slurped from interface files
-- Typecheck type/class decls
; traceTc "Tc2" empty
- ; (tcg_env, aux_binds, dm_ids)
+ ; (tcg_env, aux_binds)
<- tcTyAndClassDecls emptyModDetails tycl_decls
- ; setGblEnv tcg_env $
- tcExtendIdEnv dm_ids $ do {
+ ; setGblEnv tcg_env $ do {
-- Typecheck instance decls
-- Family instance declarations are rejected here
check_inst boot_inst
= case [dfun | inst <- local_insts,
let dfun = instanceDFunId inst,
- idType dfun `tcEqType` boot_inst_ty ] of
+ idType dfun `eqType` boot_inst_ty ] of
[] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
, text "boot_inst" <+> ppr boot_inst
, text "boot_inst_ty" <+> ppr boot_inst_ty
checkBootDecl (AnId id1) (AnId id2)
= ASSERT(id1 == id2)
- (idType id1 `tcEqType` idType id2)
+ (idType id1 `eqType` idType id2)
checkBootDecl (ATyCon tc1) (ATyCon tc2)
= checkBootTyCon tc1 tc2
eqSig (id1, def_meth1) (id2, def_meth2)
= idName id1 == idName id2 &&
- tcEqTypeX env op_ty1 op_ty2 &&
+ eqTypeX env op_ty1 op_ty2 &&
def_meth1 == def_meth2
where
(_, rho_ty1) = splitForAllTys (idType id1)
op_ty2 = funResultTy rho_ty2
eqFD (as1,bs1) (as2,bs2) =
- eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
- eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
+ eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
+ eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2)
in
eqListBy eqFD clas_fds1 clas_fds2 &&
(null sc_theta1 && null op_stuff1 && null ats1
|| -- Above tests for an "abstract" class
- eqListBy (tcEqPredX env) sc_theta1 sc_theta2 &&
+ eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
eqListBy eqSig op_stuff1 op_stuff2 &&
eqListBy checkBootTyCon ats1 ats2)
eqSynRhs SynFamilyTyCon SynFamilyTyCon
= True
eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
- = tcEqTypeX env t1 t2
+ = eqTypeX env t1 t2
eqSynRhs _ _ = False
in
equalLength tvs1 tvs2 &&
| isAlgTyCon tc1 && isAlgTyCon tc2
= ASSERT(tc1 == tc2)
eqKind (tyConKind tc1) (tyConKind tc2) &&
- eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
+ eqListBy eqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
| isForeignTyCon tc1 && isForeignTyCon tc2
&& dataConIsInfix c1 == dataConIsInfix c2
&& dataConStrictMarks c1 == dataConStrictMarks c2
&& dataConFieldLabels c1 == dataConFieldLabels c2
- && let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1
- tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2
- env = rnBndrs2 env0 tvs1 tvs2
- in
- equalLength tvs1 tvs2 &&
- eqListBy (tcEqPredX env)
- (dataConEqTheta c1 ++ dataConDictTheta c1)
- (dataConEqTheta c2 ++ dataConDictTheta c2) &&
- eqListBy (tcEqTypeX env)
- (dataConOrigArgTys c1)
- (dataConOrigArgTys c2)
+ && eqType (dataConUserType c1) (dataConUserType c2)
----------------
missingBootThing :: Name -> String -> SDoc
-- The latter come in via tycl_decls
traceTc "Tc2" empty ;
- (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ;
+ (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ;
-- If there are any errors, tcTyAndClassDecls fails here
- setGblEnv tcg_env $
- tcExtendIdEnv dm_ids $ do {
+ setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
-- and import the supporting declarations
setLclTypeEnv tcl_env $ do { -- Environment doesn't change now
-- Second pass over class and instance declarations,
+ -- now using the kind-checked decls
traceTc "Tc6" empty ;
inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
--------------------
mkPlan :: LStmt Name -> TcM PlanResult
-mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt
+mkPlan (L loc (ExprStmt expr _ _ _)) -- An expression typed at the prompt
= do { uniq <- newUnique -- is treated very specially
; let fresh_it = itName uniq
the_bind = L loc $ mkFunBind (L loc fresh_it) matches
bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
(HsVar bindIOName) noSyntaxExpr
print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
- (HsVar thenIOName) placeHolderType
+ (HsVar thenIOName) noSyntaxExpr placeHolderType
-- The plans are:
-- [it <- e; print it] but not if it::()
mkPlan stmt@(L loc (BindStmt {}))
| [v] <- collectLStmtBinders stmt -- One binder, for a bind stmt
= do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
- (HsVar thenIOName) placeHolderType
+ (HsVar thenIOName) noSyntaxExpr placeHolderType
; print_bind_result <- doptM Opt_PrintBindResult
; let print_plan = do
let {
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
- tc_io_stmts stmts = tcStmts GhciStmt tcDoStmt stmts io_ret_ty ;
-
+ tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ;
names = collectLStmtsBinders stmts ;
+ } ;
+
+ -- OK, we're ready to typecheck the stmts
+ traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
+ ((tc_stmts, ids), lie) <- captureConstraints $
+ tc_io_stmts stmts $ \ _ ->
+ mapM tcLookupId names ;
+ -- Look up the names right in the middle,
+ -- where they will all be in scope
+
+ -- Simplify the context
+ traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
+ const_binds <- checkNoErrs (simplifyInteractive lie) ;
+ -- checkNoErrs ensures that the plan fails if context redn fails
- -- mk_return builds the expression
+ traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+ let { -- mk_return builds the expression
-- returnIO @ [()] [coerce () x, .., coerce () z]
--
-- Despite the inconvenience of building the type applications etc,
-- then the type checker would instantiate x..z, and we wouldn't
-- get their *polymorphic* values. (And we'd get ambiguity errs
-- if they were overloaded, since they aren't applied to anything.)
- mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty])
- (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
+ ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
+ (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
- (nlHsVar id)
- } ;
-
- -- OK, we're ready to typecheck the stmts
- traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
- ((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ ->
- mapM tcLookupId names ;
- -- Look up the names right in the middle,
- -- where they will all be in scope
-
- -- Simplify the context
- traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
- const_binds <- checkNoErrs (simplifyInteractive lie) ;
- -- checkNoErrs ensures that the plan fails if context redn fails
-
- traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+ (nlHsVar id) ;
+ stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
+ } ;
return (ids, mkHsDictLet (EvBinds const_binds) $
- noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty))
+ noLoc (HsDo GhciStmt stmts io_ret_ty))
}
\end{code}
-- Now typecheck the expression;
-- it might have a rank-2 type (e.g. :t runST)
-
uniq <- newUnique ;
let { fresh_it = itName uniq } ;
- ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ;
- ((qtvs, dicts, _), lie_top) <- captureConstraints $
- simplifyInfer TopLevel
- False {- No MR for now -}
+ ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ;
+ ((qtvs, dicts, _), lie_top) <- captureConstraints $
+ simplifyInfer TopLevel False {- No MR for now -}
[(fresh_it, res_ty)]
lie ;
-
_ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings
let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
-- Load any orphan-module and family instance-module
-- interfaces, so their instances are visible.
; loadOrphanModules (dep_orphs (mi_deps iface)) False
- ; loadOrphanModules (dep_finsts (mi_deps iface)) True
-- Check that the family instances of all directly loaded
-- modules are consistent.
, ppr_fam_insts fam_insts
, vcat (map ppr rules)
, vcat (map ppr vects)
- , ppr_gen_tycons (typeEnvTyCons type_env)
, ptext (sLit "Dependent modules:") <+>
ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
, ptext (sLit "Dependent packages:") <+>
ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
ppr_tycons fam_insts type_env
- = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons)
+ = vcat [ text "TYPE CONSTRUCTORS"
+ , nest 2 (ppr_tydecls tycons)
+ , text "COERCION AXIOMS"
+ , nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
where
fi_tycons = map famInstTyCon fam_insts
tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
= vcat (map ppr_tycon (sortLe le_sig tycons))
where
le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
- ppr_tycon tycon
- | isCoercionTyCon tycon
- = sep [ptext (sLit "coercion") <+> ppr tycon <+> ppr tvs
- , nest 2 (dcolon <+> pprEqPred (coercionKind (mkTyConApp tycon (mkTyVarTys tvs))))]
- | otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon))
- where
- tvs = take (tyConArity tycon) alphaTyVars
+ ppr_tycon tycon = ppr (tyThingToIfaceDecl (ATyCon tycon))
ppr_rules :: [CoreRule] -> SDoc
ppr_rules [] = empty
ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
nest 2 (pprRules rs),
ptext (sLit "#-}")]
-
-ppr_gen_tycons :: [TyCon] -> SDoc
-ppr_gen_tycons [] = empty
-ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"),
- nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
\end{code}
traceRn = traceOptTcRn Opt_D_dump_rn_trace
traceSplice = traceOptTcRn Opt_D_dump_splices
-
traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
traceIf = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
env { tcl_ctxt = upd ctxt })
--- Conditionally add an error context
-maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a
-maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside
-maybeAddErrCtxt Nothing thing_inside = thing_inside
-
popErrCtxt :: TcM a -> TcM a
popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
-- Tidy the error info, trimming excessive contexts
mkErrInfo env ctxts
+ | opt_PprStyle_Debug -- In -dppr-debug style the output
+ = return empty -- just becomes too voluminous
+ | otherwise
= go 0 env ctxts
where
go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
failIfM msg
= do { env <- getLclEnv
; let full_msg = (if_loc env <> colon) $$ nest 2 msg
- ; liftIO (printErrs (full_msg defaultErrStyle))
+ ; liftIO (printErrs full_msg defaultErrStyle)
; failM }
--------------------
; return Nothing }
}}
where
- print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
+ print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle)
forkM :: SDoc -> IfL a -> IfL a
forkM doc thing_inside
Implication(..),
CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
CtOrigin(..), EqOrigin(..),
- WantedLoc, GivenLoc, pushErrCtxt,
+ WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt,
- SkolemInfo(..),
+ SkolemInfo(..),
- CtFlavor(..), pprFlavorArising, isWanted, isGiven, isDerived,
+ CtFlavor(..), pprFlavorArising, isWanted,
+ isGivenOrSolved, isGiven_maybe,
+ isDerived,
FlavoredEvVar,
-- Pretty printing
import HsSyn
import HscTypes
import Type
+import Id ( evVarPred )
import Class ( Class )
import DataCon ( DataCon, dataConUserType )
import TcType
-- plus which bit is currently being examined
if_tv_env :: UniqFM TyVar, -- Nested tyvar bindings
+ -- (and coercions)
if_id_env :: UniqFM Id -- Nested id binding
}
\end{code}
(ImportAvails { imp_mods = mods2,
imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
imp_orphs = orphs2, imp_finsts = finsts2 })
- = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
+ = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,
imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
imp_orphs = orphs1 `unionLists` orphs2,
%************************************************************************
%* *
Wanted constraints
-
These are forced to be in TcRnTypes because
TcLclEnv mentions WantedConstraints
WantedConstraint mentions CtLoc
pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)
pprEvVarWithType :: EvVar -> SDoc
-pprEvVarWithType v = ppr v <+> dcolon <+> pprPred (evVarPred v)
+pprEvVarWithType v = ppr v <+> dcolon <+> pprPredTy (evVarPred v)
pprWantedsWithLocs :: WantedConstraints -> SDoc
pprWantedsWithLocs wcs
\begin{code}
data CtFlavor
- = Given GivenLoc -- We have evidence for this constraint in TcEvBinds
- | Derived WantedLoc
- -- We have evidence for this constraint in TcEvBinds;
- -- *however* this evidence can contain wanteds, so
- -- it's valid only provisionally to the solution of
- -- these wanteds
- | Wanted WantedLoc -- We have no evidence bindings for this constraint.
-
--- data DerivedOrig = DerSC | DerInst | DerSelf
--- Deriveds are either superclasses of other wanteds or deriveds, or partially
--- solved wanteds from instances, or 'self' dictionaries containing yet wanted
--- superclasses.
+ = Given GivenLoc GivenKind -- We have evidence for this constraint in TcEvBinds
+ | Derived WantedLoc -- Derived's are just hints for unifications
+ | Wanted WantedLoc -- We have no evidence bindings for this constraint.
+
+data GivenKind
+ = GivenOrig -- Originates in some given, such as signature or pattern match
+ | GivenSolved -- Is given as result of being solved, maybe provisionally on
+ -- some other wanted constraints.
instance Outputable CtFlavor where
- ppr (Given {}) = ptext (sLit "[G]")
- ppr (Wanted {}) = ptext (sLit "[W]")
- ppr (Derived {}) = ptext (sLit "[D]")
+ ppr (Given _ GivenOrig) = ptext (sLit "[G]")
+ ppr (Given _ GivenSolved) = ptext (sLit "[S]") -- Print [S] for Given/Solved's
+ ppr (Wanted {}) = ptext (sLit "[W]")
+ ppr (Derived {}) = ptext (sLit "[D]")
+
pprFlavorArising :: CtFlavor -> SDoc
-pprFlavorArising (Derived wl ) = pprArisingAt wl
+pprFlavorArising (Derived wl) = pprArisingAt wl
pprFlavorArising (Wanted wl) = pprArisingAt wl
-pprFlavorArising (Given gl) = pprArisingAt gl
+pprFlavorArising (Given gl _) = pprArisingAt gl
isWanted :: CtFlavor -> Bool
isWanted (Wanted {}) = True
isWanted _ = False
-isGiven :: CtFlavor -> Bool
-isGiven (Given {}) = True
-isGiven _ = False
+isGivenOrSolved :: CtFlavor -> Bool
+isGivenOrSolved (Given {}) = True
+isGivenOrSolved _ = False
+
+isGiven_maybe :: CtFlavor -> Maybe GivenKind
+isGiven_maybe (Given _ gk) = Just gk
+isGiven_maybe _ = Nothing
isDerived :: CtFlavor -> Bool
isDerived (Derived {}) = True
| StandAloneDerivOrigin -- Typechecking stand-alone deriving
| DefaultOrigin -- Typechecking a default decl
| DoOrigin -- Arising from a do expression
+ | MCompOrigin -- Arising from a monad comprehension
| IfOrigin -- Arising from an if statement
| ProcOrigin -- Arising from a proc expression
| AnnOrigin -- An annotation
pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
pprO DefaultOrigin = ptext (sLit "a 'default' declaration")
pprO DoOrigin = ptext (sLit "a do statement")
+pprO MCompOrigin = ptext (sLit "a statement in a monad comprehension")
pprO ProcOrigin = ptext (sLit "a proc expression")
pprO (TypeEqOrigin eq) = ptext (sLit "an equality") <+> ppr eq
pprO AnnOrigin = ptext (sLit "an annotation")
import TcExpr
import TcEnv
import Id
-import Var ( Var )
import Name
import VarSet
import SrcLoc
CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts,
deCanonicalise, mkFrozenError,
- isWanted, isGiven, isDerived,
- isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising,
+ isWanted, isGivenOrSolved, isDerived,
+ isGivenOrSolvedCt, isGivenCt_maybe,
+ isWantedCt, isDerivedCt, pprFlavorArising,
isFlexiTcsTv,
canRewrite, canSolve,
- combineCtLoc, mkGivenFlavor, mkWantedFlavor,
+ combineCtLoc, mkSolvedFlavor, mkGivenFlavor,
+ mkWantedFlavor,
getWantedLoc,
TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality
setWantedTyBind,
+ lookupFlatCacheMap, updateFlatCacheMap,
+
getInstEnvs, getFamInstEnvs, -- Getting the environments
getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
import qualified TcMType as TcM
import qualified TcEnv as TcM
( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys )
+import Kind
import TcType
import DynFlags
import Bag
import MonadUtils
import VarSet
+import Pair
import FastString
import HsBinds -- for TcEvBinds stuff
import Id
-
import TcRnTypes
+import Data.IORef
+
+import qualified Data.Map as Map
+
#ifdef DEBUG
+import StaticFlags( opt_PprStyle_Debug )
import Control.Monad( when )
#endif
-import Data.IORef
\end{code}
ppr (CIPCan ip fl ip_nm ty)
= ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty)
ppr (CTyEqCan co fl tv ty)
- = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyVarTy tv, ty)
+ = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyVarTy tv) ty)
ppr (CFunEqCan co fl tc tys ty)
- = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyConApp tc tys, ty)
+ = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyConApp tc tys) ty)
ppr (CFrozenErr co fl)
= ppr fl <+> pprEvVarWithType co
\end{code}
isWantedCt :: CanonicalCt -> Bool
isWantedCt ct = isWanted (cc_flavor ct)
-isGivenCt :: CanonicalCt -> Bool
-isGivenCt ct = isGiven (cc_flavor ct)
isDerivedCt :: CanonicalCt -> Bool
isDerivedCt ct = isDerived (cc_flavor ct)
+isGivenCt_maybe :: CanonicalCt -> Maybe GivenKind
+isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct)
+
+isGivenOrSolvedCt :: CanonicalCt -> Bool
+isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct)
+
+
canSolve :: CtFlavor -> CtFlavor -> Bool
-- canSolve ctid1 ctid2
-- The constraint ctid1 can be used to solve ctid2
combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
-- Precondition: At least one of them should be wanted
-combineCtLoc (Wanted loc) _ = loc
-combineCtLoc _ (Wanted loc) = loc
-combineCtLoc (Derived loc ) _ = loc
-combineCtLoc _ (Derived loc ) = loc
+combineCtLoc (Wanted loc) _ = loc
+combineCtLoc _ (Wanted loc) = loc
+combineCtLoc (Derived loc ) _ = loc
+combineCtLoc _ (Derived loc ) = loc
combineCtLoc _ _ = panic "combineCtLoc: both given"
-mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
-mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk)
-mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk)
-mkGivenFlavor (Given loc) sk = Given (setCtLocOrigin loc sk)
+mkSolvedFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
+-- To be called when we actually solve a wanted/derived (perhaps leaving residual goals)
+mkSolvedFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenSolved
+mkSolvedFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenSolved
+mkSolvedFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
+mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
+mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
+mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig
+mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
mkWantedFlavor :: CtFlavor -> CtFlavor
mkWantedFlavor (Wanted loc) = Wanted loc
mkWantedFlavor (Derived loc) = Wanted loc
-mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavour" (ppr fl)
+mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl)
\end{code}
%************************************************************************
tcs_untch :: TcsUntouchables,
- tcs_ic_depth :: Int, -- Implication nesting depth
- tcs_count :: IORef Int -- Global step count
+ tcs_ic_depth :: Int, -- Implication nesting depth
+ tcs_count :: IORef Int, -- Global step count
+
+ tcs_flat_map :: IORef FlatCache
}
+data FlatCache
+ = FlatCache { givenFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor)
+ -- Invariant: all CtFlavors here satisfy isGiven
+ , wantedFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor) }
+ -- Invariant: all CtFlavors here satisfy isWanted
+
+emptyFlatCache :: FlatCache
+emptyFlatCache
+ = FlatCache { givenFlatCache = Map.empty, wantedFlatCache = Map.empty }
+
+newtype FunEqHead = FunEqHead (TyCon,[Xi])
+
+instance Eq FunEqHead where
+ FunEqHead (tc1,xis1) == FunEqHead (tc2,xis2) = tc1 == tc2 && eqTypes xis1 xis2
+
+instance Ord FunEqHead where
+ FunEqHead (tc1,xis1) `compare` FunEqHead (tc2,xis2)
+ = case compare tc1 tc2 of
+ EQ -> cmpTypes xis1 xis2
+ other -> other
+
type TcsUntouchables = (Untouchables,TcTyVarSet)
-- Like the TcM Untouchables,
-- but records extra TcsTv variables generated during simplification
= do { ty_binds_var <- TcM.newTcRef emptyVarEnv
; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
; step_count <- TcM.newTcRef 0
+ ; flat_cache_var <- TcM.newTcRef emptyFlatCache
; let env = TcSEnv { tcs_ev_binds = ev_binds_var
, tcs_ty_binds = ty_binds_var
, tcs_context = context
, tcs_untch = (untouch, emptyVarSet) -- No Tcs untouchables yet
, tcs_count = step_count
, tcs_ic_depth = 0
+ , tcs_flat_map = flat_cache_var
}
-- Run the computation
#ifdef DEBUG
; count <- TcM.readTcRef step_count
- ; when (count > 0) $
+ ; when (opt_PprStyle_Debug && count > 0) $
TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =")
<+> int count <+> ppr context)
#endif
, tcs_untch = (_outer_range, outer_tcs)
, tcs_count = count
, tcs_ic_depth = idepth
- , tcs_context = ctxt } ->
- let
- inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
+ , tcs_context = ctxt
+ , tcs_flat_map = orig_flat_cache_var
+ } ->
+ do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
-- The inner_range should be narrower than the outer one
-- (thus increasing the set of untouchables) but
-- the inner Tcs-untouchables must be unioned with the
-- outer ones!
- nest_env = TcSEnv { tcs_ev_binds = ref
- , tcs_ty_binds = ty_binds
- , tcs_untch = inner_untch
- , tcs_count = count
- , tcs_ic_depth = idepth+1
- , tcs_context = ctxtUnderImplic ctxt }
- in
- thing_inside nest_env
+
+ ; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var
+ ; flat_cache_var <- TcM.newTcRef orig_flat_cache
+ -- One could be more conservative as well:
+ -- ; flat_cache_var <- TcM.newTcRef emptyFlatCache
+
+ -- Consider copying the results the tcs_flat_map of the
+ -- incomping constraint, but we must make sure that we
+ -- have pushed everything in, which seems somewhat fragile
+ ; let nest_env = TcSEnv { tcs_ev_binds = ref
+ , tcs_ty_binds = ty_binds
+ , tcs_untch = inner_untch
+ , tcs_count = count
+ , tcs_ic_depth = idepth+1
+ , tcs_context = ctxtUnderImplic ctxt
+ , tcs_flat_map = flat_cache_var }
+ ; thing_inside nest_env }
recoverTcS :: TcS a -> TcS a -> TcS a
recoverTcS (TcS recovery_code) (TcS thing_inside)
ctxtUnderImplic ctxt = ctxt
tryTcS :: TcS a -> TcS a
--- Like runTcS, but from within the TcS monad
+-- Like runTcS, but from within the TcS monad
-- Ignore all the evidence generated, and do not affect caller's evidence!
-tryTcS tcs
+tryTcS tcs
= TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
; ev_binds_var <- TcM.newTcEvBinds
+ ; flat_cache_var <- TcM.newTcRef emptyFlatCache
; let env1 = env { tcs_ev_binds = ev_binds_var
- , tcs_ty_binds = ty_binds_var }
- ; unTcS tcs env1 })
+ , tcs_ty_binds = ty_binds_var
+ , tcs_flat_map = flat_cache_var }
+ ; unTcS tcs env1 })
-- Update TcEvBinds
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType))
getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef)
+getFlatCacheMapVar :: TcS (IORef FlatCache)
+getFlatCacheMapVar
+ = TcS (return . tcs_flat_map)
+
+lookupFlatCacheMap :: TyCon -> [Xi] -> CtFlavor
+ -> TcS (Maybe (TcType,Coercion,CtFlavor))
+-- For givens, we lookup in given flat cache
+lookupFlatCacheMap tc xis (Given {})
+ = do { cache_ref <- getFlatCacheMapVar
+ ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+ ; return $ Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) }
+-- For wanteds, we first lookup in givenFlatCache.
+-- If we get nothing back then we lookup in wantedFlatCache.
+lookupFlatCacheMap tc xis (Wanted {})
+ = do { cache_ref <- getFlatCacheMapVar
+ ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+ ; case Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) of
+ Nothing -> return $ Map.lookup (FunEqHead (tc,xis)) (wantedFlatCache cache_map)
+ other -> return other }
+lookupFlatCacheMap _tc _xis (Derived {}) = return Nothing
+
+updateFlatCacheMap :: TyCon -> [Xi]
+ -> TcType -> CtFlavor -> Coercion -> TcS ()
+updateFlatCacheMap _tc _xis _tv (Derived {}) _co
+ = return () -- Not caching deriveds
+updateFlatCacheMap tc xis ty fl co
+ = do { cache_ref <- getFlatCacheMapVar
+ ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+ ; let new_cache_map
+ | isGivenOrSolved fl
+ = cache_map { givenFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $
+ givenFlatCache cache_map }
+ | isWanted fl
+ = cache_map { wantedFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $
+ wantedFlatCache cache_map }
+ | otherwise = pprPanic "updateFlatCacheMap, met Derived!" $ empty
+ ; wrapTcS $ TcM.writeTcRef cache_ref new_cache_map }
+
getTcEvBindsBag :: TcS EvBindMap
getTcEvBindsBag
= do { EvBindsVar ev_ref _ <- getTcEvBinds
; wrapTcS $ TcM.readTcRef ev_ref }
+
setCoBind :: CoVar -> Coercion -> TcS ()
setCoBind cv co = setEvBind cv (EvCoercion co)
bind_lvl = TcM.topIdLvl dfun_id
pprEq :: TcType -> TcType -> SDoc
-pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
+pprEq ty1 ty2 = pprPredTy $ mkEqPred (ty1,ty2)
isTouchableMetaTyVar :: TcTyVar -> TcS Bool
isTouchableMetaTyVar tv
\begin{code}
module TcSimplify(
simplifyInfer,
- simplifyDefault, simplifyDeriv,
+ simplifyDefault, simplifyDeriv,
simplifyRule, simplifyTop, simplifyInteractive
) where
import TcSMonad
import TcInteract
import Inst
-import Unify( niFixTvSubst, niSubstTvSet )
+import Id ( evVarPred )
+import Unify ( niFixTvSubst, niSubstTvSet )
import Var
import VarSet
import VarEnv
+import Coercion
import TypeRep
import Name
unsolved_implics
}
-givensFromWanteds :: CanonicalCts -> Bag FlavoredEvVar
--- Extract the *wanted* ones from CanonicalCts
--- and make them into *givens*
-givensFromWanteds = foldrBag getWanted emptyBag
+givensFromWanteds :: SimplContext -> CanonicalCts -> Bag FlavoredEvVar
+-- Extract the Wanted ones from CanonicalCts and conver to
+-- Givens; not Given/Solved, see Note [Preparing inert set for implications]
+givensFromWanteds _ctxt = foldrBag getWanted emptyBag
where
getWanted :: CanonicalCt -> Bag FlavoredEvVar -> Bag FlavoredEvVar
getWanted cc givens
- | not (isCFrozenErr cc)
- , Wanted loc <- cc_flavor cc
- , let given = mkEvVarX (cc_id cc) (Given (setCtLocOrigin loc UnkSkol))
- = given `consBag` givens
- | otherwise
- = givens -- We are not helping anyone by pushing a Derived in!
- -- Because if we could not solve it to start with
- -- we are not going to do either inside the impl constraint
-
+ | pushable_wanted cc
+ = let given = mkEvVarX (cc_id cc) (mkGivenFlavor (cc_flavor cc) UnkSkol)
+ in given `consBag` givens -- and not mkSolvedFlavor,
+ -- see Note [Preparing inert set for implications]
+ | otherwise = givens
+
+ pushable_wanted :: CanonicalCt -> Bool
+ pushable_wanted cc
+ | not (isCFrozenErr cc)
+ , isWantedCt cc
+ = isEqPred (evVarPred (cc_id cc)) -- see Note [Preparing inert set for implications]
+ | otherwise = False
+
solveNestedImplications :: InertSet -> CanonicalCts
-> Bag Implication
-> TcS (Bag FlavoredEvVar, Bag Implication)
| otherwise
= do { -- See Note [Preparing inert set for implications]
-- Push the unsolved wanteds inwards, but as givens
- let pushed_givens = givensFromWanteds unsolved_cans
+
+ ; simpl_ctx <- getTcSContext
+
+ ; let pushed_givens = givensFromWanteds simpl_ctx unsolved_cans
tcs_untouchables = filterVarSet isFlexiTcsTv $
tyVarsOfEvVarXs pushed_givens
-- See Note [Extra TcsTv untouchables]
; traceTcS "solveWanteds: preparing inerts for implications {"
(vcat [ppr tcs_untouchables, ppr pushed_givens])
-
- ; (_, inert_for_implics) <- solveInteract just_given_inert pushed_givens
+
+ ; (_, inert_for_implics) <- solveInteract just_given_inert pushed_givens
; traceTcS "solveWanteds: } now doing nested implications {" $
vcat [ text "inerts_for_implics =" <+> ppr inert_for_implics
given because the resulting set is not inert. Hence we have to do a
'solveInteract' step first.
+Finally, note that we convert them to [Given] and NOT [Given/Solved].
+The reason is that Given/Solved are weaker than Givens and may be discarded.
+As an example consider the inference case, where we may have, the following
+original constraints:
+ [Wanted] F Int ~ Int
+ (F Int ~ a => F Int ~ a)
+If we convert F Int ~ Int to [Given/Solved] instead of Given, then the next
+given (F Int ~ a) is going to cause the Given/Solved to be ignored, casting
+the (F Int ~ a) insoluble. Hence we should really convert the residual
+wanteds to plain old Given.
+
+We need only push in unsolved equalities both in checking mode and inference mode:
+
+ (1) In checking mode we should not push given dictionaries in because of
+example LongWayOverlapping.hs, where we might get strange overlap
+errors between far-away constraints in the program. But even in
+checking mode, we must still push type family equations. Consider:
+
+ type instance F True a b = a
+ type instance F False a b = b
+
+ [w] F c a b ~ gamma
+ (c ~ True) => a ~ gamma
+ (c ~ False) => b ~ gamma
+
+Since solveCTyFunEqs happens at the very end of solving, the only way to solve
+the two implications is temporarily consider (F c a b ~ gamma) as Given (NB: not
+merely Given/Solved because it has to interact with the top-level instance
+environment) and push it inside the implications. Now, when we come out again at
+the end, having solved the implications solveCTyFunEqs will solve this equality.
+
+ (2) In inference mode, we recheck the final constraint in checking mode and
+hence we will be able to solve inner implications from top-level quantified
+constraints nonetheless.
+
+
Note [Extra TcsTv untouchables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Furthemore, we record the inert set simplifier-generated unification
; return (niFixTvSubst ni_subst, unsolved_can_cts) }
where
- solve_one (cv,tv,ty) = setWantedTyBind tv ty >> setCoBind cv ty
+ solve_one (cv,tv,ty) = do { setWantedTyBind tv ty
+ ; setCoBind cv (mkReflCo ty) }
------------
type FunEqBinds = (TvSubstEnv, [(CoVar, TcTyVar, TcType)])
, not (tv `elemVarSet` niSubstTvSet tv_subst (tyVarsOfTypes xis))
-- Occurs check: see Note [Solving Family Equations], Point 2
- = ASSERT ( not (isGiven fl) )
+ = ASSERT ( not (isGivenOrSolved fl) )
(cts_in, extendFunEqBinds feb cv tv (mkTyConApp tc xis))
dflt_funeq (cts_in, fun_eq_binds) ct
import Outputable
import Util ( dropList )
import Data.List ( mapAccumL )
+import Pair
import Unique
import Data.Maybe
import BasicTypes
_ -> return (TH.VarI v ty Nothing fix)
}
-reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
-reifyThing (AGlobal (AClass cls)) = reifyClass cls
+reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
+reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax
+reifyThing (AGlobal (AClass cls)) = reifyClass cls
reifyThing (AGlobal (ADataCon dc))
= do { let name = dataConName dc
; ty <- reifyType (idType (dataConWrapId dc))
reifyThing (AThing {}) = panic "reifyThing AThing"
------------------------------
+reifyAxiom :: CoAxiom -> TcM TH.Info
+reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs })
+ | Just (tc, args) <- tcSplitTyConApp_maybe lhs
+ = do { args' <- mapM reifyType args
+ ; rhs' <- reifyType rhs
+ ; return (TH.TyConI $ TH.TySynInstD (reifyName tc) args' rhs') }
+ | otherwise
+ = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax
+ <+> dcolon <+> pprEqPred (Pair lhs rhs))
+
reifyTyCon :: TyCon -> TcM TH.Info
reifyTyCon tc
| isFunTyCon tc
= return (TH.PrimTyConI (reifyName tc) 2 False)
+
| isPrimTyCon tc
= return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
+
| isFamilyTyCon tc
= let flavour = reifyFamFlavour tc
tvs = tyConTyVars tc
in
return (TH.TyConI $
TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
+
| isSynTyCon tc
= do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
}
-reifyTyCon tc
+ | otherwise
= do { cxt <- reifyCxt (tyConStupidTheta tc)
; let tvs = tyConTyVars tc
; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
reifyType :: TypeRep.Type -> TcM TH.Type
-- Monadic only because of failure
reifyType ty@(ForAllTy _ _) = reify_for_all ty
-reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
+reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
\begin{code}
module TcTyClsDecls (
- tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds
+ tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds,
+ checkValidTyCon, dataDeclChecks, badFamInstDecl
) where
#include "HsVersions.h"
import TcType
import TysWiredIn ( unitTy )
import Type
-import Generics
import Class
import TyCon
import DataCon
import Id
-import MkId ( mkDefaultMethodId )
import MkCore ( rEC_SEL_ERROR_ID )
import IdInfo
import Var
import VarSet
import Name
+import NameEnv
import Outputable
import Maybes
import Unify
%************************************************************************
\begin{code}
+
tcTyAndClassDecls :: ModDetails
-> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order
-> TcM (TcGblEnv, -- Input env extended by types and classes
-- and their implicit Ids,DataCons
- HsValBinds Name, -- Renamed bindings for record selectors
- [Id]) -- Default method ids
+ HsValBinds Name) -- Renamed bindings for record selectors
-- Fails if there are any errors
tcTyAndClassDecls boot_details decls_s
-- And now build the TyCons/Classes
; let rec_flags = calcRecFlags boot_details rec_tyclss
- ; concatMapM (tcTyClDecl rec_flags) kc_decls }
+ ; concatMapM (tcTyClDecl rec_flags) kc_decls }
; tcExtendGlobalEnv tyclss $ do
{ -- Perform the validity check
-- second time here. This doesn't matter as the definitions are
-- the same.
; let { implicit_things = concatMap implicitTyThings tyclss
- ; rec_sel_binds = mkRecSelBinds tyclss
+ ; rec_sel_binds = mkRecSelBinds [tc | ATyCon tc <- tyclss]
; dm_ids = mkDefaultMethodIds tyclss }
- ; env <- tcExtendGlobalEnv implicit_things getGblEnv
- ; return (env, rec_sel_binds, dm_ids) } }
+ ; env <- tcExtendGlobalEnv implicit_things $
+ tcExtendGlobalValEnv dm_ids $
+ getGblEnv
+ ; return (env, rec_sel_binds) } }
zipRecTyClss :: [[LTyClDecl Name]]
-> [TyThing] -- Knot-tied
%************************************************************************
%* *
- Type checking family instances
-%* *
-%************************************************************************
-
-Family instances are somewhat of a hybrid. They are processed together with
-class instance heads, but can contain data constructors and hence they share a
-lot of kinding and type checking code with ordinary algebraic data types (and
-GADTs).
-
-\begin{code}
-tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
-tcFamInstDecl top_lvl (L loc decl)
- = -- Prime error recovery, set source location
- setSrcSpan loc $
- tcAddDeclCtxt decl $
- do { -- type family instances require -XTypeFamilies
- -- and can't (currently) be in an hs-boot file
- ; type_families <- xoptM Opt_TypeFamilies
- ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
- ; checkTc type_families $ badFamInstDecl (tcdLName decl)
- ; checkTc (not is_boot) $ badBootFamInstDeclErr
-
- -- Perform kind and type checking
- ; tc <- tcFamInstDecl1 decl
- ; checkValidTyCon tc -- Remember to check validity;
- -- no recursion to worry about here
-
- -- Check that toplevel type instances are not for associated types.
- ; when (isTopLevel top_lvl && isAssocFamily tc)
- (addErr $ assocInClassErr (tcdName decl))
-
- ; return (ATyCon tc) }
-
-isAssocFamily :: TyCon -> Bool -- Is an assocaited type
-isAssocFamily tycon
- = case tyConFamInst_maybe tycon of
- Nothing -> panic "isAssocFamily: no family?!?"
- Just (fam, _) -> isTyConAssoc fam
-
-assocInClassErr :: Name -> SDoc
-assocInClassErr name
- = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
- ptext (sLit "must be inside a class instance")
-
-
-
-tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
-
- -- "type instance"
-tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
- = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
- do { -- check that the family declaration is for a synonym
- checkTc (isFamilyTyCon family) (notFamily family)
- ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
-
- ; -- (1) kind check the right-hand side of the type equation
- ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
- -- ToDo: the ExpKind could be better
-
- -- we need the exact same number of type parameters as the family
- -- declaration
- ; let famArity = tyConArity family
- ; checkTc (length k_typats == famArity) $
- wrongNumberOfParmsErr famArity
-
- -- (2) type check type equation
- ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
- ; t_typats <- mapM tcHsKindedType k_typats
- ; t_rhs <- tcHsKindedType k_rhs
-
- -- (3) check the well-formedness of the instance
- ; checkValidTypeInst t_typats t_rhs
-
- -- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
- ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs)
- (typeKind t_rhs)
- NoParentTyCon (Just (family, t_typats))
- }}
-
- -- "newtype instance" and "data instance"
-tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
- tcdCons = cons})
- = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
- do { -- check that the family declaration is for the right kind
- checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
- ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
-
- ; -- (1) kind check the data declaration as usual
- ; k_decl <- kcDataDecl decl k_tvs
- ; let k_ctxt = tcdCtxt k_decl
- k_cons = tcdCons k_decl
-
- -- result kind must be '*' (otherwise, we have too few patterns)
- ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon)
-
- -- (2) type check indexed data type declaration
- ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars
- ; unbox_strict <- doptM Opt_UnboxStrictFields
-
- -- kind check the type indexes and the context
- ; t_typats <- mapM tcHsKindedType k_typats
- ; stupid_theta <- tcHsKindedContext k_ctxt
-
- -- (3) Check that
- -- (a) left-hand side contains no type family applications
- -- (vanilla synonyms are fine, though, and we checked for
- -- foralls earlier)
- ; mapM_ checkTyFamFreeness t_typats
-
- -- Check that we don't use GADT syntax in H98 world
- ; gadt_ok <- xoptM Opt_GADTs
- ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name)
-
- -- (b) a newtype has exactly one constructor
- ; checkTc (new_or_data == DataType || isSingleton k_cons) $
- newtypeConError tc_name (length k_cons)
-
- -- (4) construct representation tycon
- ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
- ; let ex_ok = True -- Existentials ok for type families!
- ; fixM (\ rep_tycon -> do
- { let orig_res_ty = mkTyConApp fam_tycon t_typats
- ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon
- (t_tvs, orig_res_ty) k_cons
- ; tc_rhs <-
- case new_or_data of
- DataType -> return (mkDataTyConRhs data_cons)
- NewType -> ASSERT( not (null data_cons) )
- mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
- ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
- False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
- -- We always assume that indexed types are recursive. Why?
- -- (1) Due to their open nature, we can never be sure that a
- -- further instance might not introduce a new recursive
- -- dependency. (2) They are always valid loop breakers as
- -- they involve a coercion.
- })
- }}
- where
- h98_syntax = case cons of -- All constructors have same shape
- L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False
- _ -> True
-
-tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d)
-
--- Kind checking of indexed types
--- -
-
--- Kind check type patterns and kind annotate the embedded type variables.
---
--- * Here we check that a type instance matches its kind signature, but we do
--- not check whether there is a pattern for each type index; the latter
--- check is only required for type synonym instances.
-
-kcIdxTyPats :: TyClDecl Name
- -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a)
- -- ^^kinded tvs ^^kinded ty pats ^^res kind
- -> TcM a
-kcIdxTyPats decl thing_inside
- = kcHsTyVars (tcdTyVars decl) $ \tvs ->
- do { let tc_name = tcdLName decl
- ; fam_tycon <- tcLookupLocatedTyCon tc_name
- ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
- ; hs_typats = fromJust $ tcdTyPats decl }
-
- -- we may not have more parameters than the kind indicates
- ; checkTc (length kinds >= length hs_typats) $
- tooManyParmsErr (tcdLName decl)
-
- -- type functions can have a higher-kinded result
- ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
- ; typats <- zipWithM kcCheckLHsType hs_typats
- [ EK kind (EkArg (ppr tc_name) n)
- | (kind,n) <- kinds `zip` [1..]]
- ; thing_inside tvs typats resultKind fam_tycon
- }
-\end{code}
-
-
-%************************************************************************
-%* *
Kind checking
%* *
%************************************************************************
where
kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
; return (TypeSig nm op_ty') }
+ kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
+ ; return (GenericSig nm op_ty') }
kc_sig other_sig = return other_sig
kcTyClDecl decl@(ForeignType {})
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildAlgTyCon tc_name final_tvs []
- DataFamilyTyCon Recursive False True
+ DataFamilyTyCon Recursive True
parent Nothing
; return [ATyCon tycon]
}
{ extra_tvs <- tcDataKindSig mb_ksig
; let final_tvs = tvs' ++ extra_tvs
; stupid_theta <- tcHsKindedContext ctxt
- ; want_generic <- xoptM Opt_Generics
; unbox_strict <- doptM Opt_UnboxStrictFields
- ; empty_data_decls <- xoptM Opt_EmptyDataDecls
; kind_signatures <- xoptM Opt_KindSignatures
; existential_ok <- xoptM Opt_ExistentialQuantification
; gadt_ok <- xoptM Opt_GADTs
- ; gadtSyntax_ok <- xoptM Opt_GADTSyntax
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context
- -- Check that we don't use GADT syntax in H98 world
- ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
-
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name)
- -- Check that the stupid theta is empty for a GADT-style declaration
- ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
-
- -- Check that a newtype has exactly one constructor
- -- Do this before checking for empty data decls, so that
- -- we don't suggest -XEmptyDataDecls for newtypes
- ; checkTc (new_or_data == DataType || isSingleton cons)
- (newtypeConError tc_name (length cons))
+ ; dataDeclChecks tc_name new_or_data stupid_theta cons
- -- Check that there's at least one condecl,
- -- or else we're reading an hs-boot file, or -XEmptyDataDecls
- ; checkTc (not (null cons) || empty_data_decls || is_boot)
- (emptyConDeclsErr tc_name)
-
; tycon <- fixM (\ tycon -> do
{ let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
; data_cons <- tcConDecls unbox_strict ex_ok
NewType -> ASSERT( not (null data_cons) )
mkNewTyConRhs tc_name tycon (head data_cons)
; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
- (want_generic && canDoGenerics data_cons) (not h98_syntax)
- NoParentTyCon Nothing
+ (not h98_syntax) NoParentTyCon Nothing
})
; return [ATyCon tycon]
}
tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
; fds' <- mapM (addLocM tc_fundep) fundeps
- ; sig_stuff <- tcClassSigs class_name sigs meths
+ ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
; clas <- fixM $ \ clas -> do
{ let -- This little knot is just so we can get
-- hold of the name of the class TyCon, which we
; buildClass False {- Must include unfoldings for selectors -}
class_name tvs' ctxt' fds' (concat atss')
sig_stuff tc_isrec }
- ; return (AClass clas : map ATyCon (classATs clas))
+
+ ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
+ | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas
+ , let gen_dm_tau = expectJust "tcTyClDecl1" $
+ lookupNameEnv gen_dm_env (idName sel_id)
+ , let gen_dm_ty = mkSigmaTy tvs'
+ [mkClassPred clas (mkTyVarTys tvs')]
+ gen_dm_tau
+ ]
+ class_ats = map ATyCon (classATs clas)
+
+ ; return (AClass clas : gen_dm_ids ++ class_ats )
-- NB: Order is important due to the call to `mkGlobalThings' when
-- tying the the type and class declaration type checking knot.
}
tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
+dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM ()
+dataDeclChecks tc_name new_or_data stupid_theta cons
+ = do { -- Check that we don't use GADT syntax in H98 world
+ gadtSyntax_ok <- xoptM Opt_GADTSyntax
+ ; let h98_syntax = consUseH98Syntax cons
+ ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name)
+
+ -- Check that the stupid theta is empty for a GADT-style declaration
+ ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name)
+
+ -- Check that a newtype has exactly one constructor
+ -- Do this before checking for empty data decls, so that
+ -- we don't suggest -XEmptyDataDecls for newtypes
+ ; checkTc (new_or_data == DataType || isSingleton cons)
+ (newtypeConError tc_name (length cons))
+
+ -- Check that there's at least one condecl,
+ -- or else we're reading an hs-boot file, or -XEmptyDataDecls
+ ; empty_data_decls <- xoptM Opt_EmptyDataDecls
+ ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
+ ; checkTc (not (null cons) || empty_data_decls || is_boot)
+ (emptyConDeclsErr tc_name) }
+
-----------------------------------
tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
-> [LConDecl Name] -> TcM [DataCon]
ATyCon tc -> checkValidTyCon tc
AClass cl -> do { checkValidClass cl
; mapM_ (addLocM checkValidTyCl) (tcdATs decl) }
+ AnId _ -> return () -- Generic default methods are checked
+ -- with their parent class
_ -> panic "checkValidTyCl"
; traceTc "Done validity of" (ppr thing)
}
-- One argument
; checkTc (null eq_spec) (newtypePredError con)
-- Return type is (T a b c)
- ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con)
+ ; checkTc (null ex_tvs && null theta) (newtypeExError con)
-- No existentials
; checkTc (not (any isBanged (dataConStrictMarks con)))
(newtypeStrictError con)
-- No strictness
}
where
- (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con
+ (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con
-------------------------------
checkValidClass :: Class -> TcM ()
where
(tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
unary = isSingleton tyvars
- no_generics = null [() | (_, GenDefMeth) <- op_stuff]
+ no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
check_op constrained_class_methods (sel_id, dm)
= addErrCtxt (classOpCtxt sel_id tau) $ do
; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
(noClassTyVarErr cls sel_id)
- -- Check that for a generic method, the type of
- -- the method is sufficiently simple
- ; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
- (badGenericMethodType op_name op_ty)
+ ; case dm of
+ GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name
+ ; checkValidType (FunSigCtxt op_name) (idType dm_id) }
+ _ -> return ()
}
where
op_name = idName sel_id
mkDefaultMethodIds :: [TyThing] -> [Id]
-- See Note [Default method Ids and Template Haskell]
mkDefaultMethodIds things
- = [ mkDefaultMethodId sel_id dm_name
+ = [ mkExportedLocalId dm_name (idType sel_id)
| AClass cls <- things
, (sel_id, DefMeth dm_name) <- classOpItems cls ]
\end{code}
when typechecking the [d| .. |] quote, and typecheck them later.
\begin{code}
-mkRecSelBinds :: [TyThing] -> HsValBinds Name
+mkRecSelBinds :: [TyCon] -> HsValBinds Name
-- NB We produce *un-typechecked* bindings, rather like 'deriving'
-- This makes life easier, because the later type checking will add
-- all necessary type abstractions and applications
-mkRecSelBinds ty_things
+mkRecSelBinds tycons
= ValBindsOut [(NonRecursive, b) | b <- binds] sigs
where
(sigs, binds) = unzip rec_sels
rec_sels = map mkRecSelBind [ (tc,fld)
- | ATyCon tc <- ty_things
+ | tc <- tycons
, fld <- tyConFields tc ]
mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
= ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+>
ptext (sLit "cannot have generic methods")
-badGenericMethodType :: Name -> Kind -> SDoc
-badGenericMethodType op op_ty
- = hang (ptext (sLit "Generic method type is too complex"))
- 2 (vcat [ppr op <+> dcolon <+> ppr op_ty,
- ptext (sLit "You can only use type variables, arrows, lists, and tuples")])
-
recSynErr :: [LTyClDecl Name] -> TcRn ()
recSynErr syn_decls
= setSrcSpan (getLoc (head sorted_decls)) $
quotes (ppr tc_name)
, nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
-tooManyParmsErr :: Located Name -> SDoc
-tooManyParmsErr tc_name
- = ptext (sLit "Family instance has too many parameters:") <+>
- quotes (ppr tc_name)
-
-tooFewParmsErr :: Arity -> SDoc
-tooFewParmsErr arity
- = ptext (sLit "Family instance has too few parameters; expected") <+>
- ppr arity
-
-wrongNumberOfParmsErr :: Arity -> SDoc
-wrongNumberOfParmsErr exp_arity
- = ptext (sLit "Number of parameters must match family declaration; expected")
- <+> ppr exp_arity
-
-badBootFamInstDeclErr :: SDoc
-badBootFamInstDeclErr
- = ptext (sLit "Illegal family instance in hs-boot file")
-
-notFamily :: TyCon -> SDoc
-notFamily tycon
- = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
- , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
-
-wrongKindOfFamily :: TyCon -> SDoc
-wrongKindOfFamily family
- = ptext (sLit "Wrong category of family instance; declaration was for a")
- <+> kindOfFamily
- where
- kindOfFamily | isSynTyCon family = ptext (sLit "type synonym")
- | isAlgTyCon family = ptext (sLit "data type")
- | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
-
emptyConDeclsErr :: Name -> SDoc
emptyConDeclsErr tycon
= sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"),
import Digraph
import BasicTypes
import SrcLoc
-import Outputable
+import Maybes( mapCatMaybes )
import Util ( isSingleton )
import Data.List
\end{code}
nt_loop_breakers `unionNameSets`
prod_loop_breakers
- all_tycons = [ tc | tycls <- tyclss,
+ all_tycons = [ tc | tc <- mapCatMaybes getTyCon tyclss
-- Recursion of newtypes/data types can happen via
-- the class TyCon, so tyclss includes the class tycons
- let tc = getTyCon tycls,
- not (tyConName tc `elemNameSet` boot_name_set) ]
+ , not (tyConName tc `elemNameSet` boot_name_set) ]
-- Remove the boot_name_set because they are going
-- to be loop breakers regardless.
new_tc_rhs :: TyCon -> Type
new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables
-getTyCon :: TyThing -> TyCon
-getTyCon (ATyCon tc) = tc
-getTyCon (AClass cl) = classTyCon cl
-getTyCon _ = panic "getTyCon"
+getTyCon :: TyThing -> Maybe TyCon
+getTyCon (ATyCon tc) = Just tc
+getTyCon (AClass cl) = Just (classTyCon cl)
+getTyCon _ = Nothing
findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
-- Finds a set of tycons that cut all loops
go (FunTy a b) = go a `plusNameEnv` go b
go (PredTy (IParam _ ty)) = go ty
go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys
+ go (PredTy (EqPred ty1 ty2)) = go ty1 `plusNameEnv` go ty2
go (ForAllTy _ ty) = go ty
- go _ = panic "tcTyConsOfType"
go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc
go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
--------------------------------
-- Types
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
- TcTyVar, TcTyVarSet, TcKind, TcCoVar,
+ TcCoercion, TcTyVar, TcTyVarSet, TcKind, TcCoVar,
--------------------------------
-- MetaDetails
---------------------------------
-- Predicates.
-- Again, newtypes are opaque
- tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
+ eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX,
eqKind,
isSigmaTy, isOverloadedTy,
isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
---------------------------------
-- Misc type manipulators
deNoteType,
- orphNamesOfType, orphNamesOfDFunHead,
+ orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo,
getDFunTyKey,
---------------------------------
-- Predicate types
- getClassPredTys_maybe, getClassPredTys,
- isClassPred, isTyVarClassPred, isEqPred,
- mkClassPred, mkIPPred, tcSplitPredTy_maybe,
- mkDictTy, evVarPred,
- isPredTy, isDictTy, isDictLikeTy,
- tcSplitDFunTy, tcSplitDFunHead, predTyUnique,
- isIPPred,
mkMinimalBySCs, transSuperClasses, immSuperClasses,
-- * Tidying type related things up for printing
tidyTyVarBndr, tidyFreeTyVars,
tidyOpenTyVar, tidyOpenTyVars,
tidyTopType, tidyPred,
- tidyKind,
+ tidyKind,
+ tidyCo, tidyCos,
---------------------------------
-- Foreign import and export
tcSplitIOType_maybe, -- :: Type -> Maybe Type
--------------------------------
- -- Rexported from Coercion
- typeKind,
-
- --------------------------------
- -- Rexported from Type
- Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
+ -- Rexported from Kind
+ Kind, typeKind,
unliftedTypeKind, liftedTypeKind, argTypeKind,
openTypeKind, mkArrowKind, mkArrowKinds,
isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind,
isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind,
kindVarRef, mkKindVar,
- Type, PredType(..), ThetaType,
+ --------------------------------
+ -- Rexported from Type
+ Type, Pred(..), PredType, ThetaType,
mkForAllTy, mkForAllTys,
mkFunTy, mkFunTys, zipFunTys,
mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
+ getClassPredTys_maybe, getClassPredTys,
+ isClassPred, isTyVarClassPred, isEqPred,
+ mkClassPred, mkIPPred, splitPredTy_maybe,
+ mkDictTy, isPredTy, isDictTy, isDictLikeTy,
+ tcSplitDFunTy, tcSplitDFunHead,
+ isIPPred, mkEqPred,
+
-- Type substitutions
TvSubst(..), -- Representation visible to a few friends
- TvSubstEnv, emptyTvSubst, substEqSpec,
+ TvSubstEnv, emptyTvSubst,
mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst,
mkTopTvSubst, notElemTvSubst, unionTvSubst,
- getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar,
- extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
- substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, substTyVarBndr,
+ getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
+ Type.lookupTyVar, Type.extendTvSubst, Type.substTyVarBndr,
+ extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
+ Type.substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars,
isUnLiftedType, -- Source types are always lifted
isUnboxedTupleType, -- Ditto
pprKind, pprParendKind,
pprType, pprParendType, pprTypeApp, pprTyThingCategory,
- pprPred, pprTheta, pprThetaArrow, pprClassPred
+ pprPred, pprTheta, pprThetaArrow, pprThetaArrowTy, pprClassPred
) where
#include "HsVersions.h"
-- friends:
+import Kind
import TypeRep
import Class
import Var
-- others:
import DynFlags
-import Name
+import Name hiding (varName)
import NameSet
import VarEnv
import PrelNames
-- a cannot occur inside a MutTyVar in T; that is,
-- T is "flattened" before quantifying over a
+type TcCoercion = Coercion -- A TcCoercion can contain TcTypes.
+
-- These types do not have boxy type variables in them
type TcPredType = PredType
type TcThetaType = ThetaType
The alternative (currently implemented) is to have a special kind of skolem
constant, SigTv, which can unify with other SigTvs. These are *not* treated
-as righd for the purposes of GADTs. And they are used *only* for pattern
+as rigid for the purposes of GADTs. And they are used *only* for pattern
bindings and mutually recursive function bindings. See the function
TcBinds.tcInstSig, and its use_skols parameter.
\begin{code}
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
-- For debugging
-pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk")
+pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk")
pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt")
pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk")
pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
--
-- It doesn't change the uniques at all, just the print names.
tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
-tidyTyVarBndr env@(tidy_env, subst) tyvar
+tidyTyVarBndr (tidy_env, subst) tyvar
= case tidyOccName tidy_env occ1 of
- (tidy', occ') -> ((tidy', subst'), tyvar'')
+ (tidy', occ') -> ((tidy', subst'), tyvar')
where
- subst' = extendVarEnv subst tyvar tyvar''
+ subst' = extendVarEnv subst tyvar tyvar'
tyvar' = setTyVarName tyvar name'
-
- name' = tidyNameOcc name occ'
-
- -- Don't forget to tidy the kind for coercions!
- tyvar'' | isCoVar tyvar = setTyVarKind tyvar' kind'
- | otherwise = tyvar'
- kind' = tidyType env (tyVarKind tyvar)
+ name' = tidyNameOcc name occ'
where
name = tyVarName tyvar
occ = getOccName name
tidyKind env k = tidyOpenType env k
\end{code}
+%************************************************************************
+%* *
+ Tidying coercions
+%* *
+%************************************************************************
+
+\begin{code}
+
+tidyCo :: TidyEnv -> Coercion -> Coercion
+tidyCo env@(_, subst) co
+ = go co
+ where
+ go (Refl ty) = Refl (tidyType env ty)
+ go (TyConAppCo tc cos) = let args = map go cos
+ in args `seqList` TyConAppCo tc args
+ go (AppCo co1 co2) = (AppCo $! go co1) $! go co2
+ go (ForAllCo tv co) = ForAllCo tvp $! (tidyCo envp co)
+ where
+ (envp, tvp) = tidyTyVarBndr env tv
+ go (CoVarCo cv) = case lookupVarEnv subst cv of
+ Nothing -> CoVarCo cv
+ Just cv' -> CoVarCo cv'
+ go (AxiomInstCo con cos) = let args = tidyCos env cos
+ in args `seqList` AxiomInstCo con args
+ go (UnsafeCo ty1 ty2) = (UnsafeCo $! tidyType env ty1) $! tidyType env ty2
+ go (SymCo co) = SymCo $! go co
+ go (TransCo co1 co2) = (TransCo $! go co1) $! go co2
+ go (NthCo d co) = NthCo d $! go co
+ go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty
+
+tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
+tidyCos env = map (tidyCo env)
+
+\end{code}
%************************************************************************
%* *
tcSplitForAllTys ty = split ty ty []
where
split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
- split _ (ForAllTy tv ty) tvs
- | not (isCoVar tv) = split ty ty (tv:tvs)
- split orig_ty _ tvs = (reverse tvs, orig_ty)
+ split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
+ split orig_ty _ tvs = (reverse tvs, orig_ty)
tcIsForAllTy :: Type -> Bool
tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
-tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv)
-tcIsForAllTy _ = False
+tcIsForAllTy (ForAllTy {}) = True
+tcIsForAllTy _ = False
tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
-- Split off the first predicate argument from a type
tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty'
-tcSplitPredFunTy_maybe (ForAllTy tv ty)
- | isCoVar tv = Just (coVarPred tv, ty)
tcSplitPredFunTy_maybe (FunTy arg res)
- | Just p <- tcSplitPredTy_maybe arg = Just (p, res)
+ | Just p <- splitPredTy_maybe arg = Just (p, res)
tcSplitPredFunTy_maybe _
= Nothing
-- coercion and class constraints; or (in the general NDP case)
-- some other function argument
split_dfun_args n ty | Just ty' <- tcView ty = split_dfun_args n ty'
- split_dfun_args n (ForAllTy tv ty) = ASSERT( isCoVar tv ) split_dfun_args (n+1) ty
split_dfun_args n (FunTy _ ty) = split_dfun_args (n+1) ty
split_dfun_args n ty = (n, ty)
tcSplitDFunHead :: Type -> (Class, [Type])
tcSplitDFunHead tau
- = case tcSplitPredTy_maybe tau of
+ = case splitPredTy_maybe tau of
Just (ClassP clas tys) -> (clas, tys)
_ -> pprPanic "tcSplitDFunHead" (ppr tau)
%* *
%************************************************************************
-\begin{code}
-evVarPred :: EvVar -> PredType
-evVarPred var
- = case tcSplitPredTy_maybe (varType var) of
- Just pred -> pred
- Nothing -> pprPanic "evVarPred" (ppr var <+> ppr (varType var))
-
-tcSplitPredTy_maybe :: Type -> Maybe PredType
- -- Returns Just for predicates only
-tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty'
-tcSplitPredTy_maybe (PredTy p) = Just p
-tcSplitPredTy_maybe _ = Nothing
-
-predTyUnique :: PredType -> Unique
-predTyUnique (IParam n _) = getUnique (ipNameName n)
-predTyUnique (ClassP clas _) = getUnique clas
-predTyUnique (EqPred a b) = pprPanic "predTyUnique" (ppr (EqPred a b))
-\end{code}
-
-
---------------------- Dictionary types ---------------------------------
-
-\begin{code}
-mkClassPred :: Class -> [Type] -> PredType
-mkClassPred clas tys = ClassP clas tys
-
-isClassPred :: PredType -> Bool
-isClassPred (ClassP _ _) = True
-isClassPred _ = False
-
-isTyVarClassPred :: PredType -> Bool
-isTyVarClassPred (ClassP _ tys) = all tcIsTyVarTy tys
-isTyVarClassPred _ = False
-
-getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
-getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
-getClassPredTys_maybe _ = Nothing
-
-getClassPredTys :: PredType -> (Class, [Type])
-getClassPredTys (ClassP clas tys) = (clas, tys)
-getClassPredTys _ = panic "getClassPredTys"
-
-mkDictTy :: Class -> [Type] -> Type
-mkDictTy clas tys = mkPredTy (ClassP clas tys)
-
-isDictLikeTy :: Type -> Bool
--- Note [Dictionary-like types]
-isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty'
-isDictLikeTy (PredTy p) = isClassPred p
-isDictLikeTy (TyConApp tc tys)
- | isTupleTyCon tc = all isDictLikeTy tys
-isDictLikeTy _ = False
-\end{code}
-
Superclasses
\begin{code}
, ploc `not_in_preds` rec_scs ]
where
rec_scs = concatMap trans_super_classes ptys
- not_in_preds p ps = null (filter (tcEqPred p) ps)
+ not_in_preds p ps = null (filter (eqPred p) ps)
trans_super_classes (ClassP cls tys) = transSuperClasses cls tys
trans_super_classes _other_pty = []
where (tyvars,sc_theta,_,_) = classBigSig cls
\end{code}
-Note [Dictionary-like types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Being "dictionary-like" means either a dictionary type or a tuple thereof.
-In GHC 6.10 we build implication constraints which construct such tuples,
-and if we land up with a binding
- t :: (C [a], Eq [a])
- t = blah
-then we want to treat t as cheap under "-fdicts-cheap" for example.
-(Implication constraints are normally inlined, but sadly not if the
-occurrence is itself inside an INLINE function! Until we revise the
-handling of implication constraints, that is.) This turned out to
-be important in getting good arities in DPH code. Example:
-
- class C a
- class D a where { foo :: a -> a }
- instance C a => D (Maybe a) where { foo x = x }
-
- bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b)
- {-# INLINE bar #-}
- bar x y = (foo (Just x), foo (Just y))
-
-Then 'bar' should jolly well have arity 4 (two dicts, two args), but
-we ended up with something like
- bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ...
- in \x,y. <blah>)
-
-This is all a bit ad-hoc; eg it relies on knowing that implication
-constraints build tuples.
-
---------------------- Implicit parameters ---------------------------------
-
-\begin{code}
-mkIPPred :: IPName Name -> Type -> PredType
-mkIPPred ip ty = IParam ip ty
-
-isIPPred :: PredType -> Bool
-isIPPred (IParam _ _) = True
-isIPPred _ = False
-\end{code}
-
---------------------- Equality predicates ---------------------------------
-\begin{code}
-substEqSpec :: TvSubst -> [(TyVar,Type)] -> [(TcType,TcType)]
-substEqSpec subst eq_spec = [ (substTyVar subst tv, substTy subst ty)
- | (tv,ty) <- eq_spec]
-\end{code}
-
%************************************************************************
%* *
isOverloadedTy :: Type -> Bool
-- Yes for a type of a function that might require evidence-passing
-- Used only by bindLocalMethods
--- NB: be sure to check for type with an equality predicate; hence isCoVar
isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
-isOverloadedTy (ForAllTy tv ty) = isCoVar tv || isOverloadedTy ty
-isOverloadedTy (FunTy a _) = isPredTy a
-isOverloadedTy _ = False
-
-isPredTy :: Type -> Bool -- Belongs in TcType because it does
- -- not look through newtypes, or predtypes (of course)
-isPredTy ty | Just ty' <- tcView ty = isPredTy ty'
-isPredTy (PredTy _) = True
-isPredTy _ = False
+isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty
+isOverloadedTy (FunTy a _) = isPredTy a
+isOverloadedTy _ = False
\end{code}
\begin{code}
tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty
tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
-tcTyVarsOfType (ForAllTy tyvar ty) = (tcTyVarsOfType ty `delVarSet` tyvar)
- `unionVarSet` tcTyVarsOfTyVar tyvar
+tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar
-- We do sometimes quantify over skolem TcTyVars
-tcTyVarsOfTyVar :: TcTyVar -> TyVarSet
-tcTyVarsOfTyVar tv | isCoVar tv = tcTyVarsOfType (tyVarKind tv)
- | otherwise = emptyVarSet
-
tcTyVarsOfTypes :: [Type] -> TyVarSet
tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
tcTyVarsOfPred (EqPred ty1 ty2) = tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2
\end{code}
-Note [Silly type synonym]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- type T a = Int
-What are the free tyvars of (T x)? Empty, of course!
-Here's the example that Ralf Laemmel showed me:
- foo :: (forall a. C u a -> C u a) -> u
- mappend :: Monoid u => u -> u -> u
-
- bar :: Monoid u => u
- bar = foo (\t -> t `mappend` t)
-We have to generalise at the arg to f, and we don't
-want to capture the constraint (Monad (C u a)) because
-it appears to mention a. Pretty silly, but it was useful to him.
-
-exactTyVarsOfType is used by the type checker to figure out exactly
-which type variables are mentioned in a type. It's also used in the
-smart-app checking code --- see TcExpr.tcIdApp
-
-On the other hand, consider a *top-level* definition
- f = (\x -> x) :: T a -> T a
-If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then
-if we have an application like (f "x") we get a confusing error message
-involving Any. So the conclusion is this: when generalising
- - at top level use tyVarsOfType
- - in nested bindings use exactTyVarsOfType
-See Trac #1813 for example.
-
-\begin{code}
-exactTyVarsOfType :: TcType -> TyVarSet
--- Find the free type variables (of any kind)
--- but *expand* type synonyms. See Note [Silly type synonym] above.
-exactTyVarsOfType ty
- = go ty
- where
- go ty | Just ty' <- tcView ty = go ty' -- This is the key line
- go (TyVarTy tv) = unitVarSet tv
- go (TyConApp _ tys) = exactTyVarsOfTypes tys
- go (PredTy ty) = go_pred ty
- go (FunTy arg res) = go arg `unionVarSet` go res
- go (AppTy fun arg) = go fun `unionVarSet` go arg
- go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
- `unionVarSet` go_tv tyvar
-
- go_pred (IParam _ ty) = go ty
- go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
- go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2
-
- go_tv tyvar | isCoVar tyvar = go (tyVarKind tyvar)
- | otherwise = emptyVarSet
-
-exactTyVarsOfTypes :: [TcType] -> TyVarSet
-exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
-\end{code}
-
Find the free tycons and classes of a type. This is used in the front
end of the compiler.
orphNamesOfDFunHead dfun_ty
= case tcSplitSigmaTy dfun_ty of
(_, _, head_ty) -> orphNamesOfType head_ty
+
+orphNamesOfCo :: Coercion -> NameSet
+orphNamesOfCo (Refl ty) = orphNamesOfType ty
+orphNamesOfCo (TyConAppCo tc cos) = unitNameSet (getName tc) `unionNameSets` orphNamesOfCos cos
+orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
+orphNamesOfCo (ForAllCo _ co) = orphNamesOfCo co
+orphNamesOfCo (CoVarCo _) = emptyNameSet
+orphNamesOfCo (AxiomInstCo con cos) = orphNamesOfCoCon con `unionNameSets` orphNamesOfCos cos
+orphNamesOfCo (UnsafeCo ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
+orphNamesOfCo (SymCo co) = orphNamesOfCo co
+orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
+orphNamesOfCo (NthCo _ co) = orphNamesOfCo co
+orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSets` orphNamesOfType ty
+
+orphNamesOfCos :: [Coercion] -> NameSet
+orphNamesOfCos = foldr (unionNameSets . orphNamesOfCo) emptyNameSet
+
+orphNamesOfCoCon :: CoAxiom -> NameSet
+orphNamesOfCoCon (CoAxiom { co_ax_lhs = ty1, co_ax_rhs = ty2 })
+ = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
\end{code}
being the )
\begin{code}
-tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, CoercionI)
+tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, Coercion)
-- (isIOType t) returns Just (IO,t',co)
-- if co : t ~ IO t'
-- returns Nothing otherwise
Just (io_tycon, [io_res_ty])
| io_tycon `hasKey` ioTyConKey
- -> Just (io_tycon, io_res_ty, IdCo ty)
+ -> Just (io_tycon, io_res_ty, mkReflCo ty)
Just (tc, tys)
| not (isRecursiveTyCon tc)
-- Newtypes that require a coercion are ok
-> case tcSplitIOType_maybe ty of
Nothing -> Nothing
- Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCoI` co2)
+ Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCo` co2)
_ -> Nothing
matchExpectedListTy, matchExpectedPArrTy,
matchExpectedTyConApp, matchExpectedAppTy,
matchExpectedFunTys, matchExpectedFunKind,
- wrapFunResCoercion
+ wrapFunResCoercion, failWithMisMatch
) where
#include "HsVersions.h"
import HsSyn
import TypeRep
import CoreUtils( mkPiTypes )
-import TcErrors ( unifyCtxt )
+import TcErrors ( unifyCtxt )
import TcMType
import TcIface
import TcRnMonad
import Name
import ErrUtils
import BasicTypes
-
import Maybes ( allMaybes )
import Util
import Outputable
matchExpectedFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys]
-> Arity
-> TcRhoType
- -> TcM (CoercionI, [TcSigmaType], TcRhoType)
+ -> TcM (Coercion, [TcSigmaType], TcRhoType)
-- If matchExpectFunTys n ty = (co, [t1,..,tn], ty_r)
-- then co : ty ~ (t1 -> ... -> tn -> ty_r)
-- then co : ty ~ t1 -> .. -> tn -> ty_r
go n_req ty
- | n_req == 0 = return (IdCo ty, [], ty)
+ | n_req == 0 = return (mkReflCo ty, [], ty)
go n_req ty
| Just ty' <- tcView ty = go n_req ty'
go n_req (FunTy arg_ty res_ty)
| not (isPredTy arg_ty)
= do { (coi, tys, ty_r) <- go (n_req-1) res_ty
- ; return (mkFunTyCoI (IdCo arg_ty) coi, arg_ty:tys, ty_r) }
+ ; return (mkFunCo (mkReflCo arg_ty) coi, arg_ty:tys, ty_r) }
go _ (TyConApp tc _) -- A common case
| not (isSynFamilyTyCon tc)
\begin{code}
----------------------
-matchExpectedListTy :: TcRhoType -> TcM (CoercionI, TcRhoType)
+matchExpectedListTy :: TcRhoType -> TcM (Coercion, TcRhoType)
-- Special case for lists
matchExpectedListTy exp_ty
= do { (coi, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty
; return (coi, elt_ty) }
----------------------
-matchExpectedPArrTy :: TcRhoType -> TcM (CoercionI, TcRhoType)
+matchExpectedPArrTy :: TcRhoType -> TcM (Coercion, TcRhoType)
-- Special case for parrs
matchExpectedPArrTy exp_ty
= do { (coi, [elt_ty]) <- matchExpectedTyConApp parrTyCon exp_ty
----------------------
matchExpectedTyConApp :: TyCon -- T :: k1 -> ... -> kn -> *
-> TcRhoType -- orig_ty
- -> TcM (CoercionI, -- T a b c ~ orig_ty
+ -> TcM (Coercion, -- T a b c ~ orig_ty
[TcSigmaType]) -- Element types, a b c
-- It's used for wired-in tycons, so we call checkWiredInTyCon
= do { checkWiredInTyCon tc
; go (tyConArity tc) orig_ty [] }
where
- go :: Int -> TcRhoType -> [TcSigmaType] -> TcM (CoercionI, [TcSigmaType])
+ go :: Int -> TcRhoType -> [TcSigmaType] -> TcM (Coercion, [TcSigmaType])
-- If go n ty tys = (co, [t1..tn] ++ tys)
-- then co : T t1..tn ~ ty
go n_req ty@(TyConApp tycon args) tys
| tc == tycon
= ASSERT( n_req == length args) -- ty::*
- return (IdCo ty, args ++ tys)
+ return (mkReflCo ty, args ++ tys)
go n_req (AppTy fun arg) tys
| n_req > 0
= do { (coi, args) <- go (n_req - 1) fun (arg : tys)
- ; return (mkAppTyCoI coi (IdCo arg), args) }
+ ; return (mkAppCo coi (mkReflCo arg), args) }
go n_req ty tys = defer n_req ty tys
----------------------
matchExpectedAppTy :: TcRhoType -- orig_ty
- -> TcM (CoercionI, -- m a ~ orig_ty
+ -> TcM (Coercion, -- m a ~ orig_ty
(TcSigmaType, TcSigmaType)) -- Returns m, a
-- If the incoming type is a mutable type variable of kind k, then
-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.
| Just ty' <- tcView ty = go ty'
| Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
- = return (IdCo orig_ty, (fun_ty, arg_ty))
+ = return (mkReflCo orig_ty, (fun_ty, arg_ty))
go (TyVarTy tv)
| ASSERT( isTcTyVar tv) isMetaTyVar tv
<- tcGen ctxt ty_expected $ \ _ sk_rho -> do
{ (in_wrap, in_rho) <- deeplyInstantiate origin ty_actual
; coi <- unifyType in_rho sk_rho
- ; return (coiToHsWrapper coi <.> in_wrap) }
+ ; return (coToHsWrapper coi <.> in_wrap) }
; return (sk_wrap <.> inst_wrap) }
| otherwise -- Urgh! It seems deeply weird to have equality
-- when actual is not a polytype, and it makes a big
-- difference e.g. tcfail104
= do { coi <- unifyType ty_actual ty_expected
- ; return (coiToHsWrapper coi) }
+ ; return (coToHsWrapper coi) }
tcInfer :: (TcType -> TcM a) -> TcM (a, TcType)
tcInfer tc_infer = do { ty <- newFlexiTyVarTy openTypeKind
tcWrapResult expr actual_ty res_ty
= do { coi <- unifyType actual_ty res_ty
-- Both types are deeply skolemised
- ; return (mkHsWrapCoI coi expr) }
+ ; return (mkHsWrapCo coi expr) }
-----------------------------------
wrapFunResCoercion
\begin{code}
---------------
-unifyType :: TcTauType -> TcTauType -> TcM CoercionI
+unifyType :: TcTauType -> TcTauType -> TcM Coercion
-- Actual and expected types
-- Returns a coercion : ty1 ~ ty2
unifyType ty1 ty2 = uType [] ty1 ty2
---------------
-unifyPred :: PredType -> PredType -> TcM CoercionI
+unifyPred :: PredType -> PredType -> TcM Coercion
-- Actual and expected types
unifyPred p1 p2 = uPred [UnifyOrigin (mkPredTy p1) (mkPredTy p2)] p1 p2
---------------
-unifyTheta :: TcThetaType -> TcThetaType -> TcM [CoercionI]
+unifyTheta :: TcThetaType -> TcThetaType -> TcM [Coercion]
-- Actual and expected types
unifyTheta theta1 theta2
= do { checkTc (equalLength theta1 theta2)
:: [EqOrigin]
-> TcType -- ty1 is the *actual* type
-> TcType -- ty2 is the *expected* type
- -> TcM CoercionI
+ -> TcM Coercion
--------------
-- It is always safe to defer unification to the main constraint solver
; doc <- mkErrInfo emptyTidyEnv ctxt
; traceTc "utype_defer" (vcat [ppr co_var, ppr ty1, ppr ty2, ppr origin, doc])
- ; return $ ACo $ mkTyVarTy co_var }
+ ; return $ mkCoVarCo co_var }
uType_defer [] _ _
= panic "uType_defer"
[ sep [ ppr orig_ty1, text "~", ppr orig_ty2]
, ppr origin]
; coi <- go orig_ty1 orig_ty2
- ; case coi of
- ACo co -> traceTc "u_tys yields coercion:" (ppr co)
- IdCo _ -> traceTc "u_tys yields no coercion" empty
+ ; if isReflCo coi
+ then traceTc "u_tys yields no coercion" empty
+ else traceTc "u_tys yields coercion:" (ppr coi)
; return coi }
where
bale_out :: [EqOrigin] -> TcM a
bale_out origin = failWithMisMatch origin
- go :: TcType -> TcType -> TcM CoercionI
+ go :: TcType -> TcType -> TcM Coercion
-- The arguments to 'go' are always semantically identical
-- to orig_ty{1,2} except for looking through type synonyms
| Just ty1' <- tcView ty1 = go ty1' ty2
| Just ty2' <- tcView ty2 = go ty1 ty2'
-
-- Predicates
go (PredTy p1) (PredTy p2) = uPred origin p1 p2
- -- Coercion functions: (t1a ~ t1b) => t1c ~ (t2a ~ t2b) => t2c
- go ty1 ty2
- | Just (t1a,t1b,t1c) <- splitCoPredTy_maybe ty1,
- Just (t2a,t2b,t2c) <- splitCoPredTy_maybe ty2
- = do { co1 <- uType origin t1a t2a
- ; co2 <- uType origin t1b t2b
- ; co3 <- uType origin t1c t2c
- ; return $ mkCoPredCoI co1 co2 co3 }
-
-- Functions (or predicate functions) just check the two parts
go (FunTy fun1 arg1) (FunTy fun2 arg2)
= do { coi_l <- uType origin fun1 fun2
; coi_r <- uType origin arg1 arg2
- ; return $ mkFunTyCoI coi_l coi_r }
+ ; return $ mkFunCo coi_l coi_r }
-- Always defer if a type synonym family (type function)
-- is involved. (Data families behave rigidly.)
go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
| tc1 == tc2 -- See Note [TyCon app]
= do { cois <- uList origin uType tys1 tys2
- ; return $ mkTyConAppCoI tc1 cois }
+ ; return $ mkTyConAppCo tc1 cois }
-- See Note [Care with type applications]
go (AppTy s1 t1) ty2
| Just (s2,t2) <- tcSplitAppTy_maybe ty2
= do { coi_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy]
; coi_t <- uType origin t1 t2
- ; return $ mkAppTyCoI coi_s coi_t }
+ ; return $ mkAppCo coi_s coi_t }
go ty1 (AppTy s2 t2)
| Just (s1,t1) <- tcSplitAppTy_maybe ty1
= do { coi_s <- uType_np origin s1 s2
; coi_t <- uType origin t1 t2
- ; return $ mkAppTyCoI coi_s coi_t }
+ ; return $ mkAppCo coi_s coi_t }
go ty1 ty2
| tcIsForAllTy ty1 || tcIsForAllTy ty2
-- Anything else fails
go _ _ = bale_out origin
-unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM CoercionI
+unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM Coercion
unifySigmaTy origin ty1 ty2
= do { let (tvs1, body1) = tcSplitForAllTys ty1
(tvs2, body2) = tcSplitForAllTys ty2
-- Get location from monad, not from tvs1
; let tys = mkTyVarTys skol_tvs
in_scope = mkInScopeSet (mkVarSet skol_tvs)
- phi1 = substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1
- phi2 = substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2
--- untch = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+ phi1 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1
+ phi2 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2
; ((coi, _untch), lie) <- captureConstraints $
captureUntouchables $
(failWithMisMatch origin) -- ToDo: give details from bad_lie
; emitConstraints lie
- ; return (foldr mkForAllTyCoI coi skol_tvs) }
+ ; return (foldr mkForAllCo coi skol_tvs) }
----------
-uPred :: [EqOrigin] -> PredType -> PredType -> TcM CoercionI
+uPred :: [EqOrigin] -> PredType -> PredType -> TcM Coercion
uPred origin (IParam n1 t1) (IParam n2 t2)
| n1 == n2
= do { coi <- uType origin t1 t2
- ; return $ mkIParamPredCoI n1 coi }
+ ; return $ mkPredCo $ IParam n1 coi }
uPred origin (ClassP c1 tys1) (ClassP c2 tys2)
| c1 == c2
= do { cois <- uList origin uType tys1 tys2
-- Guaranteed equal lengths because the kinds check
- ; return $ mkClassPPredCoI c1 cois }
+ ; return $ mkPredCo $ ClassP c1 cois }
+
uPred origin (EqPred ty1a ty1b) (EqPred ty2a ty2b)
- = do { coia <- uType origin ty1a ty2a
- ; coib <- uType origin ty1b ty2b
- ; return $ mkEqPredCoI coia coib }
+ = do { coa <- uType origin ty1a ty2a
+ ; cob <- uType origin ty1b ty2b
+ ; return $ mkPredCo $ EqPred coa cob }
uPred origin _ _ = failWithMisMatch origin
back into @uTys@ if it turns out that the variable is already bound.
\begin{code}
-uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM CoercionI
+uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM Coercion
uVar origin swapped tv1 ty2
= do { traceTc "uVar" (vcat [ ppr origin
, ppr swapped
-> SwapFlag
-> TcTyVar -> TcTyVarDetails -- Tyvar 1
-> TcTauType -- Type 2
- -> TcM CoercionI
+ -> TcM Coercion
-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar
-- It might be a skolem, or untouchable, or meta
uUnfilledVar origin swapped tv1 details1 (TyVarTy tv2)
| tv1 == tv2 -- Same type variable => no-op
- = return (IdCo (mkTyVarTy tv1))
+ = return (mkReflCo (mkTyVarTy tv1))
| otherwise -- Distinct type variables
= do { lookup2 <- lookupTcTyVar tv2
-> SwapFlag
-> TcTyVar -> TcTyVarDetails -- Tyvar 1
-> TcTyVar -> TcTyVarDetails -- Tyvar 2
- -> TcM CoercionI
+ -> TcM Coercion
-- Invarant: The type variables are distinct,
-- Neither is filled in yet
details = ASSERT2( isTcTyVar tyvar, ppr tyvar )
tcTyVarDetails tyvar
-updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM CoercionI
+updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM Coercion
updateMeta tv1 ref1 ty2
= do { writeMetaTyVarRef tv1 ref1 ty2
- ; return (IdCo ty2) }
+ ; return (mkReflCo ty2) }
\end{code}
Note [Unifying untouchables]
module TcUnify where
import TcType ( TcTauType )
import TcRnTypes( TcM )
-import Coercion (CoercionI)
+import Coercion (Coercion)
-- This boot file exists only to tie the knot between
-- TcUnify and TcSimplify
-unifyType :: TcTauType -> TcTauType -> TcM CoercionI
+unifyType :: TcTauType -> TcTauType -> TcM Coercion
\end{code}
data DefMeth = NoDefMeth -- No default method
| DefMeth Name -- A polymorphic default method
- | GenDefMeth -- A generic default method
+ | GenDefMeth Name -- A generic default method
deriving Eq
-- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in
= case meth of
NoDefMeth -> NoDM
DefMeth _ -> VanillaDM
- GenDefMeth -> GenericDM
+ GenDefMeth _ -> GenericDM
\end{code}
showsPrec p c = showsPrecSDoc p (ppr c)
instance Outputable DefMeth where
- ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n
- ppr GenDefMeth = ptext (sLit "Generic default method")
- ppr NoDefMeth = empty -- No default method
+ ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n
+ ppr (GenDefMeth n) = ptext (sLit "Generic default method") <+> ppr n
+ ppr NoDefMeth = empty -- No default method
pprFundeps :: Outputable a => [FunDep a] -> SDoc
pprFundeps [] = empty
-- as used in System FC. See 'CoreSyn.Expr' for
-- more on System FC and how coercions fit into it.
--
--- Coercions are represented as types, and their kinds tell what types the
--- coercion works on. The coercion kind constructor is a special TyCon that
--- must always be saturated, like so:
---
--- > typeKind (symCoercion type) :: TyConApp CoTyCon{...} [type, type]
module Coercion (
-- * Main data type
- Coercion, Kind,
- typeKind,
+ Coercion(..), Var, CoVar,
-- ** Deconstructing Kinds
kindFunResult, kindAppResult, synTyConResKind,
-- ** Predicates on Kinds
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind,
- isCoSuperKind, isSuperKind, isCoercionKind,
+ isSuperKind, isCoercionKind,
mkArrowKind, mkArrowKinds,
isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind,
isSubKindCon,
- mkCoKind, mkCoPredTy, coVarKind, coVarKind_maybe,
- coercionKind, coercionKinds, isIdentityCoercion,
-
- -- ** Equality predicates
- isEqPred, mkEqPred, getEqPredTys, isEqPredTy,
-
- -- ** Coercion transformations
- mkCoercion,
- mkSymCoercion, mkTransCoercion,
- mkLeftCoercion, mkRightCoercion,
- mkInstCoercion, mkAppCoercion, mkTyConCoercion, mkFunCoercion,
- mkForAllCoercion, mkInstsCoercion, mkUnsafeCoercion,
- mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion,
- mkCsel1Coercion, mkCsel2Coercion, mkCselRCoercion,
-
- mkClassPPredCo, mkIParamPredCo, mkEqPredCo,
- mkCoVarCoercion, mkCoPredCo,
+ mkCoType, coVarKind, coVarKind_maybe,
+ coercionType, coercionKind, coercionKinds, isReflCo,
-
- unsafeCoercionTyCon, symCoercionTyCon,
- transCoercionTyCon, leftCoercionTyCon,
- rightCoercionTyCon, instCoercionTyCon, -- needed by TysWiredIn
- csel1CoercionTyCon, csel2CoercionTyCon, cselRCoercionTyCon,
+ -- ** Constructing coercions
+ mkReflCo, mkCoVarCo,
+ mkAxInstCo, mkPiCo, mkPiCos,
+ mkSymCo, mkTransCo, mkNthCo,
+ mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo,
+ mkForAllCo, mkUnsafeCo,
+ mkNewTypeCo, mkFamInstCo,
+ mkPredCo,
-- ** Decomposition
- decompLR_maybe, decompCsel_maybe, decompInst_maybe,
splitCoPredTy_maybe,
splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo,
-
+ getCoVar_maybe,
+
+ splitTyConAppCo_maybe,
+ splitAppCo_maybe,
+ splitForAllCo_maybe,
+
+ -- ** Coercion variables
+ mkCoVar, isCoVar, isCoVarType, coVarName, setCoVarName, setCoVarUnique,
+
+ -- ** Free variables
+ tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, coercionSize,
+
+ -- ** Substitution
+ CvSubstEnv, emptyCvSubstEnv,
+ CvSubst(..), emptyCvSubst, Coercion.lookupTyVar, lookupCoVar,
+ isEmptyCvSubst, zapCvSubstEnv, getCvInScope,
+ substCo, substCos, substCoVar, substCoVars,
+ substCoWithTy, substCoWithTys,
+ cvTvSubst, tvCvSubst, zipOpenCvSubst,
+ substTy, extendTvSubst,
+ substTyVarBndr, substCoVarBndr,
+
+ -- ** Lifting
+ liftCoMatch, liftCoSubst, liftCoSubstTyVar, liftCoSubstWith,
+
-- ** Comparison
coreEqCoercion, coreEqCoercion2,
- -- * CoercionI
- CoercionI(..),
- isIdentityCoI,
- mkSymCoI, mkTransCoI,
- mkTyConAppCoI, mkAppTyCoI, mkFunTyCoI,
- mkForAllTyCoI,
- fromCoI,
- mkClassPPredCoI, mkIParamPredCoI, mkEqPredCoI, mkCoPredCoI
+ -- ** Forcing evaluation of coercions
+ seqCo,
+
+ -- * Pretty-printing
+ pprCo, pprParendCo, pprCoAxiom,
+ -- * Other
+ applyCo, coVarPred
+
) where
#include "HsVersions.h"
+import Unify ( MatchEnv(..), ruleMatchTyX, matchList )
import TypeRep
-import Type
+import qualified Type
+import Type hiding( substTy, substTyVarBndr, extendTvSubst )
+import Kind
+import Class ( classTyCon )
import TyCon
-import Class
import Var
import VarEnv
import VarSet
-import Name
-import PrelNames
+import UniqFM ( minusUFM )
+import Maybes ( orElse )
+import Name ( Name, NamedThing(..), nameUnique )
+import OccName ( isSymOcc )
import Util
import BasicTypes
import Outputable
+import Unique
+import Pair
+import TysPrim ( eqPredPrimTyCon )
+import PrelNames ( funTyConKey )
+import Control.Applicative
+import Data.Traversable (traverse, sequenceA)
+import Control.Arrow (second)
import FastString
+
+import qualified Data.Data as Data hiding ( TyCon )
\end{code}
%************************************************************************
%* *
- Functions over Kinds
+ Coercions
%* *
%************************************************************************
\begin{code}
--- | Essentially 'funResultTy' on kinds
-kindFunResult :: Kind -> Kind
-kindFunResult k = funResultTy k
-
-kindAppResult :: Kind -> [arg] -> Kind
-kindAppResult k [] = k
-kindAppResult k (_:as) = kindAppResult (kindFunResult k) as
-
--- | Essentially 'splitFunTys' on kinds
-splitKindFunTys :: Kind -> ([Kind],Kind)
-splitKindFunTys k = splitFunTys k
-
-splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind)
-splitKindFunTy_maybe = splitFunTy_maybe
-
--- | Essentially 'splitFunTysN' on kinds
-splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
-splitKindFunTysN k = splitFunTysN k
-
--- | Find the result 'Kind' of a type synonym,
--- after applying it to its 'arity' number of type variables
--- Actually this function works fine on data types too,
--- but they'd always return '*', so we never need to ask
-synTyConResKind :: TyCon -> Kind
-synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon)
-
--- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
-isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool
-isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon,
- isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool
-
-isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey
-
-isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc
-isOpenTypeKind _ = False
-
-isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey
-
-isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc
-isUbxTupleKind _ = False
-
-isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey
-
-isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc
-isArgTypeKind _ = False
-
-isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey
-
-isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc
-isUnliftedTypeKind _ = False
-
-isSubOpenTypeKind :: Kind -> Bool
--- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
-isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) )
- ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) )
- False
-isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True
-isSubOpenTypeKind other = ASSERT( isKind other ) False
- -- This is a conservative answer
- -- It matters in the call to isSubKind in
- -- checkExpectedKind.
-
-isSubArgTypeKindCon kc
- | isUnliftedTypeKindCon kc = True
- | isLiftedTypeKindCon kc = True
- | isArgTypeKindCon kc = True
- | otherwise = False
-
-isSubArgTypeKind :: Kind -> Bool
--- ^ True of any sub-kind of ArgTypeKind
-isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc
-isSubArgTypeKind _ = False
-
--- | Is this a super-kind (i.e. a type-of-kinds)?
-isSuperKind :: Type -> Bool
-isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc
-isSuperKind _ = False
-
--- | Is this a kind (i.e. a type-of-types)?
-isKind :: Kind -> Bool
-isKind k = isSuperKind (typeKind k)
-
-isSubKind :: Kind -> Kind -> Bool
--- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@
-isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2
-isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
-isSubKind (PredTy (EqPred ty1 ty2)) (PredTy (EqPred ty1' ty2'))
- = ty1 `tcEqType` ty1' && ty2 `tcEqType` ty2'
-isSubKind _ _ = False
-
-eqKind :: Kind -> Kind -> Bool
-eqKind = tcEqType
-
-isSubKindCon :: TyCon -> TyCon -> Bool
--- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@
-isSubKindCon kc1 kc2
- | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True
- | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True
- | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True
- | isOpenTypeKindCon kc2 = True
- -- we already know kc1 is not a fun, its a TyCon
- | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True
- | otherwise = False
-
-defaultKind :: Kind -> Kind
--- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more
--- information on what that means
-
--- When we generalise, we make generic type variables whose kind is
--- simple (* or *->* etc). So generic type variables (other than
--- built-in constants like 'error') always have simple kinds. This is important;
--- consider
--- f x = True
--- We want f to get type
--- f :: forall (a::*). a -> Bool
--- Not
--- f :: forall (a::??). a -> Bool
--- because that would allow a call like (f 3#) as well as (f True),
---and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr.
-defaultKind k
- | isSubOpenTypeKind k = liftedTypeKind
- | isSubArgTypeKind k = liftedTypeKind
- | otherwise = k
+-- | A 'Coercion' is concrete evidence of the equality/convertibility
+-- of two types.
+
+data Coercion
+ -- These ones mirror the shape of types
+ = Refl Type -- See Note [Refl invariant]
+ -- Invariant: applications of (Refl T) to a bunch of identity coercions
+ -- always show up as Refl.
+ -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)).
+
+ -- Applications of (Refl T) to some coercions, at least one of
+ -- which is NOT the identity, show up as TyConAppCo.
+ -- (They may not be fully saturated however.)
+ -- ConAppCo coercions (like all coercions other than Refl)
+ -- are NEVER the identity.
+
+ -- These ones simply lift the correspondingly-named
+ -- Type constructors into Coercions
+ | TyConAppCo TyCon [Coercion] -- lift TyConApp
+ -- The TyCon is never a synonym;
+ -- we expand synonyms eagerly
+
+ | AppCo Coercion Coercion -- lift AppTy
+
+ -- See Note [Forall coercions]
+ | ForAllCo TyVar Coercion -- forall a. g
+
+ -- These are special
+ | CoVarCo CoVar
+ | AxiomInstCo CoAxiom [Coercion] -- The coercion arguments always *precisely*
+ -- saturate arity of CoAxiom.
+ -- See [Coercion axioms applied to coercions]
+ | UnsafeCo Type Type
+ | SymCo Coercion
+ | TransCo Coercion Coercion
+
+ -- These are destructors
+ | NthCo Int Coercion -- Zero-indexed
+ | InstCo Coercion Type
+ deriving (Data.Data, Data.Typeable)
\end{code}
+Note [Refl invariant]
+~~~~~~~~~~~~~~~~~~~~~
+Coercions have the following invariant
+ Refl is always lifted as far as possible.
+
+You might think that a consequencs is:
+ Every identity coercions has Refl at the root
+
+But that's not quite true because of coercion variables. Consider
+ g where g :: Int~Int
+ Left h where h :: Maybe Int ~ Maybe Int
+etc. So the consequence is only true of coercions that
+have no coercion variables.
+
+Note [Coercion axioms applied to coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The reason coercion axioms can be applied to coercions and not just
+types is to allow for better optimization. There are some cases where
+we need to be able to "push transitivity inside" an axiom in order to
+expose further opportunities for optimization.
+
+For example, suppose we have
+
+ C a : t[a] ~ F a
+ g : b ~ c
+
+and we want to optimize
+
+ sym (C b) ; t[g] ; C c
+
+which has the kind
+
+ F b ~ F c
+
+(stopping through t[b] and t[c] along the way).
+
+We'd like to optimize this to just F g -- but how? The key is
+that we need to allow axioms to be instantiated by *coercions*,
+not just by types. Then we can (in certain cases) push
+transitivity inside the axiom instantiations, and then react
+opposite-polarity instantiations of the same axiom. In this
+case, e.g., we match t[g] against the LHS of (C c)'s kind, to
+obtain the substitution a |-> g (note this operation is sort
+of the dual of lifting!) and hence end up with
+
+ C g : t[b] ~ F c
+
+which indeed has the same kind as t[g] ; C c.
+
+Now we have
+
+ sym (C b) ; C g
+
+which can be optimized to F g.
+
+
+Note [Forall coercions]
+~~~~~~~~~~~~~~~~~~~~~~~
+Constructing coercions between forall-types can be a bit tricky.
+Currently, the situation is as follows:
+
+ ForAllCo TyVar Coercion
+
+represents a coercion between polymorphic types, with the rule
+
+ v : k g : t1 ~ t2
+ ----------------------------------------------
+ ForAllCo v g : (all v:k . t1) ~ (all v:k . t2)
+
+Note that it's only necessary to coerce between polymorphic types
+where the type variables have identical kinds, because equality on
+kinds is trivial.
+
+Note [Predicate coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+ g :: a~b
+How can we coerce between types
+ ([c]~a) => [a] -> c
+and
+ ([c]~b) => [b] -> c
+where the equality predicate *itself* differs?
+
+Answer: we simply treat (~) as an ordinary type constructor, so these
+types really look like
+
+ ((~) [c] a) -> [a] -> c
+ ((~) [c] b) -> [b] -> c
+
+So the coercion between the two is obviously
+
+ ((~) [c] g) -> [g] -> c
+
+Another way to see this to say that we simply collapse predicates to
+their representation type (see Type.coreView and Type.predTypeRep).
+
+This collapse is done by mkPredCo; there is no PredCo constructor
+in Coercion. This is important because we need Nth to work on
+predicates too:
+ Nth 1 ((~) [c] g) = g
+See Simplify.simplCoercionF, which generates such selections.
+
%************************************************************************
%* *
- Coercions
+\subsection{Coercion variables}
+%* *
+%************************************************************************
+
+\begin{code}
+coVarName :: CoVar -> Name
+coVarName = varName
+
+setCoVarUnique :: CoVar -> Unique -> CoVar
+setCoVarUnique = setVarUnique
+
+setCoVarName :: CoVar -> Name -> CoVar
+setCoVarName = setVarName
+
+isCoVar :: Var -> Bool
+isCoVar v = isCoVarType (varType v)
+
+isCoVarType :: Type -> Bool
+isCoVarType = isEqPredTy
+\end{code}
+
+
+\begin{code}
+tyCoVarsOfCo :: Coercion -> VarSet
+-- Extracts type and coercion variables from a coercion
+tyCoVarsOfCo (Refl ty) = tyVarsOfType ty
+tyCoVarsOfCo (TyConAppCo _ cos) = tyCoVarsOfCos cos
+tyCoVarsOfCo (AppCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
+tyCoVarsOfCo (ForAllCo tv co) = tyCoVarsOfCo co `delVarSet` tv
+tyCoVarsOfCo (CoVarCo v) = unitVarSet v
+tyCoVarsOfCo (AxiomInstCo _ cos) = tyCoVarsOfCos cos
+tyCoVarsOfCo (UnsafeCo ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+tyCoVarsOfCo (SymCo co) = tyCoVarsOfCo co
+tyCoVarsOfCo (TransCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2
+tyCoVarsOfCo (NthCo _ co) = tyCoVarsOfCo co
+tyCoVarsOfCo (InstCo co ty) = tyCoVarsOfCo co `unionVarSet` tyVarsOfType ty
+
+tyCoVarsOfCos :: [Coercion] -> VarSet
+tyCoVarsOfCos cos = foldr (unionVarSet . tyCoVarsOfCo) emptyVarSet cos
+
+coVarsOfCo :: Coercion -> VarSet
+-- Extract *coerction* variables only. Tiresome to repeat the code, but easy.
+coVarsOfCo (Refl _) = emptyVarSet
+coVarsOfCo (TyConAppCo _ cos) = coVarsOfCos cos
+coVarsOfCo (AppCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
+coVarsOfCo (ForAllCo _ co) = coVarsOfCo co
+coVarsOfCo (CoVarCo v) = unitVarSet v
+coVarsOfCo (AxiomInstCo _ cos) = coVarsOfCos cos
+coVarsOfCo (UnsafeCo _ _) = emptyVarSet
+coVarsOfCo (SymCo co) = coVarsOfCo co
+coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2
+coVarsOfCo (NthCo _ co) = coVarsOfCo co
+coVarsOfCo (InstCo co _) = coVarsOfCo co
+
+coVarsOfCos :: [Coercion] -> VarSet
+coVarsOfCos cos = foldr (unionVarSet . coVarsOfCo) emptyVarSet cos
+
+coercionSize :: Coercion -> Int
+coercionSize (Refl ty) = typeSize ty
+coercionSize (TyConAppCo _ cos) = 1 + sum (map coercionSize cos)
+coercionSize (AppCo co1 co2) = coercionSize co1 + coercionSize co2
+coercionSize (ForAllCo _ co) = 1 + coercionSize co
+coercionSize (CoVarCo _) = 1
+coercionSize (AxiomInstCo _ cos) = 1 + sum (map coercionSize cos)
+coercionSize (UnsafeCo ty1 ty2) = typeSize ty1 + typeSize ty2
+coercionSize (SymCo co) = 1 + coercionSize co
+coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2
+coercionSize (NthCo _ co) = 1 + coercionSize co
+coercionSize (InstCo co ty) = 1 + coercionSize co + typeSize ty
+\end{code}
+
+%************************************************************************
%* *
+ Pretty-printing coercions
+%* *
%************************************************************************
+@pprCo@ is the standard @Coercion@ printer; the overloaded @ppr@
+function is defined to use this. @pprParendCo@ is the same, except it
+puts parens around the type, except for the atomic cases.
+@pprParendCo@ works just by setting the initial context precedence
+very high.
\begin{code}
--- | A 'Coercion' represents a 'Type' something should be coerced to.
-type Coercion = Type
+instance Outputable Coercion where
+ ppr = pprCo
+
+pprCo, pprParendCo :: Coercion -> SDoc
+pprCo co = ppr_co TopPrec co
+pprParendCo co = ppr_co TyConPrec co
+
+ppr_co :: Prec -> Coercion -> SDoc
+ppr_co _ (Refl ty) = angles (ppr ty)
+
+ppr_co p co@(TyConAppCo tc cos)
+ | tc `hasKey` funTyConKey = ppr_fun_co p co
+ | otherwise = pprTcApp p ppr_co tc cos
+
+ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $
+ pprCo co1 <+> ppr_co TyConPrec co2
+
+ppr_co p co@(ForAllCo {}) = ppr_forall_co p co
+
+ppr_co _ (CoVarCo cv)
+ | isSymOcc (getOccName cv) = parens (ppr cv)
+ | otherwise = ppr cv
+
+ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos
--- | A 'CoercionKind' is always of form @ty1 ~ ty2@ and indicates the
--- types that a 'Coercion' will work on.
-type CoercionKind = Kind
-------------------------------
+ppr_co p (TransCo co1 co2) = maybeParen p FunPrec $
+ ppr_co FunPrec co1
+ <+> ptext (sLit ";")
+ <+> ppr_co FunPrec co2
+ppr_co p (InstCo co ty) = maybeParen p TyConPrec $
+ pprParendCo co <> ptext (sLit "@") <> pprType ty
--- | This breaks a 'Coercion' with 'CoercionKind' @T A B C ~ T D E F@ into
+ppr_co p (UnsafeCo ty1 ty2) = pprPrefixApp p (ptext (sLit "UnsafeCo")) [pprParendType ty1, pprParendType ty2]
+ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co]
+ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendCo co]
+
+
+angles :: SDoc -> SDoc
+angles p = char '<' <> p <> char '>'
+
+ppr_fun_co :: Prec -> Coercion -> SDoc
+ppr_fun_co p co = pprArrowChain p (split co)
+ where
+ split (TyConAppCo f [arg,res])
+ | f `hasKey` funTyConKey
+ = ppr_co FunPrec arg : split res
+ split co = [ppr_co TopPrec co]
+
+ppr_forall_co :: Prec -> Coercion -> SDoc
+ppr_forall_co p ty
+ = maybeParen p FunPrec $
+ sep [pprForAll tvs, ppr_co TopPrec rho]
+ where
+ (tvs, rho) = split1 [] ty
+ split1 tvs (ForAllCo tv ty) = split1 (tv:tvs) ty
+ split1 tvs ty = (reverse tvs, ty)
+\end{code}
+
+\begin{code}
+pprCoAxiom :: CoAxiom -> SDoc
+pprCoAxiom ax
+ = sep [ ptext (sLit "axiom") <+> ppr ax <+> ppr (co_ax_tvs ax)
+ , nest 2 (dcolon <+> pprEqPred (Pair (co_ax_lhs ax) (co_ax_rhs ax))) ]
+\end{code}
+
+%************************************************************************
+%* *
+ Functions over Kinds
+%* *
+%************************************************************************
+
+\begin{code}
+-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into
-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence:
--
--- > decomposeCo 3 c = [right (left (left c)), right (left c), right c]
+-- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c]
decomposeCo :: Arity -> Coercion -> [Coercion]
-decomposeCo n co
- = go n co []
- where
- go 0 _ cos = cos
- go n co cos = go (n-1) (mkLeftCoercion co)
- (mkRightCoercion co : cos)
-
+decomposeCo arity co = [mkNthCo n co | n <- [0..(arity-1)] ]
+
+-- | Attempts to obtain the type variable underlying a 'Coercion'
+getCoVar_maybe :: Coercion -> Maybe CoVar
+getCoVar_maybe (CoVarCo cv) = Just cv
+getCoVar_maybe _ = Nothing
+
+-- | Attempts to tease a coercion apart into a type constructor and the application
+-- of a number of coercion arguments to that constructor
+splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion])
+splitTyConAppCo_maybe (Refl ty) = (fmap . second . map) Refl (splitTyConApp_maybe ty)
+splitTyConAppCo_maybe (TyConAppCo tc cos) = Just (tc, cos)
+splitTyConAppCo_maybe _ = Nothing
+
+splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)
+-- ^ Attempt to take a coercion application apart.
+splitAppCo_maybe (AppCo co1 co2) = Just (co1, co2)
+splitAppCo_maybe (TyConAppCo tc cos)
+ | isDecomposableTyCon tc || cos `lengthExceeds` tyConArity tc
+ , Just (cos', co') <- snocView cos
+ = Just (mkTyConAppCo tc cos', co') -- Never create unsaturated type family apps!
+ -- Use mkTyConAppCo to preserve the invariant
+ -- that identity coercions are always represented by Refl
+splitAppCo_maybe (Refl ty)
+ | Just (ty1, ty2) <- splitAppTy_maybe ty
+ = Just (Refl ty1, Refl ty2)
+splitAppCo_maybe _ = Nothing
+
+splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion)
+splitForAllCo_maybe (ForAllCo tv co) = Just (tv, co)
+splitForAllCo_maybe _ = Nothing
-------------------------------------------------------
-- and some coercion kind stuff
+coVarPred :: CoVar -> PredType
+coVarPred cv
+ = ASSERT( isCoVar cv )
+ case splitPredTy_maybe (varType cv) of
+ Just pred -> pred
+ other -> pprPanic "coVarPred" (ppr cv $$ ppr other)
+
coVarKind :: CoVar -> (Type,Type)
-- c :: t1 ~ t2
coVarKind cv = case coVarKind_maybe cv of
Nothing -> pprPanic "coVarKind" (ppr cv $$ ppr (tyVarKind cv))
coVarKind_maybe :: CoVar -> Maybe (Type,Type)
-coVarKind_maybe cv = splitCoKind_maybe (tyVarKind cv)
-
--- | Take a 'CoercionKind' apart into the two types it relates: see also 'mkCoKind'.
--- Panics if the argument is not a valid 'CoercionKind'
-splitCoKind_maybe :: Kind -> Maybe (Type, Type)
-splitCoKind_maybe co | Just co' <- kindView co = splitCoKind_maybe co'
-splitCoKind_maybe (PredTy (EqPred ty1 ty2)) = Just (ty1, ty2)
-splitCoKind_maybe _ = Nothing
+coVarKind_maybe cv = splitEqPredTy_maybe (varType cv)
--- | Makes a 'CoercionKind' from two types: the types whose equality
+-- | Makes a coercion type from two types: the types whose equality
-- is proven by the relevant 'Coercion'
-mkCoKind :: Type -> Type -> CoercionKind
-mkCoKind ty1 ty2 = PredTy (EqPred ty1 ty2)
-
--- | (mkCoPredTy s t r) produces the type: (s~t) => r
-mkCoPredTy :: Type -> Type -> Type -> Type
-mkCoPredTy s t r = ASSERT( not (co_var `elemVarSet` tyVarsOfType r) )
- ForAllTy co_var r
- where
- co_var = mkWildCoVar (mkCoKind s t)
-
-mkCoPredCo :: Coercion -> Coercion -> Coercion -> Coercion
--- Creates a coercion between (s1~t1) => r1 and (s2~t2) => r2
-mkCoPredCo = mkCoPredTy
-
+mkCoType :: Type -> Type -> Type
+mkCoType ty1 ty2 = PredTy (EqPred ty1 ty2)
splitCoPredTy_maybe :: Type -> Maybe (Type, Type, Type)
splitCoPredTy_maybe ty
| otherwise
= Nothing
--- | Tests whether a type is just a type equality predicate
-isEqPredTy :: Type -> Bool
-isEqPredTy (PredTy pred) = isEqPred pred
-isEqPredTy _ = False
-
--- | Creates a type equality predicate
-mkEqPred :: (Type, Type) -> PredType
-mkEqPred (ty1, ty2) = EqPred ty1 ty2
-
--- | Splits apart a type equality predicate, if the supplied 'PredType' is one.
--- Panics otherwise
-getEqPredTys :: PredType -> (Type,Type)
-getEqPredTys (EqPred ty1 ty2) = (ty1, ty2)
-getEqPredTys other = pprPanic "getEqPredTys" (ppr other)
-
-isIdentityCoercion :: Coercion -> Bool
-isIdentityCoercion co
- = case coercionKind co of
- (t1,t2) -> t1 `coreEqType` t2
+isReflCo :: Coercion -> Bool
+isReflCo (Refl {}) = True
+isReflCo _ = False
+
+isReflCo_maybe :: Coercion -> Maybe Type
+isReflCo_maybe (Refl ty) = Just ty
+isReflCo_maybe _ = Nothing
\end{code}
%************************************************************************
%* *
%************************************************************************
-Coercion kind and type mk's (make saturated TyConApp CoercionTyCon{...} args)
-
\begin{code}
--- | Make a coercion from the specified coercion 'TyCon' and the 'Type' arguments to
--- that coercion. Try to use the @mk*Coercion@ family of functions instead of using this function
--- if possible
-mkCoercion :: TyCon -> [Type] -> Coercion
-mkCoercion coCon args = ASSERT( tyConArity coCon == length args )
- TyConApp coCon args
+mkCoVarCo :: CoVar -> Coercion
+mkCoVarCo cv
+ | ty1 `eqType` ty2 = Refl ty1
+ | otherwise = CoVarCo cv
+ where
+ (ty1, ty2) = ASSERT( isCoVar cv ) coVarKind cv
-mkCoVarCoercion :: CoVar -> Coercion
-mkCoVarCoercion cv = mkTyVarTy cv
+mkReflCo :: Type -> Coercion
+mkReflCo = Refl
--- | Apply a 'Coercion' to another 'Coercion', which is presumably a
--- 'Coercion' constructor of some kind
-mkAppCoercion :: Coercion -> Coercion -> Coercion
-mkAppCoercion co1 co2 = mkAppTy co1 co2
+mkAxInstCo :: CoAxiom -> [Type] -> Coercion
+mkAxInstCo ax tys
+ | arity == n_tys = AxiomInstCo ax rtys
+ | otherwise = ASSERT( arity < n_tys )
+ foldl AppCo (AxiomInstCo ax (take arity rtys))
+ (drop arity rtys)
+ where
+ n_tys = length tys
+ arity = coAxiomArity ax
+ rtys = map Refl tys
+
+-- | Apply a 'Coercion' to another 'Coercion'.
+mkAppCo :: Coercion -> Coercion -> Coercion
+mkAppCo (Refl ty1) (Refl ty2) = Refl (mkAppTy ty1 ty2)
+mkAppCo (Refl (TyConApp tc tys)) co = TyConAppCo tc (map Refl tys ++ [co])
+mkAppCo (TyConAppCo tc cos) co = TyConAppCo tc (cos ++ [co])
+mkAppCo co1 co2 = AppCo co1 co2
+-- Note, mkAppCo is careful to maintain invariants regarding
+-- where Refl constructors appear; see the comments in the definition
+-- of Coercion and the Note [Refl invariant] in types/TypeRep.lhs.
-- | Applies multiple 'Coercion's to another 'Coercion', from left to right.
--- See also 'mkAppCoercion'
-mkAppsCoercion :: Coercion -> [Coercion] -> Coercion
-mkAppsCoercion co1 tys = foldl mkAppTy co1 tys
+-- See also 'mkAppCo'
+mkAppCos :: Coercion -> [Coercion] -> Coercion
+mkAppCos co1 tys = foldl mkAppCo co1 tys
-- | Apply a type constructor to a list of coercions.
-mkTyConCoercion :: TyCon -> [Coercion] -> Coercion
-mkTyConCoercion con cos = mkTyConApp con cos
+mkTyConAppCo :: TyCon -> [Coercion] -> Coercion
+mkTyConAppCo tc cos
+ -- Expand type synonyms
+ | Just (tv_co_prs, rhs_ty, leftover_cos) <- tcExpandTyCon_maybe tc cos
+ = mkAppCos (liftCoSubst (mkTopCvSubst tv_co_prs) rhs_ty) leftover_cos
+
+ | Just tys <- traverse isReflCo_maybe cos
+ = Refl (mkTyConApp tc tys) -- See Note [Refl invariant]
+
+ | otherwise = TyConAppCo tc cos
-- | Make a function 'Coercion' between two other 'Coercion's
-mkFunCoercion :: Coercion -> Coercion -> Coercion
-mkFunCoercion co1 co2 = mkFunTy co1 co2 -- NB: Handles correctly the forall for eqpreds!
+mkFunCo :: Coercion -> Coercion -> Coercion
+mkFunCo co1 co2 = mkTyConAppCo funTyCon [co1, co2]
-- | Make a 'Coercion' which binds a variable within an inner 'Coercion'
-mkForAllCoercion :: Var -> Coercion -> Coercion
+mkForAllCo :: Var -> Coercion -> Coercion
-- note that a TyVar should be used here, not a CoVar (nor a TcTyVar)
-mkForAllCoercion tv co = ASSERT ( isTyCoVar tv ) mkForAllTy tv co
+mkForAllCo tv (Refl ty) = ASSERT( isTyVar tv ) Refl (mkForAllTy tv ty)
+mkForAllCo tv co = ASSERT ( isTyVar tv ) ForAllCo tv co
+mkPredCo :: Pred Coercion -> Coercion
+-- See Note [Predicate coercions]
+mkPredCo (EqPred co1 co2) = mkTyConAppCo eqPredPrimTyCon [co1,co2]
+mkPredCo (ClassP cls cos) = mkTyConAppCo (classTyCon cls) cos
+mkPredCo (IParam _ co) = co
-------------------------------
-mkSymCoercion :: Coercion -> Coercion
--- ^ Create a symmetric version of the given 'Coercion' that asserts equality
--- between the same types but in the other "direction", so a kind of @t1 ~ t2@
--- becomes the kind @t2 ~ t1@.
-mkSymCoercion g = mkCoercion symCoercionTyCon [g]
-
-mkTransCoercion :: Coercion -> Coercion -> Coercion
--- ^ Create a new 'Coercion' by exploiting transitivity on the two given 'Coercion's.
-mkTransCoercion g1 g2 = mkCoercion transCoercionTyCon [g1, g2]
-
-mkLeftCoercion :: Coercion -> Coercion
--- ^ From an application 'Coercion' build a 'Coercion' that asserts the equality of
--- the "functions" on either side of the type equality. So if @c@ has kind @f x ~ g y@ then:
---
--- > mkLeftCoercion c :: f ~ g
-mkLeftCoercion co = mkCoercion leftCoercionTyCon [co]
-
-mkRightCoercion :: Coercion -> Coercion
--- ^ From an application 'Coercion' build a 'Coercion' that asserts the equality of
--- the "arguments" on either side of the type equality. So if @c@ has kind @f x ~ g y@ then:
---
--- > mkLeftCoercion c :: x ~ y
-mkRightCoercion co = mkCoercion rightCoercionTyCon [co]
-
-mkCsel1Coercion, mkCsel2Coercion, mkCselRCoercion :: Coercion -> Coercion
-mkCsel1Coercion co = mkCoercion csel1CoercionTyCon [co]
-mkCsel2Coercion co = mkCoercion csel2CoercionTyCon [co]
-mkCselRCoercion co = mkCoercion cselRCoercionTyCon [co]
-
--------------------------------
-mkInstCoercion :: Coercion -> Type -> Coercion
--- ^ Instantiates a 'Coercion' with a 'Type' argument. If possible, it immediately performs
--- the resulting beta-reduction, otherwise it creates a suspended instantiation.
-mkInstCoercion co ty = mkCoercion instCoercionTyCon [co, ty]
-
-mkInstsCoercion :: Coercion -> [Type] -> Coercion
--- ^ As 'mkInstCoercion', but instantiates the coercion with a number of type arguments, left-to-right
-mkInstsCoercion co tys = foldl mkInstCoercion co tys
-
--- | Manufacture a coercion from this air. Needless to say, this is not usually safe,
--- but it is used when we know we are dealing with bottom, which is one case in which
--- it is safe. This is also used implement the @unsafeCoerce#@ primitive.
--- Optimise by pushing down through type constructors
-mkUnsafeCoercion :: Type -> Type -> Coercion
-mkUnsafeCoercion (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+-- | Create a symmetric version of the given 'Coercion' that asserts
+-- equality between the same types but in the other "direction", so
+-- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@.
+mkSymCo :: Coercion -> Coercion
+
+-- Do a few simple optimizations, but don't bother pushing occurrences
+-- of symmetry to the leaves; the optimizer will take care of that.
+mkSymCo co@(Refl {}) = co
+mkSymCo (UnsafeCo ty1 ty2) = UnsafeCo ty2 ty1
+mkSymCo (SymCo co) = co
+mkSymCo co = SymCo co
+
+-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively.
+mkTransCo :: Coercion -> Coercion -> Coercion
+mkTransCo (Refl _) co = co
+mkTransCo co (Refl _) = co
+mkTransCo co1 co2 = TransCo co1 co2
+
+mkNthCo :: Int -> Coercion -> Coercion
+mkNthCo n (Refl ty) = Refl (getNth n ty)
+mkNthCo n co = NthCo n co
+
+-- | Instantiates a 'Coercion' with a 'Type' argument. If possible, it immediately performs
+-- the resulting beta-reduction, otherwise it creates a suspended instantiation.
+mkInstCo :: Coercion -> Type -> Coercion
+mkInstCo (ForAllCo tv co) ty = substCoWithTy tv ty co
+mkInstCo co ty = InstCo co ty
+
+-- | Manufacture a coercion from thin air. Needless to say, this is
+-- not usually safe, but it is used when we know we are dealing with
+-- bottom, which is one case in which it is safe. This is also used
+-- to implement the @unsafeCoerce#@ primitive. Optimise by pushing
+-- down through type constructors.
+mkUnsafeCo :: Type -> Type -> Coercion
+mkUnsafeCo ty1 ty2 | ty1 `eqType` ty2 = Refl ty1
+mkUnsafeCo (TyConApp tc1 tys1) (TyConApp tc2 tys2)
| tc1 == tc2
- = TyConApp tc1 (zipWith mkUnsafeCoercion tys1 tys2)
+ = mkTyConAppCo tc1 (zipWith mkUnsafeCo tys1 tys2)
-mkUnsafeCoercion (FunTy a1 r1) (FunTy a2 r2)
- = FunTy (mkUnsafeCoercion a1 a2) (mkUnsafeCoercion r1 r2)
+mkUnsafeCo (FunTy a1 r1) (FunTy a2 r2)
+ = mkFunCo (mkUnsafeCo a1 a2) (mkUnsafeCo r1 r2)
-mkUnsafeCoercion ty1 ty2
- | ty1 `coreEqType` ty2 = ty1
- | otherwise = mkCoercion unsafeCoercionTyCon [ty1, ty2]
+mkUnsafeCo ty1 ty2 = UnsafeCo ty1 ty2
-- See note [Newtype coercions] in TyCon
--- | Create a coercion suitable for the given 'TyCon'. The 'Name' should be that of a
--- new coercion 'TyCon', the 'TyVar's the arguments expected by the @newtype@ and the
--- type the appropriate right hand side of the @newtype@, with the free variables
--- a subset of those 'TyVar's.
-mkNewTypeCoercion :: Name -> TyCon -> [TyVar] -> Type -> TyCon
-mkNewTypeCoercion name tycon tvs rhs_ty
- = mkCoercionTyCon name arity desc
- where
- arity = length tvs
- desc = CoAxiom { co_ax_tvs = tvs
- , co_ax_lhs = mkTyConApp tycon (mkTyVarTys tvs)
- , co_ax_rhs = rhs_ty }
+-- | Create a coercion constructor (axiom) suitable for the given
+-- newtype 'TyCon'. The 'Name' should be that of a new coercion
+-- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and
+-- the type the appropriate right hand side of the @newtype@, with
+-- the free variables a subset of those 'TyVar's.
+mkNewTypeCo :: Name -> TyCon -> [TyVar] -> Type -> CoAxiom
+mkNewTypeCo name tycon tvs rhs_ty
+ = CoAxiom { co_ax_unique = nameUnique name
+ , co_ax_name = name
+ , co_ax_tvs = tvs
+ , co_ax_lhs = mkTyConApp tycon (mkTyVarTys tvs)
+ , co_ax_rhs = rhs_ty }
-- | Create a coercion identifying a @data@, @newtype@ or @type@ representation type
-- and its family instance. It has the form @Co tvs :: F ts ~ R tvs@, where @Co@ is
--- the coercion tycon built here, @F@ the family tycon and @R@ the (derived)
+-- the coercion constructor built here, @F@ the family tycon and @R@ the (derived)
-- representation tycon.
-mkFamInstCoercion :: Name -- ^ Unique name for the coercion tycon
+mkFamInstCo :: Name -- ^ Unique name for the coercion tycon
-> [TyVar] -- ^ Type parameters of the coercion (@tvs@)
-> TyCon -- ^ Family tycon (@F@)
-> [Type] -- ^ Type instance (@ts@)
-> TyCon -- ^ Representation tycon (@R@)
- -> TyCon -- ^ Coercion tycon (@Co@)
-mkFamInstCoercion name tvs family inst_tys rep_tycon
- = mkCoercionTyCon name arity desc
- where
- arity = length tvs
- desc = CoAxiom { co_ax_tvs = tvs
- , co_ax_lhs = mkTyConApp family inst_tys
- , co_ax_rhs = mkTyConApp rep_tycon (mkTyVarTys tvs) }
-
-
-mkClassPPredCo :: Class -> [Coercion] -> Coercion
-mkClassPPredCo cls = (PredTy . ClassP cls)
-
-mkIParamPredCo :: (IPName Name) -> Coercion -> Coercion
-mkIParamPredCo ipn = (PredTy . IParam ipn)
-
-mkEqPredCo :: Coercion -> Coercion -> Coercion
-mkEqPredCo co1 co2 = PredTy (EqPred co1 co2)
-
-
+ -> CoAxiom -- ^ Coercion constructor (@Co@)
+mkFamInstCo name tvs family inst_tys rep_tycon
+ = CoAxiom { co_ax_unique = nameUnique name
+ , co_ax_name = name
+ , co_ax_tvs = tvs
+ , co_ax_lhs = mkTyConApp family inst_tys
+ , co_ax_rhs = mkTyConApp rep_tycon (mkTyVarTys tvs) }
+
+mkPiCos :: [Var] -> Coercion -> Coercion
+mkPiCos vs co = foldr mkPiCo co vs
+
+mkPiCo :: Var -> Coercion -> Coercion
+mkPiCo v co | isTyVar v = mkForAllCo v co
+ | otherwise = mkFunCo (mkReflCo (varType v)) co
\end{code}
-
-%************************************************************************
-%* *
- Coercion Type Constructors
-%* *
-%************************************************************************
-
-Example. The coercion ((sym c) (sym d) (sym e))
-will be represented by (TyConApp sym [c, sym d, sym e])
-If sym c :: p1=q1
- sym d :: p2=q2
- sym e :: p3=q3
-then ((sym c) (sym d) (sym e)) :: (p1 p2 p3)=(q1 q2 q3)
-
-\begin{code}
--- | Coercion type constructors: avoid using these directly and instead use
--- the @mk*Coercion@ and @split*Coercion@ family of functions if possible.
---
--- Each coercion TyCon is built with the special CoercionTyCon record and
--- carries its own kinding rule. Such CoercionTyCons must be fully applied
--- by any TyConApp in which they are applied, however they may also be over
--- applied (see example above) and the kinding function must deal with this.
-symCoercionTyCon, transCoercionTyCon, leftCoercionTyCon,
- rightCoercionTyCon, instCoercionTyCon, unsafeCoercionTyCon,
- csel1CoercionTyCon, csel2CoercionTyCon, cselRCoercionTyCon :: TyCon
-
-symCoercionTyCon = mkCoercionTyCon symCoercionTyConName 1 CoSym
-transCoercionTyCon = mkCoercionTyCon transCoercionTyConName 2 CoTrans
-leftCoercionTyCon = mkCoercionTyCon leftCoercionTyConName 1 CoLeft
-rightCoercionTyCon = mkCoercionTyCon rightCoercionTyConName 1 CoRight
-instCoercionTyCon = mkCoercionTyCon instCoercionTyConName 2 CoInst
-csel1CoercionTyCon = mkCoercionTyCon csel1CoercionTyConName 1 CoCsel1
-csel2CoercionTyCon = mkCoercionTyCon csel2CoercionTyConName 1 CoCsel2
-cselRCoercionTyCon = mkCoercionTyCon cselRCoercionTyConName 1 CoCselR
-unsafeCoercionTyCon = mkCoercionTyCon unsafeCoercionTyConName 2 CoUnsafe
-
-transCoercionTyConName, symCoercionTyConName, leftCoercionTyConName,
- rightCoercionTyConName, instCoercionTyConName, unsafeCoercionTyConName,
- csel1CoercionTyConName, csel2CoercionTyConName, cselRCoercionTyConName :: Name
-
-transCoercionTyConName = mkCoConName (fsLit "trans") transCoercionTyConKey transCoercionTyCon
-symCoercionTyConName = mkCoConName (fsLit "sym") symCoercionTyConKey symCoercionTyCon
-leftCoercionTyConName = mkCoConName (fsLit "left") leftCoercionTyConKey leftCoercionTyCon
-rightCoercionTyConName = mkCoConName (fsLit "right") rightCoercionTyConKey rightCoercionTyCon
-instCoercionTyConName = mkCoConName (fsLit "inst") instCoercionTyConKey instCoercionTyCon
-csel1CoercionTyConName = mkCoConName (fsLit "csel1") csel1CoercionTyConKey csel1CoercionTyCon
-csel2CoercionTyConName = mkCoConName (fsLit "csel2") csel2CoercionTyConKey csel2CoercionTyCon
-cselRCoercionTyConName = mkCoConName (fsLit "cselR") cselRCoercionTyConKey cselRCoercionTyCon
-unsafeCoercionTyConName = mkCoConName (fsLit "CoUnsafe") unsafeCoercionTyConKey unsafeCoercionTyCon
-
-mkCoConName :: FastString -> Unique -> TyCon -> Name
-mkCoConName occ key coCon = mkWiredInName gHC_PRIM (mkTcOccFS occ)
- key (ATyCon coCon) BuiltInSyntax
-\end{code}
-
-\begin{code}
-------------
-decompLR_maybe :: (Type,Type) -> Maybe ((Type,Type), (Type,Type))
--- Helper for left and right. Finds coercion kind of its input and
--- returns the left and right projections of the coercion...
---
--- if c :: t1 s1 ~ t2 s2 then splitCoercionKindOf c = ((t1, t2), (s1, s2))
-decompLR_maybe (ty1,ty2)
- | Just (ty_fun1, ty_arg1) <- splitAppTy_maybe ty1
- , Just (ty_fun2, ty_arg2) <- splitAppTy_maybe ty2
- = Just ((ty_fun1, ty_fun2),(ty_arg1, ty_arg2))
-decompLR_maybe _ = Nothing
-
-------------
-decompInst_maybe :: (Type, Type) -> Maybe ((TyVar,TyVar), (Type,Type))
-decompInst_maybe (ty1, ty2)
- | Just (tv1,r1) <- splitForAllTy_maybe ty1
- , Just (tv2,r2) <- splitForAllTy_maybe ty2
- = Just ((tv1,tv2), (r1,r2))
-decompInst_maybe _ = Nothing
-
-------------
-decompCsel_maybe :: (Type, Type) -> Maybe ((Type,Type), (Type,Type), (Type,Type))
--- If co :: (s1~t1 => r1) ~ (s2~t2 => r2)
--- Then csel1 co :: s1 ~ s2
--- csel2 co :: t1 ~ t2
--- cselR co :: r1 ~ r2
-decompCsel_maybe (ty1, ty2)
- | Just (s1, t1, r1) <- splitCoPredTy_maybe ty1
- , Just (s2, t2, r2) <- splitCoPredTy_maybe ty2
- = Just ((s1,s2), (t1,t2), (r1,r2))
-decompCsel_maybe _ = Nothing
-\end{code}
-
-
%************************************************************************
%* *
Newtypes
%************************************************************************
\begin{code}
-instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, CoercionI)
+instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)
-- ^ If @co :: T ts ~ rep_ty@ then:
--
-- > instNewTyCon_maybe T ts = Just (rep_ty, co)
instNewTyCon_maybe tc tys
- | Just (tvs, ty, mb_co_tc) <- unwrapNewTyCon_maybe tc
+ | Just (tvs, ty, co_tc) <- unwrapNewTyCon_maybe tc
= ASSERT( tys `lengthIs` tyConArity tc )
- Just (substTyWith tvs tys ty,
- case mb_co_tc of
- Nothing -> IdCo (mkTyConApp tc tys)
- Just co_tc -> ACo (mkTyConApp co_tc tys))
+ Just (substTyWith tvs tys ty, mkAxInstCo co_tc tys)
| otherwise
= Nothing
splitNewTypeRepCo_maybe ty
| Just ty' <- coreView ty = splitNewTypeRepCo_maybe ty'
splitNewTypeRepCo_maybe (TyConApp tc tys)
- | Just (ty', coi) <- instNewTyCon_maybe tc tys
- = case coi of
- ACo co -> Just (ty', co)
- IdCo _ -> panic "splitNewTypeRepCo_maybe"
+ | Just (ty', co) <- instNewTyCon_maybe tc tys
+ = case co of
+ Refl _ -> panic "splitNewTypeRepCo_maybe"
-- This case handled by coreView
+ _ -> Just (ty', co)
splitNewTypeRepCo_maybe _
= Nothing
-- | Determines syntactic equality of coercions
coreEqCoercion :: Coercion -> Coercion -> Bool
-coreEqCoercion = coreEqType
+coreEqCoercion co1 co2 = coreEqCoercion2 rn_env co1 co2
+ where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2))
coreEqCoercion2 :: RnEnv2 -> Coercion -> Coercion -> Bool
-coreEqCoercion2 = coreEqType2
-\end{code}
+coreEqCoercion2 env (Refl ty1) (Refl ty2) = eqTypeX env ty1 ty2
+coreEqCoercion2 env (TyConAppCo tc1 cos1) (TyConAppCo tc2 cos2)
+ = tc1 == tc2 && all2 (coreEqCoercion2 env) cos1 cos2
+
+coreEqCoercion2 env (AppCo co11 co12) (AppCo co21 co22)
+ = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22
+
+coreEqCoercion2 env (ForAllCo v1 co1) (ForAllCo v2 co2)
+ = coreEqCoercion2 (rnBndr2 env v1 v2) co1 co2
+
+coreEqCoercion2 env (CoVarCo cv1) (CoVarCo cv2)
+ = rnOccL env cv1 == rnOccR env cv2
+
+coreEqCoercion2 env (AxiomInstCo con1 cos1) (AxiomInstCo con2 cos2)
+ = con1 == con2
+ && all2 (coreEqCoercion2 env) cos1 cos2
+
+coreEqCoercion2 env (UnsafeCo ty11 ty12) (UnsafeCo ty21 ty22)
+ = eqTypeX env ty11 ty21 && eqTypeX env ty12 ty22
+
+coreEqCoercion2 env (SymCo co1) (SymCo co2)
+ = coreEqCoercion2 env co1 co2
+
+coreEqCoercion2 env (TransCo co11 co12) (TransCo co21 co22)
+ = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22
+
+coreEqCoercion2 env (NthCo d1 co1) (NthCo d2 co2)
+ = d1 == d2 && coreEqCoercion2 env co1 co2
+
+coreEqCoercion2 env (InstCo co1 ty1) (InstCo co2 ty2)
+ = coreEqCoercion2 env co1 co2 && eqTypeX env ty1 ty2
+coreEqCoercion2 _ _ _ = False
+\end{code}
%************************************************************************
%* *
- CoercionI and its constructors
-%* *
+ Substitution of coercions
+%* *
%************************************************************************
---------------------------------------
--- CoercionI smart constructors
--- lifted smart constructors of ordinary coercions
+\begin{code}
+-- | A substitution of 'Coercion's for 'CoVar's (OR 'TyVar's, when
+-- doing a \"lifting\" substitution)
+type CvSubstEnv = VarEnv Coercion
+
+emptyCvSubstEnv :: CvSubstEnv
+emptyCvSubstEnv = emptyVarEnv
+
+data CvSubst
+ = CvSubst InScopeSet -- The in-scope type variables
+ TvSubstEnv -- Substitution of types
+ CvSubstEnv -- Substitution of coercions
+
+instance Outputable CvSubst where
+ ppr (CvSubst ins tenv cenv)
+ = brackets $ sep[ ptext (sLit "CvSubst"),
+ nest 2 (ptext (sLit "In scope:") <+> ppr ins),
+ nest 2 (ptext (sLit "Type env:") <+> ppr tenv),
+ nest 2 (ptext (sLit "Coercion env:") <+> ppr cenv) ]
+
+emptyCvSubst :: CvSubst
+emptyCvSubst = CvSubst emptyInScopeSet emptyVarEnv emptyVarEnv
+
+isEmptyCvSubst :: CvSubst -> Bool
+isEmptyCvSubst (CvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv
+
+getCvInScope :: CvSubst -> InScopeSet
+getCvInScope (CvSubst in_scope _ _) = in_scope
+
+zapCvSubstEnv :: CvSubst -> CvSubst
+zapCvSubstEnv (CvSubst in_scope _ _) = CvSubst in_scope emptyVarEnv emptyVarEnv
+
+cvTvSubst :: CvSubst -> TvSubst
+cvTvSubst (CvSubst in_scope tvs _) = TvSubst in_scope tvs
+
+tvCvSubst :: TvSubst -> CvSubst
+tvCvSubst (TvSubst in_scope tenv) = CvSubst in_scope tenv emptyCvSubstEnv
+
+extendTvSubst :: CvSubst -> TyVar -> Type -> CvSubst
+extendTvSubst (CvSubst in_scope tenv cenv) tv ty
+ = CvSubst in_scope (extendVarEnv tenv tv ty) cenv
+
+substCoVarBndr :: CvSubst -> CoVar -> (CvSubst, CoVar)
+substCoVarBndr subst@(CvSubst in_scope tenv cenv) old_var
+ = ASSERT( isCoVar old_var )
+ (CvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var)
+ where
+ -- When we substitute (co :: t1 ~ t2) we may get the identity (co :: t ~ t)
+ -- In that case, mkCoVarCo will return a ReflCoercion, and
+ -- we want to substitute that (not new_var) for old_var
+ new_co = mkCoVarCo new_var
+ no_change = new_var == old_var && not (isReflCo new_co)
+
+ new_cenv | no_change = delVarEnv cenv old_var
+ | otherwise = extendVarEnv cenv old_var new_co
+
+ new_var = uniqAway in_scope subst_old_var
+ subst_old_var = mkCoVar (varName old_var) (substTy subst (varType old_var))
+ -- It's important to do the substitution for coercions,
+ -- because only they can have free type variables
+
+substTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar)
+substTyVarBndr (CvSubst in_scope tenv cenv) old_var
+ = case Type.substTyVarBndr (TvSubst in_scope tenv) old_var of
+ (TvSubst in_scope' tenv', new_var) -> (CvSubst in_scope' tenv' cenv, new_var)
+
+zipOpenCvSubst :: [Var] -> [Coercion] -> CvSubst
+zipOpenCvSubst vs cos
+ | debugIsOn && (length vs /= length cos)
+ = pprTrace "zipOpenCvSubst" (ppr vs $$ ppr cos) emptyCvSubst
+ | otherwise
+ = CvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv (zipVarEnv vs cos)
+
+mkTopCvSubst :: [(Var,Coercion)] -> CvSubst
+mkTopCvSubst prs = CvSubst emptyInScopeSet emptyTvSubstEnv (mkVarEnv prs)
+
+substCoWithTy :: TyVar -> Type -> Coercion -> Coercion
+substCoWithTy tv ty = substCoWithTys [tv] [ty]
+
+substCoWithTys :: [TyVar] -> [Type] -> Coercion -> Coercion
+substCoWithTys tvs tys co
+ | debugIsOn && (length tvs /= length tys)
+ = pprTrace "substCoWithTys" (ppr tvs $$ ppr tys) co
+ | otherwise
+ = ASSERT( length tvs == length tys )
+ substCo (CvSubst in_scope (zipVarEnv tvs tys) emptyVarEnv) co
+ where
+ in_scope = mkInScopeSet (tyVarsOfTypes tys)
+
+-- | Substitute within a 'Coercion'
+substCo :: CvSubst -> Coercion -> Coercion
+substCo subst co | isEmptyCvSubst subst = co
+ | otherwise = subst_co subst co
+
+-- | Substitute within several 'Coercion's
+substCos :: CvSubst -> [Coercion] -> [Coercion]
+substCos subst cos | isEmptyCvSubst subst = cos
+ | otherwise = map (substCo subst) cos
+
+substTy :: CvSubst -> Type -> Type
+substTy subst = Type.substTy (cvTvSubst subst)
+
+subst_co :: CvSubst -> Coercion -> Coercion
+subst_co subst co
+ = go co
+ where
+ go_ty :: Type -> Type
+ go_ty = Coercion.substTy subst
+
+ go :: Coercion -> Coercion
+ go (Refl ty) = Refl $! go_ty ty
+ go (TyConAppCo tc cos) = let args = map go cos
+ in args `seqList` TyConAppCo tc args
+ go (AppCo co1 co2) = mkAppCo (go co1) $! go co2
+ go (ForAllCo tv co) = case substTyVarBndr subst tv of
+ (subst', tv') ->
+ ForAllCo tv' $! subst_co subst' co
+ go (CoVarCo cv) = substCoVar subst cv
+ go (AxiomInstCo con cos) = AxiomInstCo con $! map go cos
+ go (UnsafeCo ty1 ty2) = (UnsafeCo $! go_ty ty1) $! go_ty ty2
+ go (SymCo co) = mkSymCo (go co)
+ go (TransCo co1 co2) = mkTransCo (go co1) (go co2)
+ go (NthCo d co) = mkNthCo d (go co)
+ go (InstCo co ty) = mkInstCo (go co) $! go_ty ty
+
+substCoVar :: CvSubst -> CoVar -> Coercion
+substCoVar (CvSubst in_scope _ cenv) cv
+ | Just co <- lookupVarEnv cenv cv = co
+ | Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1
+ | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv )
+ ASSERT( isCoVar cv ) CoVarCo cv
+
+substCoVars :: CvSubst -> [CoVar] -> [Coercion]
+substCoVars subst cvs = map (substCoVar subst) cvs
+
+lookupTyVar :: CvSubst -> TyVar -> Maybe Type
+lookupTyVar (CvSubst _ tenv _) tv = lookupVarEnv tenv tv
+
+lookupCoVar :: CvSubst -> Var -> Maybe Coercion
+lookupCoVar (CvSubst _ _ cenv) v = lookupVarEnv cenv v
+\end{code}
+
+%************************************************************************
+%* *
+ "Lifting" substitution
+ [(TyVar,Coercion)] -> Type -> Coercion
+%* *
+%************************************************************************
\begin{code}
--- | 'CoercionI' represents a /lifted/ ordinary 'Coercion', in that it
--- can represent either one of:
---
--- 1. A proper 'Coercion'
+liftCoSubstWith :: [TyVar] -> [Coercion] -> Type -> Coercion
+liftCoSubstWith tvs cos = liftCoSubst (zipOpenCvSubst tvs cos)
+
+-- | The \"lifting\" operation which substitutes coercions for type
+-- variables in a type to produce a coercion.
--
--- 2. The identity coercion
-data CoercionI = IdCo Type | ACo Coercion
+-- For the inverse operation, see 'liftCoMatch'
+liftCoSubst :: CvSubst -> Type -> Coercion
+-- The CvSubst maps TyVar -> Type (mainly for cloning foralls)
+-- TyVar -> Coercion (this is the payload)
+-- The unusual thing is that the *coercion* substitution maps
+-- some *type* variables. That's the whole point of this function!
+liftCoSubst subst ty | isEmptyCvSubst subst = Refl ty
+ | otherwise = ty_co_subst subst ty
+
+ty_co_subst :: CvSubst -> Type -> Coercion
+ty_co_subst subst ty
+ = go ty
+ where
+ go (TyVarTy tv) = liftCoSubstTyVar subst tv `orElse` Refl (TyVarTy tv)
+ go (AppTy ty1 ty2) = mkAppCo (go ty1) (go ty2)
+ go (TyConApp tc tys) = mkTyConAppCo tc (map go tys)
+ go (FunTy ty1 ty2) = mkFunCo (go ty1) (go ty2)
+ go (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' ty)
+ where
+ (subst', v') = liftCoSubstTyVarBndr subst v
+ go (PredTy p) = mkPredCo (go <$> p)
+
+liftCoSubstTyVar :: CvSubst -> TyVar -> Maybe Coercion
+liftCoSubstTyVar subst@(CvSubst _ tenv cenv) tv
+ = case (lookupVarEnv tenv tv, lookupVarEnv cenv tv) of
+ (Nothing, Nothing) -> Nothing
+ (Just ty, Nothing) -> Just (Refl ty)
+ (Nothing, Just co) -> Just co
+ (Just {}, Just {}) -> pprPanic "ty_co_subst" (ppr tv $$ ppr subst)
+
+liftCoSubstTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar)
+liftCoSubstTyVarBndr (CvSubst in_scope tenv cenv) old_var
+ = (CvSubst (in_scope `extendInScopeSet` new_var)
+ new_tenv
+ (delVarEnv cenv old_var) -- See Note [Lifting substitutions]
+ , new_var)
+ where
+ new_tenv | no_change = delVarEnv tenv old_var
+ | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)
+
+ no_change = new_var == old_var
+ new_var = uniqAway in_scope old_var
+\end{code}
-liftCoI :: (Type -> Type) -> CoercionI -> CoercionI
-liftCoI f (IdCo ty) = IdCo (f ty)
-liftCoI f (ACo ty) = ACo (f ty)
+Note [Lifting substitutions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider liftCoSubstWith [a] [co] (a, forall a. a)
+Then we want to substitute for the free 'a', but obviously not for
+the bound 'a'. hence the (delVarEnv cent old_var) in liftCoSubstTyVarBndr.
-liftCoI2 :: (Type -> Type -> Type) -> CoercionI -> CoercionI -> CoercionI
-liftCoI2 f (IdCo ty1) (IdCo ty2) = IdCo (f ty1 ty2)
-liftCoI2 f coi1 coi2 = ACo (f (fromCoI coi1) (fromCoI coi2))
+This also why we need a full CvSubst when doing lifting substitutions.
-liftCoIs :: ([Type] -> Type) -> [CoercionI] -> CoercionI
-liftCoIs f cois = go_id [] cois
+\begin{code}
+-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if
+-- @liftCoMatch vars ty co == Just s@, then @tyCoSubst s ty == co@.
+-- That is, it matches a type against a coercion of the same
+-- "shape", and returns a lifting substitution which could have been
+-- used to produce the given coercion from the given type.
+liftCoMatch :: TyVarSet -> Type -> Coercion -> Maybe CvSubst
+liftCoMatch tmpls ty co
+ = case ty_co_match menv (emptyVarEnv, emptyVarEnv) ty co of
+ Just (tv_env, cv_env) -> Just (CvSubst in_scope tv_env cv_env)
+ Nothing -> Nothing
where
- go_id rev_tys [] = IdCo (f (reverse rev_tys))
- go_id rev_tys (IdCo ty : cois) = go_id (ty:rev_tys) cois
- go_id rev_tys (ACo co : cois) = go_aco (co:rev_tys) cois
-
- go_aco rev_tys [] = ACo (f (reverse rev_tys))
- go_aco rev_tys (IdCo ty : cois) = go_aco (ty:rev_tys) cois
- go_aco rev_tys (ACo co : cois) = go_aco (co:rev_tys) cois
-
-instance Outputable CoercionI where
- ppr (IdCo _) = ptext (sLit "IdCo")
- ppr (ACo co) = ppr co
-
-isIdentityCoI :: CoercionI -> Bool
-isIdentityCoI (IdCo _) = True
-isIdentityCoI (ACo _) = False
-
--- | Return either the 'Coercion' contained within the 'CoercionI' or the given
--- 'Type' if the 'CoercionI' is the identity 'Coercion'
-fromCoI :: CoercionI -> Type
-fromCoI (IdCo ty) = ty -- Identity coercion represented
-fromCoI (ACo co) = co -- by the type itself
-
--- | Smart constructor for @sym@ on 'CoercionI', see also 'mkSymCoercion'
-mkSymCoI :: CoercionI -> CoercionI
-mkSymCoI (IdCo ty) = IdCo ty
-mkSymCoI (ACo co) = ACo $ mkCoercion symCoercionTyCon [co]
- -- the smart constructor
- -- is too smart with tyvars
-
--- | Smart constructor for @trans@ on 'CoercionI', see also 'mkTransCoercion'
-mkTransCoI :: CoercionI -> CoercionI -> CoercionI
-mkTransCoI (IdCo _) aco = aco
-mkTransCoI aco (IdCo _) = aco
-mkTransCoI (ACo co1) (ACo co2) = ACo $ mkTransCoercion co1 co2
-
--- | Smart constructor for type constructor application on 'CoercionI', see also 'mkAppCoercion'
-mkTyConAppCoI :: TyCon -> [CoercionI] -> CoercionI
-mkTyConAppCoI tyCon cois = liftCoIs (mkTyConApp tyCon) cois
-
--- | Smart constructor for honest-to-god 'Coercion' application on 'CoercionI', see also 'mkAppCoercion'
-mkAppTyCoI :: CoercionI -> CoercionI -> CoercionI
-mkAppTyCoI = liftCoI2 mkAppTy
-
-mkFunTyCoI :: CoercionI -> CoercionI -> CoercionI
-mkFunTyCoI = liftCoI2 mkFunTy
-
--- | Smart constructor for quantified 'Coercion's on 'CoercionI', see also 'mkForAllCoercion'
-mkForAllTyCoI :: TyVar -> CoercionI -> CoercionI
-mkForAllTyCoI tv = liftCoI (ForAllTy tv)
-
--- | Smart constructor for class 'Coercion's on 'CoercionI'. Satisfies:
---
--- > mkClassPPredCoI cls tys cois :: PredTy (cls tys) ~ PredTy (cls (tys `cast` cois))
-mkClassPPredCoI :: Class -> [CoercionI] -> CoercionI
-mkClassPPredCoI cls = liftCoIs (PredTy . ClassP cls)
+ menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope }
+ in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co)
+ -- Like tcMatchTy, assume all the interesting variables
+ -- in ty are in tmpls
+
+type TyCoSubstEnv = (TvSubstEnv, CvSubstEnv)
+ -- Used locally inside ty_co_match only
+
+-- | 'ty_co_match' does all the actual work for 'liftCoMatch'.
+ty_co_match :: MatchEnv -> TyCoSubstEnv -> Type -> Coercion -> Maybe TyCoSubstEnv
+ty_co_match menv subst ty co | Just ty' <- coreView ty = ty_co_match menv subst ty' co
+
+ -- Deal with the Refl case by delegating to type matching
+ty_co_match menv (tenv, cenv) ty co
+ | Just ty' <- isReflCo_maybe co
+ = case ruleMatchTyX ty_menv tenv ty ty' of
+ Just tenv' -> Just (tenv', cenv)
+ Nothing -> Nothing
+ where
+ ty_menv = menv { me_tmpls = me_tmpls menv `minusUFM` cenv }
+ -- Remove from the template set any variables already bound to non-refl coercions
+
+ -- Match a type variable against a non-refl coercion
+ty_co_match menv subst@(tenv, cenv) (TyVarTy tv1) co
+ | Just {} <- lookupVarEnv tenv tv1' -- tv1' is already bound to (Refl ty)
+ = Nothing -- The coercion 'co' is not Refl
+
+ | Just co1' <- lookupVarEnv cenv tv1' -- tv1' is already bound to co1
+ = if coreEqCoercion2 (nukeRnEnvL rn_env) co1' co
+ then Just subst
+ else Nothing -- no match since tv1 matches two different coercions
+
+ | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var
+ = if any (inRnEnvR rn_env) (varSetElems (tyCoVarsOfCo co))
+ then Nothing -- occurs check failed
+ else return (tenv, extendVarEnv cenv tv1' co)
+ -- BAY: I don't think we need to do any kind matching here yet
+ -- (compare 'match'), but we probably will when moving to SHE.
+
+ | otherwise -- tv1 is not a template ty var, so the only thing it
+ -- can match is a reflexivity coercion for itself.
+ -- But that case is dealt with already
+ = Nothing
--- | Smart constructor for implicit parameter 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI'
-mkIParamPredCoI :: (IPName Name) -> CoercionI -> CoercionI
-mkIParamPredCoI ipn = liftCoI (PredTy . IParam ipn)
+ where
+ rn_env = me_env menv
+ tv1' = rnOccL rn_env tv1
--- | Smart constructor for type equality 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI'
-mkEqPredCoI :: CoercionI -> CoercionI -> CoercionI
-mkEqPredCoI = liftCoI2 (\t1 t2 -> PredTy (EqPred t1 t2))
+ty_co_match menv subst (AppTy ty1 ty2) co
+ | Just (co1, co2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy
+ = do { subst' <- ty_co_match menv subst ty1 co1
+ ; ty_co_match menv subst' ty2 co2 }
-mkCoPredCoI :: CoercionI -> CoercionI -> CoercionI -> CoercionI
-mkCoPredCoI coi1 coi2 coi3 = mkFunTyCoI (mkEqPredCoI coi1 coi2) coi3
+ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo tc2 cos)
+ | tc1 == tc2 = ty_co_matches menv subst tys cos
+ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo tc cos)
+ | tc == funTyCon = ty_co_matches menv subst [ty1,ty2] cos
+ty_co_match menv subst (ForAllTy tv1 ty) (ForAllCo tv2 co)
+ = ty_co_match menv' subst ty co
+ where
+ menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 }
+
+ty_co_match _ _ _ _ = Nothing
+
+ty_co_matches :: MatchEnv -> TyCoSubstEnv -> [Type] -> [Coercion] -> Maybe TyCoSubstEnv
+ty_co_matches menv = matchList (ty_co_match menv)
\end{code}
%************************************************************************
%* *
- The kind of a type, and of a coercion
+ Sequencing on coercions
%* *
%************************************************************************
\begin{code}
-typeKind :: Type -> Kind
-typeKind ty@(TyConApp tc tys)
- | isCoercionTyCon tc = typeKind (fst (coercionKind ty))
- | otherwise = kindAppResult (tyConKind tc) tys
- -- During coercion optimisation we *do* match a type
- -- against a coercion (see OptCoercion.matchesAxiomLhs)
- -- So the use of typeKind in Unify.match_kind must work on coercions too
- -- Hence the isCoercionTyCon case above
-
-typeKind (PredTy pred) = predKind pred
-typeKind (AppTy fun _) = kindFunResult (typeKind fun)
-typeKind (ForAllTy _ ty) = typeKind ty
-typeKind (TyVarTy tyvar) = tyVarKind tyvar
-typeKind (FunTy _arg res)
- -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*),
- -- not unliftedTypKind (#)
- -- The only things that can be after a function arrow are
- -- (a) types (of kind openTypeKind or its sub-kinds)
- -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *))
- | isTySuperKind k = k
- | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind
- where
- k = typeKind res
+seqCo :: Coercion -> ()
+seqCo (Refl ty) = seqType ty
+seqCo (TyConAppCo tc cos) = tc `seq` seqCos cos
+seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2
+seqCo (ForAllCo tv co) = tv `seq` seqCo co
+seqCo (CoVarCo cv) = cv `seq` ()
+seqCo (AxiomInstCo con cos) = con `seq` seqCos cos
+seqCo (UnsafeCo ty1 ty2) = seqType ty1 `seq` seqType ty2
+seqCo (SymCo co) = seqCo co
+seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2
+seqCo (NthCo _ co) = seqCo co
+seqCo (InstCo co ty) = seqCo co `seq` seqType ty
+
+seqCos :: [Coercion] -> ()
+seqCos [] = ()
+seqCos (co:cos) = seqCo co `seq` seqCos cos
+\end{code}
-------------------
-predKind :: PredType -> Kind
-predKind (EqPred {}) = coSuperKind -- A coercion kind!
-predKind (ClassP {}) = liftedTypeKind -- Class and implicitPredicates are
-predKind (IParam {}) = liftedTypeKind -- always represented by lifted types
+
+%************************************************************************
+%* *
+ The kind of a type, and of a coercion
+%* *
+%************************************************************************
+
+\begin{code}
+coercionType :: Coercion -> Type
+coercionType co = case coercionKind co of
+ Pair ty1 ty2 -> mkCoType ty1 ty2
------------------
-- | If it is the case that
--
-- > c :: (t1 ~ t2)
--
--- i.e. the kind of @c@ is a 'CoercionKind' relating @t1@ and @t2@,
--- then @coercionKind c = (t1, t2)@.
-coercionKind :: Coercion -> (Type, Type)
-coercionKind ty@(TyVarTy a) | isCoVar a = coVarKind a
- | otherwise = (ty, ty)
-coercionKind (AppTy ty1 ty2)
- = let (s1, t1) = coercionKind ty1
- (s2, t2) = coercionKind ty2 in
- (mkAppTy s1 s2, mkAppTy t1 t2)
-coercionKind co@(TyConApp tc args)
- | Just (ar, desc) <- isCoercionTyCon_maybe tc
- -- CoercionTyCons carry their kinding rule, so we use it here
- = WARN( not (length args >= ar), ppr co ) -- Always saturated
- (let (ty1, ty2) = coTyConAppKind desc (take ar args)
- (tys1, tys2) = coercionKinds (drop ar args)
- in (mkAppTys ty1 tys1, mkAppTys ty2 tys2))
-
- | otherwise
- = let (lArgs, rArgs) = coercionKinds args in
- (TyConApp tc lArgs, TyConApp tc rArgs)
-
-coercionKind (FunTy ty1 ty2)
- = let (t1, t2) = coercionKind ty1
- (s1, s2) = coercionKind ty2 in
- (mkFunTy t1 s1, mkFunTy t2 s2)
-
-coercionKind (ForAllTy tv ty)
- | isCoVar tv
--- c1 :: s1~s2 c2 :: t1~t2 c3 :: r1~r2
--- ----------------------------------------------
--- c1~c2 => c3 :: (s1~t1) => r1 ~ (s2~t2) => r2
--- or
--- forall (_:c1~c2)
- = let (c1,c2) = coVarKind tv
- (s1,s2) = coercionKind c1
- (t1,t2) = coercionKind c2
- (r1,r2) = coercionKind ty
- in
- (mkCoPredTy s1 t1 r1, mkCoPredTy s2 t2 r2)
-
- | otherwise
--- c1 :: s1~s2 c2 :: t1~t2 c3 :: r1~r2
--- ----------------------------------------------
--- forall a:k. c :: forall a:k. t1 ~ forall a:k. t2
- = let (ty1, ty2) = coercionKind ty in
- (ForAllTy tv ty1, ForAllTy tv ty2)
-
-coercionKind (PredTy (ClassP cl args))
- = let (lArgs, rArgs) = coercionKinds args in
- (PredTy (ClassP cl lArgs), PredTy (ClassP cl rArgs))
-coercionKind (PredTy (IParam name ty))
- = let (ty1, ty2) = coercionKind ty in
- (PredTy (IParam name ty1), PredTy (IParam name ty2))
-coercionKind (PredTy (EqPred c1 c2))
- = pprTrace "coercionKind" (pprEqPred (c1,c2)) $
- -- These should not show up in coercions at all
- -- becuase they are in the form of for-alls
- let k1 = coercionKindPredTy c1
- k2 = coercionKindPredTy c2 in
- (k1,k2)
- where
- coercionKindPredTy c = let (t1, t2) = coercionKind c in mkCoKind t1 t2
+-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.
+coercionKind :: Coercion -> Pair Type
+coercionKind (Refl ty) = Pair ty ty
+coercionKind (TyConAppCo tc cos) = mkTyConApp tc <$> (sequenceA $ map coercionKind cos)
+coercionKind (AppCo co1 co2) = mkAppTy <$> coercionKind co1 <*> coercionKind co2
+coercionKind (ForAllCo tv co) = mkForAllTy tv <$> coercionKind co
+coercionKind (CoVarCo cv) = ASSERT( isCoVar cv ) toPair $ coVarKind cv
+coercionKind (AxiomInstCo ax cos) = let Pair tys1 tys2 = coercionKinds cos
+ in Pair (substTyWith (co_ax_tvs ax) tys1 (co_ax_lhs ax))
+ (substTyWith (co_ax_tvs ax) tys2 (co_ax_rhs ax))
+coercionKind (UnsafeCo ty1 ty2) = Pair ty1 ty2
+coercionKind (SymCo co) = swap $ coercionKind co
+coercionKind (TransCo co1 co2) = Pair (pFst $ coercionKind co1) (pSnd $ coercionKind co2)
+coercionKind (NthCo d co) = getNth d <$> coercionKind co
+coercionKind co@(InstCo aco ty) | Just ks <- splitForAllTy_maybe `traverse` coercionKind aco
+ = (\(tv, body) -> substTyWith [tv] [ty] body) <$> ks
+ | otherwise = pprPanic "coercionKind" (ppr co)
-------------------
-- | Apply 'coercionKind' to multiple 'Coercion's
-coercionKinds :: [Coercion] -> ([Type], [Type])
-coercionKinds tys = unzip $ map coercionKind tys
+coercionKinds :: [Coercion] -> Pair [Type]
+coercionKinds tys = sequenceA $ map coercionKind tys
-------------------
--- | 'coTyConAppKind' is given a list of the type arguments to the 'CoTyCon',
--- and constructs the types that the resulting coercion relates.
--- Fails (in the monad) if ill-kinded.
--- Typically the monad is
--- either the Lint monad (with the consistency-check flag = True),
--- or the ID monad with a panic on failure (and the consistency-check flag = False)
-coTyConAppKind
- :: CoTyConDesc
- -> [Type] -- Exactly right number of args
- -> (Type, Type) -- Kind of this application
-coTyConAppKind CoUnsafe (ty1:ty2:_)
- = (ty1,ty2)
-coTyConAppKind CoSym (co:_)
- | (ty1,ty2) <- coercionKind co = (ty2,ty1)
-coTyConAppKind CoTrans (co1:co2:_)
- = (fst (coercionKind co1), snd (coercionKind co2))
-coTyConAppKind CoLeft (co:_)
- | Just (res,_) <- decompLR_maybe (coercionKind co) = res
-coTyConAppKind CoRight (co:_)
- | Just (_,res) <- decompLR_maybe (coercionKind co) = res
-coTyConAppKind CoCsel1 (co:_)
- | Just (res,_,_) <- decompCsel_maybe (coercionKind co) = res
-coTyConAppKind CoCsel2 (co:_)
- | Just (_,res,_) <- decompCsel_maybe (coercionKind co) = res
-coTyConAppKind CoCselR (co:_)
- | Just (_,_,res) <- decompCsel_maybe (coercionKind co) = res
-coTyConAppKind CoInst (co:ty:_)
- | Just ((tv1,tv2), (ty1,ty2)) <- decompInst_maybe (coercionKind co)
- = (substTyWith [tv1] [ty] ty1, substTyWith [tv2] [ty] ty2)
-coTyConAppKind (CoAxiom { co_ax_tvs = tvs
- , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos
- = (substTyWith tvs tys1 lhs_ty, substTyWith tvs tys2 rhs_ty)
- where
- (tys1, tys2) = coercionKinds cos
-coTyConAppKind desc cos = pprTrace "coTyConAppKind" (ppr desc $$ braces (vcat
- [ ppr co <+> dcolon <+> pprEqPred (coercionKind co)
- | co <- cos ])) $
- coercionKind (head cos)
+getNth :: Int -> Type -> Type
+getNth n ty | Just (_, tys) <- splitTyConApp_maybe ty
+ = ASSERT2( n < length tys, ppr n <+> ppr tys ) tys !! n
+getNth n ty = pprPanic "getNth" (ppr n <+> ppr ty)
\end{code}
+
+\begin{code}
+applyCo :: Type -> Coercion -> Type
+-- Gives the type of (e co) where e :: (a~b) => ty
+applyCo ty co | Just ty' <- coreView ty = applyCo ty' co
+applyCo (FunTy _ ty) _ = ty
+applyCo _ _ = panic "applyCo"
+\end{code}
\ No newline at end of file
import TyCon
import Coercion
import VarSet
-import Var
import Name
import UniqFM
import Outputable
pprFamInst :: FamInst -> SDoc
pprFamInst famInst
= hang (pprFamInstHdr famInst)
- 2 (ptext (sLit "--") <+> pprNameLoc (getName famInst))
+ 2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> pp_ax)
+ , ptext (sLit "--") <+> pprNameLoc (getName famInst)])
+ where
+ pp_ax = case tyConFamilyCoercion_maybe (fi_tycon famInst) of
+ Just ax -> ppr ax
+ Nothing -> ptext (sLit "<not there!>")
pprFamInstHdr :: FamInst -> SDoc
pprFamInstHdr (FamInst {fi_tycon = rep_tc})
-- anything else would be difficult to test for at this stage.
conflicting old_fam_inst subst
| isAlgTyCon fam = True
- | otherwise = not (old_rhs `tcEqType` new_rhs)
+ | otherwise = not (old_rhs `eqType` new_rhs)
where
old_tycon = famInstTyCon old_fam_inst
old_tvs = tyConTyVars old_tycon
go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms
= go rec_nts ty'
- go rec_nts (TyConApp tc tys) -- Expand newtypes
- | Just co_con <- newTyConCo_maybe tc -- See Note [Expanding newtypes]
- = if tc `elem` rec_nts -- in Type.lhs
+ go rec_nts (TyConApp tc tys)
+ | isNewTyCon tc -- Expand newtypes
+ = if tc `elem` rec_nts -- See Note [Expanding newtypes] in Type.lhs
then Nothing
- else let nt_co = mkTyConApp co_con tys
- in add_co nt_co rec_nts' nt_rhs
- where
- nt_rhs = newTyConInstRhs tc tys
- rec_nts' | isRecursiveTyCon tc = tc:rec_nts
- | otherwise = rec_nts
-
- go rec_nts (TyConApp tc tys) -- Expand open tycons
- | isFamilyTyCon tc
- , (ACo co, ty) <- normaliseTcApp env tc tys
- = -- The ACo says "something happened"
- -- Note that normaliseType fully normalises, but it has do to so
- -- to be sure that
- add_co co rec_nts ty
+ else let nt_co = mkAxInstCo (newTyConCo tc) tys
+ in add_co nt_co rec_nts' nt_rhs
+
+ | isFamilyTyCon tc -- Expand open tycons
+ , (co, ty) <- normaliseTcApp env tc tys
+ -- Note that normaliseType fully normalises,
+ -- but it has do to so to be sure that
+ , not (isReflCo co)
+ = add_co co rec_nts ty
+ where
+ nt_rhs = newTyConInstRhs tc tys
+ rec_nts' | isRecursiveTyCon tc = tc:rec_nts
+ | otherwise = rec_nts
go _ _ = Nothing
add_co co rec_nts ty
= case go rec_nts ty of
Nothing -> Just (co, ty)
- Just (co', ty') -> Just (mkTransCoercion co co', ty')
+ Just (co', ty') -> Just (mkTransCo co co', ty')
---------------
-normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (CoercionI, Type)
+normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (Coercion, Type)
normaliseTcApp env tc tys
| isFamilyTyCon tc
, tyConArity tc <= length tys -- Unsaturated data families are possible
= let -- A matching family instance exists
rep_tc = famInstTyCon fam_inst
co_tycon = expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc)
- co = mkTyConApp co_tycon inst_tys
- first_coi = mkTransCoI tycon_coi (ACo co)
- (rest_coi, nty) = normaliseType env (mkTyConApp rep_tc inst_tys)
- fix_coi = mkTransCoI first_coi rest_coi
+ co = mkAxInstCo co_tycon inst_tys
+ first_coi = mkTransCo tycon_coi co
+ (rest_coi,nty) = normaliseType env (mkTyConApp rep_tc inst_tys)
+ fix_coi = mkTransCo first_coi rest_coi
in
(fix_coi, nty)
- | otherwise
+ | otherwise -- No unique matching family instance exists;
+ -- we do not do anything
= (tycon_coi, TyConApp tc ntys)
where
-- Normalise the arg types so that they'll match
-- when we lookup in in the instance envt
(cois, ntys) = mapAndUnzip (normaliseType env) tys
- tycon_coi = mkTyConAppCoI tc cois
+ tycon_coi = mkTyConAppCo tc cois
---------------
normaliseType :: FamInstEnvs -- environment with family instances
-> Type -- old type
- -> (CoercionI, Type) -- (coercion,new type), where
+ -> (Coercion, Type) -- (coercion,new type), where
-- co :: old-type ~ new_type
-- Normalise the input type, by eliminating *all* type-function redexes
--- Returns with IdCo if nothing happens
+-- Returns with Refl if nothing happens
normaliseType env ty
| Just ty' <- coreView ty = normaliseType env ty'
normaliseType env (AppTy ty1 ty2)
= let (coi1,nty1) = normaliseType env ty1
(coi2,nty2) = normaliseType env ty2
- in (mkAppTyCoI coi1 coi2, mkAppTy nty1 nty2)
+ in (mkAppCo coi1 coi2, mkAppTy nty1 nty2)
normaliseType env (FunTy ty1 ty2)
= let (coi1,nty1) = normaliseType env ty1
(coi2,nty2) = normaliseType env ty2
- in (mkFunTyCoI coi1 coi2, mkFunTy nty1 nty2)
+ in (mkFunCo coi1 coi2, mkFunTy nty1 nty2)
normaliseType env (ForAllTy tyvar ty1)
= let (coi,nty1) = normaliseType env ty1
- in (mkForAllTyCoI tyvar coi, ForAllTy tyvar nty1)
+ in (mkForAllCo tyvar coi, ForAllTy tyvar nty1)
normaliseType _ ty@(TyVarTy _)
- = (IdCo ty,ty)
+ = (Refl ty,ty)
normaliseType env (PredTy predty)
= normalisePred env predty
---------------
-normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type)
+normalisePred :: FamInstEnvs -> PredType -> (Coercion,Type)
normalisePred env (ClassP cls tys)
- = let (cois,tys') = mapAndUnzip (normaliseType env) tys
- in (mkClassPPredCoI cls cois, PredTy $ ClassP cls tys')
+ = let (cos,tys') = mapAndUnzip (normaliseType env) tys
+ in (mkPredCo $ ClassP cls cos, PredTy $ ClassP cls tys')
normalisePred env (IParam ipn ty)
- = let (coi,ty') = normaliseType env ty
- in (mkIParamPredCoI ipn coi, PredTy $ IParam ipn ty')
+ = let (co,ty') = normaliseType env ty
+ in (mkPredCo $ (IParam ipn co), PredTy $ IParam ipn ty')
normalisePred env (EqPred ty1 ty2)
- = let (coi1,ty1') = normaliseType env ty1
- (coi2,ty2') = normaliseType env ty2
- in (mkEqPredCoI coi1 coi2, PredTy $ EqPred ty1' ty2')
+ = let (co1,ty1') = normaliseType env ty1
+ (co2,ty2') = normaliseType env ty2
+ in (mkPredCo $ (EqPred co1 co2), PredTy $ EqPred ty1' ty2')
\end{code}
, fd <- cls_fds
, let (ltys1, rs1) = instFD fd cls_tvs tys1
(ltys2, irs2) = instFD_WithPos fd cls_tvs tys2
- , tcEqTypes ltys1 ltys2 -- The LHSs match
- , let eqs = zipAndComputeFDEqs tcEqType rs1 irs2
+ , eqTypes ltys1 ltys2 -- The LHSs match
+ , let eqs = zipAndComputeFDEqs eqType rs1 irs2
, not (null eqs) ]
improveFromAnother _ _ = []
fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' irs2'
-- Don't discard anything!
-- We could discard equal types but it's an overkill to call
- -- tcEqType again, since we know for sure that /at least one/
+ -- eqType again, since we know for sure that /at least one/
-- equation in there is useful)
qtvs' = filterVarSet (`notElemTvSubst` subst) qtvs
%
-% (c) The University of Glasgow 2006
+% (c) The University of Glasgow 2011
%
\begin{code}
-{-# OPTIONS -fno-warn-incomplete-patterns #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
-module Generics ( canDoGenerics, mkTyConGenericBinds,
- mkGenericRhs,
- validGenericInstanceType, validGenericMethodType
+
+module Generics ( canDoGenerics,
+ mkBindsRep, tc_mkRepTyCon, mkBindsMetaD,
+ MetaTyCons(..), metaTyCons2TyCons
) where
import DataCon
import TyCon
-import Name
+import Name hiding (varName)
+import Module (moduleName, moduleNameString)
import RdrName
import BasicTypes
-import Var
-import VarSet
-import Id
import TysWiredIn
import PrelNames
-
+
+-- For generation of representation types
+import TcEnv (tcLookupTyCon)
+import TcRnMonad
+import HscTypes
+import BuildTyCl
+
import SrcLoc
-import Util
import Bag
import Outputable
import FastString
#include "HsVersions.h"
\end{code}
-Roadmap of what's where in the Generics work.
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Parser
-No real checks.
-
-RnSource.rnHsType
- Checks that HsNumTy has a "1" in it.
-
-TcInstDcls.mkGenericInstance:
- Checks for invalid type patterns, such as f {| Int |}
-
-TcClassDcl.tcClassSig
- Checks for a method type that is too complicated;
- e.g. has for-alls or lists in it
- We could lift this restriction
-
-TcClassDecl.mkDefMethRhs
- Checks that the instance type is simple, in an instance decl
- where we let the compiler fill in a generic method.
- e.g. instance C (T Int)
- is not valid if C has generic methods.
-
-TcClassDecl.checkGenericClassIsUnary
- Checks that we don't have generic methods in a multi-parameter class
-
-TcClassDecl.checkDefaultBinds
- Checks that all the equations for a method in a class decl
- are generic, or all are non-generic
-
-
-
-Checking that the type constructors which are present in Generic
-patterns (not Unit, this is done differently) is done in mk_inst_info
-(TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that
-HsOpTy is tied to Generic definitions which is not a very good design
-feature, indeed a bug. However, the check is easy to move from
-tcHsType back to mk_inst_info and everything will be fine. Also see
-bug #5. [I don't think that this is the case anymore after SPJ's latest
-changes in that regard. Delete this comment? -=chak/7Jun2]
-
-Generics.lhs
-
-Making generic information to put into a tycon. Constructs the
-representation type, which, I think, are not used later. Perhaps it is
-worth removing them from the GI datatype. Although it does get used in
-the construction of conversion functions (internally).
-
-TyCon.lhs
-
-Just stores generic information, accessible by tyConGenInfo or tyConGenIds.
-
-TysWiredIn.lhs
-
-Defines generic and other type and data constructors.
-
-This is sadly incomplete, but will be added to.
-
-
-Bugs & shortcomings of existing implementation:
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-2. Another pretty big bug I dscovered at the last minute when I was
-testing the code is that at the moment the type variable of the class
-is scoped over the entire declaration, including the patterns. For
-instance, if I have the following code,
-
-class Er a where
- ...
- er {| Plus a b |} (Inl x) (Inl y) = er x y
- er {| Plus a b |} (Inr x) (Inr y) = er x y
- er {| Plus a b |} _ _ = False
-
-and I print out the types of the generic patterns, I get the
-following. Note that all the variable names for "a" are the same,
-while for "b" they are all different.
-
-check_ty
- [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-},
- std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-},
- std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}]
-
-This is a bug as if I change the code to
-
- er {| Plus c b |} (Inl x) (Inl y) = er x y
-
-all the names come out to be different.
-
-Thus, all the types (Plus a b) come out to be different, so I cannot
-compare them and test whether they are all the same and thus cannot
-return an error if the type variables are different.
-
-Temporary fix/hack. I am not checking for this, I just assume they are
-the same, see line "check_ty = True" in TcInstDecls. When we resolve
-the issue with variables, though - I assume that we will make them to
-be the same in all the type patterns, jus uncomment the check and
-everything should work smoothly.
-
-Hence, I have also left the rather silly construction of:
-* extracting all the type variables from all the types
-* putting them *all* into the environment
-* typechecking all the types
-* selecting one of them and using it as the instance_ty.
-
-(the alternative is to make sure that all the types are the same,
-taking one, extracting its variables, putting them into the environment,
-type checking it, using it as the instance_ty)
-
-6. What happens if we do not supply all of the generic patterns? At
-the moment, the compiler crashes with an error message "Non-exhaustive
-patterns in a generic declaration"
-
-
-What has not been addressed:
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Contexts. In the generated instance declarations for the 3 primitive
-type constructors, we need contexts. It is unclear what those should
-be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b)
-
-Type application. We have type application in expressions
-(essentially) on the lhs of an equation. Do we want to allow it on the
-RHS?
-
-Scoping of type variables in a generic definition. At the moment, (see
-TcInstDecls) we extract the type variables inside the type patterns
-and add them to the environment. See my bug #2 above. This seems pretty
-important.
-
-
-
-%************************************************************************
-%* *
-\subsection{Getting the representation type out}
-%* *
-%************************************************************************
-
-\begin{code}
-validGenericInstanceType :: Type -> Bool
- -- Checks for validity of the type pattern in a generic
- -- declaration. It's ok to have
- -- f {| a + b |} ...
- -- but it's not OK to have
- -- f {| a + Int |}
-
-validGenericInstanceType inst_ty
- = case tcSplitTyConApp_maybe inst_ty of
- Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames
- Nothing -> False
-
-validGenericMethodType :: Type -> Bool
- -- At the moment we only allow method types built from
- -- * type variables
- -- * function arrow
- -- * boxed tuples
- -- * lists
- -- * an arbitrary type not involving the class type variables
- -- e.g. this is ok: forall b. Ord b => [b] -> a
- -- where a is the class variable
-validGenericMethodType ty
- = valid tau
- where
- (local_tvs, _, tau) = tcSplitSigmaTy ty
-
- valid ty
- | not (isTauTy ty) = False -- Note [Higher ramk methods]
- | isTyVarTy ty = True
- | no_tyvars_in_ty = True
- | otherwise = case tcSplitTyConApp_maybe ty of
- Just (tc,tys) -> valid_tycon tc && all valid tys
- Nothing -> False
- where
- no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
-
- valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc
- -- Compare bimapApp, below
-\end{code}
-
-
%************************************************************************
%* *
\subsection{Generating representation types}
%************************************************************************
\begin{code}
-canDoGenerics :: [DataCon] -> Bool
+canDoGenerics :: TyCon -> Maybe SDoc
-- Called on source-code data types, to see if we should generate
--- generic functions for them. (This info is recorded in the interface file for
--- imported data types.)
-
-canDoGenerics data_cons
- = not (any bad_con data_cons) -- See comment below
- && not (null data_cons) -- No values of the type
+-- generic functions for them.
+-- Nothing == yes
+-- Just s == no, because of `s`
+
+canDoGenerics tycon
+ = mergeErrors (
+ -- We do not support datatypes with context
+ (if (not (null (tyConStupidTheta tycon)))
+ then (Just (ppr tycon <+> text "must not have a datatype context"))
+ else Nothing)
+ -- We don't like type families
+ : (if (isFamilyTyCon tycon)
+ then (Just (ppr tycon <+> text "must not be a family instance"))
+ else Nothing)
+ -- See comment below
+ : (map bad_con (tyConDataCons tycon)))
where
- bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc)
- -- If any of the constructor has an unboxed type as argument,
- -- then we can't build the embedding-projection pair, because
- -- it relies on instantiating *polymorphic* sum and product types
- -- at the argument types of the constructors
+ -- If any of the constructor has an unboxed type as argument,
+ -- then we can't build the embedding-projection pair, because
+ -- it relies on instantiating *polymorphic* sum and product types
+ -- at the argument types of the constructors
+ bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
+ then (Just (ppr dc <+> text "must not have unlifted or polymorphic arguments"))
+ else (if (not (isVanillaDataCon dc))
+ then (Just (ppr dc <+> text "must be a vanilla data constructor"))
+ else Nothing)
+
-- Nor can we do the job if it's an existential data constructor,
-- Nor if the args are polymorphic types (I don't think)
bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty)
+
+ mergeErrors :: [Maybe SDoc] -> Maybe SDoc
+ mergeErrors [] = Nothing
+ mergeErrors ((Just s):t) = case mergeErrors t of
+ Nothing -> Just s
+ Just s' -> Just (s <> text ", and" $$ s')
+ mergeErrors (Nothing :t) = mergeErrors t
\end{code}
%************************************************************************
\begin{code}
type US = Int -- Local unique supply, just a plain Int
-type FromAlt = (LPat RdrName, LHsExpr RdrName)
+type Alt = (LPat RdrName, LHsExpr RdrName)
-mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
-mkTyConGenericBinds tycon
- = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
- `unionBags`
+-- Bindings for the Generic instance
+mkBindsRep :: TyCon -> LHsBinds RdrName
+mkBindsRep tycon =
+ unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
+ `unionBags`
unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
+ where
+ from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
+ to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ]
+ loc = srcLocSpan (getSrcLoc tycon)
+ datacons = tyConDataCons tycon
+
+ -- Recurse over the sum first
+ from_alts, to_alts :: [Alt]
+ (from_alts, to_alts) = mkSum (1 :: US) tycon datacons
+
+--------------------------------------------------------------------------------
+-- The type instance synonym and synonym
+-- type instance Rep (D a b) = Rep_D a b
+-- type Rep_D a b = ...representation type for D ...
+--------------------------------------------------------------------------------
+
+tc_mkRepTyCon :: TyCon -- The type to generate representation for
+ -> MetaTyCons -- Metadata datatypes to refer to
+ -> TcM TyCon -- Generated representation0 type
+tc_mkRepTyCon tycon metaDts =
+-- Consider the example input tycon `D`, where data D a b = D_ a
+ do { -- `rep0` = GHC.Generics.Rep (type family)
+ rep0 <- tcLookupTyCon repTyConName
+
+ -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
+ ; rep0Ty <- tc_mkRepTy tycon metaDts
+
+ -- `rep_name` is a name we generate for the synonym
+ ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR
+ ; let -- `tyvars` = [a,b]
+ tyvars = tyConTyVars tycon
+
+ -- rep0Ty has kind * -> *
+ rep_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
+
+ -- `appT` = D a b
+ appT = [mkTyConApp tycon (mkTyVarTys tyvars)]
+
+ ; buildSynTyCon rep_name tyvars (SynonymTyCon rep0Ty) rep_kind
+ NoParentTyCon (Just (rep0, appT)) }
+
+--------------------------------------------------------------------------------
+-- Type representation
+--------------------------------------------------------------------------------
+
+tc_mkRepTy :: -- The type to generate representation for
+ TyCon
+ -- Metadata datatypes to refer to
+ -> MetaTyCons
+ -- Generated representation0 type
+ -> TcM Type
+tc_mkRepTy tycon metaDts =
+ do
+ d1 <- tcLookupTyCon d1TyConName
+ c1 <- tcLookupTyCon c1TyConName
+ s1 <- tcLookupTyCon s1TyConName
+ nS1 <- tcLookupTyCon noSelTyConName
+ rec0 <- tcLookupTyCon rec0TyConName
+ par0 <- tcLookupTyCon par0TyConName
+ u1 <- tcLookupTyCon u1TyConName
+ v1 <- tcLookupTyCon v1TyConName
+ plus <- tcLookupTyCon sumTyConName
+ times <- tcLookupTyCon prodTyConName
+
+ let mkSum' a b = mkTyConApp plus [a,b]
+ mkProd a b = mkTyConApp times [a,b]
+ mkRec0 a = mkTyConApp rec0 [a]
+ mkPar0 a = mkTyConApp par0 [a]
+ mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)]
+ mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a)
+ (null (dataConFieldLabels a))]
+ -- This field has no label
+ mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a]
+ -- This field has a label
+ mkS False d a = mkTyConApp s1 [d, a]
+
+ sumP [] = mkTyConTy v1
+ sumP l = ASSERT (length metaCTyCons == length l)
+ foldBal mkSum' [ mkC i d a
+ | (d,(a,i)) <- zip metaCTyCons (zip l [0..])]
+ -- The Bool is True if this constructor has labelled fields
+ prod :: Int -> [Type] -> Bool -> Type
+ prod i [] _ = ASSERT (length metaSTyCons > i)
+ ASSERT (length (metaSTyCons !! i) == 0)
+ mkTyConTy u1
+ prod i l b = ASSERT (length metaSTyCons > i)
+ ASSERT (length l == length (metaSTyCons !! i))
+ foldBal mkProd [ arg d t b
+ | (d,t) <- zip (metaSTyCons !! i) l ]
+
+ arg :: Type -> Type -> Bool -> Type
+ arg d t b = mkS b d (recOrPar t (getTyVar_maybe t))
+ -- Argument is not a type variable, use Rec0
+ recOrPar t Nothing = mkRec0 t
+ -- Argument is a type variable, use Par0
+ recOrPar t (Just _) = mkPar0 t
+
+ metaDTyCon = mkTyConTy (metaD metaDts)
+ metaCTyCons = map mkTyConTy (metaC metaDts)
+ metaSTyCons = map (map mkTyConTy) (metaS metaDts)
+
+ return (mkD tycon)
+
+--------------------------------------------------------------------------------
+-- Meta-information
+--------------------------------------------------------------------------------
+
+data MetaTyCons = MetaTyCons { -- One meta datatype per dataype
+ metaD :: TyCon
+ -- One meta datatype per constructor
+ , metaC :: [TyCon]
+ -- One meta datatype per selector per constructor
+ , metaS :: [[TyCon]] }
+
+instance Outputable MetaTyCons where
+ ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
+
+metaTyCons2TyCons :: MetaTyCons -> [TyCon]
+metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s
+
+
+-- Bindings for Datatype, Constructor, and Selector instances
+mkBindsMetaD :: FixityEnv -> TyCon
+ -> ( LHsBinds RdrName -- Datatype instance
+ , [LHsBinds RdrName] -- Constructor instances
+ , [[LHsBinds RdrName]]) -- Selector instances
+mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
+ where
+ mkBag l = foldr1 unionBags
+ [ unitBag (L loc (mkFunBind (L loc name) matches))
+ | (name, matches) <- l ]
+ dtBinds = mkBag [ (datatypeName_RDR, dtName_matches)
+ , (moduleName_RDR, moduleName_matches)]
+
+ allConBinds = map conBinds datacons
+ conBinds c = mkBag ( [ (conName_RDR, conName_matches c)]
+ ++ ifElseEmpty (dataConIsInfix c)
+ [ (conFixity_RDR, conFixity_matches c) ]
+ ++ ifElseEmpty (length (dataConFieldLabels c) > 0)
+ [ (conIsRecord_RDR, conIsRecord_matches c) ]
+ )
+
+ ifElseEmpty p x = if p then x else []
+ fixity c = case lookupFixity fix_env (dataConName c) of
+ Fixity n InfixL -> buildFix n leftAssocDataCon_RDR
+ Fixity n InfixR -> buildFix n rightAssocDataCon_RDR
+ Fixity n InfixN -> buildFix n notAssocDataCon_RDR
+ buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc
+ , nlHsIntLit (toInteger n)]
+
+ allSelBinds = map (map selBinds) datasels
+ selBinds s = mkBag [(selName_RDR, selName_matches s)]
+
+ loc = srcLocSpan (getSrcLoc tycon)
+ mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
+ datacons = tyConDataCons tycon
+ datasels = map dataConFieldLabels datacons
+
+ dtName_matches = mkStringLHS . showPpr . nameOccName . tyConName
+ $ tycon
+ moduleName_matches = mkStringLHS . moduleNameString . moduleName
+ . nameModule . tyConName $ tycon
+
+ conName_matches c = mkStringLHS . showPpr . nameOccName
+ . dataConName $ c
+ conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)]
+ conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
+
+ selName_matches s = mkStringLHS (showPpr (nameOccName s))
+
+
+--------------------------------------------------------------------------------
+-- Dealing with sums
+--------------------------------------------------------------------------------
+
+mkSum :: US -- Base for generating unique names
+ -> TyCon -- The type constructor
+ -> [DataCon] -- The data constructors
+ -> ([Alt], -- Alternatives for the T->Trep "from" function
+ [Alt]) -- Alternatives for the Trep->T "to" function
+
+-- Datatype without any constructors
+mkSum _us tycon [] = ([from_alt], [to_alt])
+ where
+ from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
+ to_alt = (mkM1_P nlWildPat, makeError errMsgTo)
+ -- These M1s are meta-information for the datatype
+ makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
+ errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon
+ errMsgTo = "No values for empty datatype " ++ showPpr tycon
+
+-- Datatype with at least one constructor
+mkSum us _tycon datacons =
+ unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
+
+-- Build the sum for a particular constructor
+mk1Sum :: US -- Base for generating unique names
+ -> Int -- The index of this constructor
+ -> Int -- Total number of constructors
+ -> DataCon -- The data constructor
+ -> (Alt, -- Alternative for the T->Trep "from" function
+ Alt) -- Alternative for the Trep->T "to" function
+mk1Sum us i n datacon = (from_alt, to_alt)
where
- from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts]
- to_matches = [mkSimpleHsAlt to_pat to_body]
- loc = srcLocSpan (getSrcLoc tycon)
- datacons = tyConDataCons tycon
- (from_RDR, to_RDR) = mkGenericNames tycon
-
- -- Recurse over the sum first
- from_alts :: [FromAlt]
- (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons
- init_us = 1::Int -- Unique supply
-
-----------------------------------------------------
--- Dealing with sums
-----------------------------------------------------
-
-mk_sum_stuff :: US -- Base for generating unique names
- -> [DataCon] -- The data constructors
- -> ([FromAlt], -- Alternatives for the T->Trep "from" function
- InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function
-
--- For example, given
--- data T = C | D Int Int Int
---
--- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))],
--- case cd of { Inl u -> C;
--- Inr abc -> case abc of { a :*: bc ->
--- case bc of { b :*: c ->
--- D a b c }} },
--- cd)
-
-mk_sum_stuff us [datacon]
- = ([from_alt], to_pat, to_body_fn app_exp)
- where
- n_args = dataConSourceArity datacon -- Existentials already excluded
-
- datacon_vars = map mkGenericLocal [us .. us+n_args-1]
- us' = us + n_args
-
- datacon_rdr = getRdrName datacon
- app_exp = nlHsVarApps datacon_rdr datacon_vars
- from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
-
- (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars
-
-mk_sum_stuff us datacons
- = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts,
- nlVarPat to_arg,
- noLoc (HsCase (nlHsVar to_arg)
- (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body,
- mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])))
+ n_args = dataConSourceArity datacon -- Existentials already excluded
+
+ datacon_vars = map mkGenericLocal [us .. us+n_args-1]
+ us' = us + n_args
+
+ datacon_rdr = getRdrName datacon
+ app_exp = nlHsVarApps datacon_rdr datacon_vars
+
+ from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
+ from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars))
+
+ to_alt = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs)
+ -- These M1s are meta-information for the datatype
+ to_alt_rhs = app_exp
+
+-- Generates the L1/R1 sum pattern
+genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName
+genLR_P i n p
+ | n == 0 = error "impossible"
+ | n == 1 = p
+ | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p]
+ | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p]
+ where m = div n 2
+
+-- Generates the L1/R1 sum expression
+genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName
+genLR_E i n e
+ | n == 0 = error "impossible"
+ | n == 1 = e
+ | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i (div n 2) e
+ | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m) e
+ where m = div n 2
+
+--------------------------------------------------------------------------------
+-- Dealing with products
+--------------------------------------------------------------------------------
+
+-- Build a product expression
+mkProd_E :: US -- Base for unique names
+ -> [RdrName] -- List of variables matched on the lhs
+ -> LHsExpr RdrName -- Resulting product expression
+mkProd_E _ [] = mkM1_E (nlHsVar u1DataCon_RDR)
+mkProd_E _ vars = mkM1_E (foldBal prod appVars)
+ -- These M1s are meta-information for the constructor
where
- (l_datacons, r_datacons) = splitInHalf datacons
- (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons
- (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons
-
- to_arg = mkGenericLocal us
- us' = us+1
-
- wrap :: RdrName -> [FromAlt] -> [FromAlt]
- -- Wrap an application of the Inl or Inr constructor round each alternative
- wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts]
-
-
-----------------------------------------------------
--- Dealing with products
-----------------------------------------------------
-mk_prod_stuff :: US -- Base for unique names
- -> [RdrName] -- arg-ids; args of the original user-defined constructor
- -- They are bound enclosing from_rhs
- -- Please bind these in the to_body_fn
- -> (US, -- Depleted unique-name supply
- LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids
- InPat RdrName, -- to_pat:
- LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation
-
--- For example:
--- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c),
--- abc,
--- \<body-code> -> case abc of { a :*: bc ->
--- case bc of { b :*: c ->
--- <body-code> )
-
--- We need to use different uniques in the branches
--- because the returned to_body_fns are nested.
--- Hence the returned unqique-name supply
-
-mk_prod_stuff us [] -- Unit case
- = (us+1,
- nlHsVar genUnitDataCon_RDR,
- noLoc (SigPatIn (nlVarPat (mkGenericLocal us))
- (noLoc (HsTyVar (getRdrName genUnitTyConName)))),
- -- Give a signature to the pattern so we get
- -- data S a = Nil | S a
- -- toS = \x -> case x of { Inl (g :: Unit) -> Nil
- -- Inr x -> S x }
- -- The (:: Unit) signature ensures that we'll infer the right
- -- type for toS. If we leave it out, the type is too polymorphic
-
- \x -> x)
-
-mk_prod_stuff us [arg_var] -- Singleton case
- = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x)
-
-mk_prod_stuff us arg_vars -- Two or more
- = (us'',
- nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs],
- nlVarPat to_arg,
--- gaw 2004 FIX?
- \x -> noLoc (HsCase (nlHsVar to_arg)
- (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])))
+ appVars = map wrapArg_E vars
+ prod a b = prodDataCon_RDR `nlHsApps` [a,b]
+
+wrapArg_E :: RdrName -> LHsExpr RdrName
+wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v])
+ -- This M1 is meta-information for the selector
+
+-- Build a product pattern
+mkProd_P :: US -- Base for unique names
+ -> [RdrName] -- List of variables to match
+ -> LPat RdrName -- Resulting product pattern
+mkProd_P _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR)
+mkProd_P _ vars = mkM1_P (foldBal prod appVars)
+ -- These M1s are meta-information for the constructor
where
- to_arg = mkGenericLocal us
- (l_arg_vars, r_arg_vars) = splitInHalf arg_vars
- (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars
- (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars
- pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat]
-
-splitInHalf :: [a] -> ([a],[a])
-splitInHalf list = (left, right)
- where
- half = length list `div` 2
- left = take half list
- right = drop half list
+ appVars = map wrapArg_P vars
+ prod a b = prodDataCon_RDR `nlConPat` [a,b]
+
+wrapArg_P :: RdrName -> LPat RdrName
+wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v])
+ -- This M1 is meta-information for the selector
mkGenericLocal :: US -> RdrName
mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
-mkGenericNames :: TyCon -> (RdrName, RdrName)
-mkGenericNames tycon
- = (from_RDR, to_RDR)
- where
- tc_name = tyConName tycon
- tc_occ = nameOccName tc_name
- tc_mod = ASSERT( isExternalName tc_name ) nameModule tc_name
- from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ)
- to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Generating the RHS of a generic default method}
-%* *
-%************************************************************************
-
-Generating the Generic default method. Uses the bimaps to generate the
-actual method. All of this is rather incomplete, but it would be nice
-to make even this work. Example
-
- class Foo a where
- op :: Op a
-
- instance Foo T
-
-Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs:
-
- instance Foo T where
- op = <mkGenericRhs op a T>
-
-To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where
-
- toOp :: Op Trep -> Op T
- fromOp :: Op T -> Op Trep
-
-(the bimap) and then fill in the RHS with
-
- instance Foo T where
- op = toOp op
-
-Remember, we're generating a RenamedHsExpr, so the result of all this
-will be fed to the type checker. So the 'op' on the RHS will be
-at the representation type for T, Trep.
+mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName
+mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
+mkM1_P :: LPat RdrName -> LPat RdrName
+mkM1_P p = m1DataCon_RDR `nlConPat` [p]
-Note [Polymorphic methods]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose the class op is polymorphic:
+-- | Variant of foldr1 for producing balanced lists
+foldBal :: (a -> a -> a) -> [a] -> a
+foldBal op = foldBal' op (error "foldBal: empty list")
- class Baz a where
- op :: forall b. Ord b => a -> b -> b
+foldBal' :: (a -> a -> a) -> a -> [a] -> a
+foldBal' _ x [] = x
+foldBal' _ _ [y] = y
+foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l
+ in foldBal' op x a `op` foldBal' op x b
-Then we can still generate a bimap with
-
- toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b)
-
-and fill in the instance decl thus
-
- instance Foo T where
- op = toOp op
-
-By the time the type checker has done its stuff we'll get
-
- instance Foo T where
- op = \b. \dict::Ord b. toOp b (op Trep b dict)
-
-Note [Higher rank methods]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Higher-rank method types don't work, because we'd generate a bimap that
-needs impredicative polymorphism. In principle that should be possible
-(with boxy types and all) but it would take a bit of working out. Here's
-an example:
- class ChurchEncode k where
- match :: k -> z
- -> (forall a b z. a -> b -> z) {- product -}
- -> (forall a z. a -> z) {- left -}
- -> (forall a z. a -> z) {- right -}
- -> z
-
- match {| Unit |} Unit unit prod left right = unit
- match {| a :*: b |} (x :*: y) unit prod left right = prod x y
- match {| a :+: b |} (Inl l) unit prod left right = left l
- match {| a :+: b |} (Inr r) unit prod left right = right r
-
-\begin{code}
-mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName
-mkGenericRhs sel_id tyvar tycon
- = ASSERT( isSingleton ctxt ) -- Checks shape of selector-id context
--- pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $
- mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id))
- where
- -- Initialising the "Environment" with the from/to functions
- -- on the datatype (actually tycon) in question
- (from_RDR, to_RDR) = mkGenericNames tycon
-
- -- Instantiate the selector type, and strip off its class context
- (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar))
-
- -- Do it again! This deals with the case where the method type
- -- is polymorphic -- see Note [Polymorphic methods] above
- (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty
-
- -- Now we probably have a tycon in front
- -- of us, quite probably a FunTyCon.
- ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR)
- bimap = generate_bimap (tyvar, ep, local_tvs) final_ty
-
-type EPEnv = (TyVar, -- The class type variable
- EP (LHsExpr RdrName), -- The EP it maps to
- [TyVar] -- Other in-scope tyvars; they have an identity EP
- )
-
--------------------
-generate_bimap :: EPEnv
- -> Type
- -> EP (LHsExpr RdrName)
--- Top level case - splitting the TyCon.
-generate_bimap env@(tv,ep,local_tvs) ty
- | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty))
- = idEP -- A constant type
-
- | Just tv1 <- getTyVar_maybe ty
- = ASSERT( tv == tv1 ) ep -- The class tyvar
-
- | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty
- = bimapTyCon tycon (map (generate_bimap env) ty_args)
-
- | otherwise
- = pprPanic "generate_bimap" (ppr ty)
-
--------------------
-bimapTyCon :: TyCon -> [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapTyCon tycon arg_eps
- | tycon == funTyCon = bimapArrow arg_eps
- | tycon == listTyCon = bimapList arg_eps
- | isBoxedTupleTyCon tycon = bimapTuple arg_eps
- | otherwise = pprPanic "bimapTyCon" (ppr tycon)
-
--------------------
--- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b')
-bimapArrow :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapArrow [ep1, ep2]
- = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body,
- toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body }
- where
- from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR))
- to_body = toEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR))
-
--------------------
--- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn)
-bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapTuple eps
- = EP { fromEP = mkHsLam [noLoc tuple_pat] from_body,
- toEP = mkHsLam [noLoc tuple_pat] to_body }
- where
- names = takeList eps gs_RDR
- tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType
- eps_w_names = eps `zip` names
- to_body = mkLHsTupleExpr [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
- from_body = mkLHsTupleExpr [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names]
-
--------------------
--- bimapList :: EP a b -> EP [a] [b]
-bimapList :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName)
-bimapList [ep]
- = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep),
- toEP = nlHsApp (nlHsVar map_RDR) (toEP ep) }
-
--------------------
-a_RDR, b_RDR :: RdrName
-a_RDR = mkVarUnqual (fsLit "a")
-b_RDR = mkVarUnqual (fsLit "b")
-
-gs_RDR :: [RdrName]
-gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ]
-
-idEP :: EP (LHsExpr RdrName)
-idEP = EP idexpr idexpr
- where
- idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR)
\end{code}
setInstanceDFunId :: Instance -> DFunId -> Instance
setInstanceDFunId ispec dfun
- = ASSERT( idType dfun `tcEqType` idType (is_dfun ispec) )
+ = ASSERT( idType dfun `eqType` idType (is_dfun ispec) )
-- We need to create the cached fields afresh from
-- the new dfun id. In particular, the is_tvs in
-- the Instance must match those in the dfun!
| debugStyle sty = theta
| otherwise = drop (dfunNSilent dfun) theta
in ptext (sLit "instance") <+> ppr flag
- <+> sep [pprThetaArrow theta_to_print, ppr res_ty]
+ <+> sep [pprThetaArrowTy theta_to_print, ppr res_ty]
where
dfun = is_dfun ispec
(_, theta, res_ty) = tcSplitSigmaTy (idType dfun)
--- /dev/null
+%
+% (c) The University of Glasgow 2006
+%
+
+\begin{code}
+module Kind (
+ -- * Main data type
+ Kind, typeKind,
+
+ -- Kinds
+ liftedTypeKind, unliftedTypeKind, openTypeKind,
+ argTypeKind, ubxTupleKind,
+ mkArrowKind, mkArrowKinds,
+
+ -- Kind constructors...
+ liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
+ argTypeKindTyCon, ubxTupleKindTyCon,
+ ecKind,
+
+ -- Super Kinds
+ tySuperKind, tySuperKindTyCon,
+
+ pprKind, pprParendKind,
+
+ -- ** Deconstructing Kinds
+ kindFunResult, kindAppResult, synTyConResKind,
+ splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
+
+ -- ** Predicates on Kinds
+ isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
+ isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind,
+ isSuperKind, isCoercionKind,
+ isLiftedTypeKindCon,
+
+ isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind,
+ isSubKindCon,
+
+ ) where
+
+#include "HsVersions.h"
+
+import TypeRep
+import TysPrim
+import TyCon
+import Var
+import PrelNames
+import Outputable
+\end{code}
+
+%************************************************************************
+%* *
+ Predicates over Kinds
+%* *
+%************************************************************************
+
+\begin{code}
+isTySuperKind :: SuperKind -> Bool
+isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
+isTySuperKind _ = False
+
+-------------------
+-- Lastly we need a few functions on Kinds
+
+isLiftedTypeKindCon :: TyCon -> Bool
+isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey
+\end{code}
+
+%************************************************************************
+%* *
+ The kind of a type
+%* *
+%************************************************************************
+
+\begin{code}
+typeKind :: Type -> Kind
+typeKind _ty@(TyConApp tc tys)
+ = ASSERT2( not (tc `hasKey` eqPredPrimTyConKey) || length tys == 2, ppr _ty )
+ -- Assertion checks for unsaturated application of (~)
+ -- See Note [The (~) TyCon] in TysPrim
+ kindAppResult (tyConKind tc) tys
+
+typeKind (PredTy pred) = predKind pred
+typeKind (AppTy fun _) = kindFunResult (typeKind fun)
+typeKind (ForAllTy _ ty) = typeKind ty
+typeKind (TyVarTy tyvar) = tyVarKind tyvar
+typeKind (FunTy _arg res)
+ -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*),
+ -- not unliftedTypKind (#)
+ -- The only things that can be after a function arrow are
+ -- (a) types (of kind openTypeKind or its sub-kinds)
+ -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *))
+ | isTySuperKind k = k
+ | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind
+ where
+ k = typeKind res
+
+------------------
+predKind :: PredType -> Kind
+predKind (EqPred {}) = unliftedTypeKind -- Coercions are unlifted
+predKind (ClassP {}) = liftedTypeKind -- Class and implicitPredicates are
+predKind (IParam {}) = liftedTypeKind -- always represented by lifted types
+\end{code}
+
+%************************************************************************
+%* *
+ Functions over Kinds
+%* *
+%************************************************************************
+
+\begin{code}
+-- | Essentially 'funResultTy' on kinds
+kindFunResult :: Kind -> Kind
+kindFunResult (FunTy _ res) = res
+kindFunResult k = pprPanic "kindFunResult" (ppr k)
+
+kindAppResult :: Kind -> [arg] -> Kind
+kindAppResult k [] = k
+kindAppResult k (_:as) = kindAppResult (kindFunResult k) as
+
+-- | Essentially 'splitFunTys' on kinds
+splitKindFunTys :: Kind -> ([Kind],Kind)
+splitKindFunTys (FunTy a r) = case splitKindFunTys r of
+ (as, k) -> (a:as, k)
+splitKindFunTys k = ([], k)
+
+splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind)
+splitKindFunTy_maybe (FunTy a r) = Just (a,r)
+splitKindFunTy_maybe _ = Nothing
+
+-- | Essentially 'splitFunTysN' on kinds
+splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
+splitKindFunTysN 0 k = ([], k)
+splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of
+ (as, k) -> (a:as, k)
+splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k)
+
+-- | Find the result 'Kind' of a type synonym,
+-- after applying it to its 'arity' number of type variables
+-- Actually this function works fine on data types too,
+-- but they'd always return '*', so we never need to ask
+synTyConResKind :: TyCon -> Kind
+synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon)
+
+-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
+isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool
+isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon,
+ isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool
+
+isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey
+
+isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc
+isOpenTypeKind _ = False
+
+isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey
+
+isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc
+isUbxTupleKind _ = False
+
+isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey
+
+isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc
+isArgTypeKind _ = False
+
+isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey
+
+isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc
+isUnliftedTypeKind _ = False
+
+isSubOpenTypeKind :: Kind -> Bool
+-- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow)
+isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) )
+ ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) )
+ False
+isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True
+isSubOpenTypeKind other = ASSERT( isKind other ) False
+ -- This is a conservative answer
+ -- It matters in the call to isSubKind in
+ -- checkExpectedKind.
+
+isSubArgTypeKindCon kc
+ | isUnliftedTypeKindCon kc = True
+ | isLiftedTypeKindCon kc = True
+ | isArgTypeKindCon kc = True
+ | otherwise = False
+
+isSubArgTypeKind :: Kind -> Bool
+-- ^ True of any sub-kind of ArgTypeKind
+isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc
+isSubArgTypeKind _ = False
+
+-- | Is this a super-kind (i.e. a type-of-kinds)?
+isSuperKind :: Type -> Bool
+isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc
+isSuperKind _ = False
+
+-- | Is this a kind (i.e. a type-of-types)?
+isKind :: Kind -> Bool
+isKind k = isSuperKind (typeKind k)
+
+isSubKind :: Kind -> Kind -> Bool
+-- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@
+isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2
+isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2)
+isSubKind _ _ = False
+
+isSubKindCon :: TyCon -> TyCon -> Bool
+-- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@
+isSubKindCon kc1 kc2
+ | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True
+ | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True
+ | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True
+ | isOpenTypeKindCon kc2 = True
+ -- we already know kc1 is not a fun, its a TyCon
+ | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True
+ | otherwise = False
+
+defaultKind :: Kind -> Kind
+-- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more
+-- information on what that means
+
+-- When we generalise, we make generic type variables whose kind is
+-- simple (* or *->* etc). So generic type variables (other than
+-- built-in constants like 'error') always have simple kinds. This is important;
+-- consider
+-- f x = True
+-- We want f to get type
+-- f :: forall (a::*). a -> Bool
+-- Not
+-- f :: forall (a::??). a -> Bool
+-- because that would allow a call like (f 3#) as well as (f True),
+--and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr.
+defaultKind k
+ | isSubOpenTypeKind k = liftedTypeKind
+ | isSubArgTypeKind k = liftedTypeKind
+ | otherwise = k
+
+ecKind = liftedTypeKind `mkArrowKind` (liftedTypeKind `mkArrowKind` liftedTypeKind)
+\end{code}
\ No newline at end of file
-%\r
-% (c) The University of Glasgow 2006\r
-%\r
-\r
-\begin{code}\r
-{-# OPTIONS_GHC -w #-}\r
-module OptCoercion (\r
- optCoercion\r
- ) where \r
-\r
-#include "HsVersions.h"\r
-\r
-import Unify ( tcMatchTy )\r
-import Coercion\r
-import Type\r
-import TypeRep\r
-import TyCon\r
-import Var\r
-import VarSet\r
-import VarEnv\r
-import PrelNames\r
-import StaticFlags ( opt_NoOptCoercion )\r
-import Util\r
-import Outputable\r
-\end{code}\r
-\r
-%************************************************************************\r
-%* *\r
- Optimising coercions \r
-%* *\r
-%************************************************************************\r
-\r
-Note [Subtle shadowing in coercions]\r
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\r
-Supose we optimising a coercion\r
- optCoercion (forall (co_X5:t1~t2). ...co_B1...)\r
-The co_X5 is a wild-card; the bound variable of a coercion for-all\r
-should never appear in the body of the forall. Indeed we often\r
-write it like this\r
- optCoercion ( (t1~t2) => ...co_B1... )\r
-\r
-Just because it's a wild-card doesn't mean we are free to choose\r
-whatever variable we like. For example it'd be wrong for optCoercion\r
-to return\r
- forall (co_B1:t1~t2). ...co_B1...\r
-because now the co_B1 (which is really free) has been captured, and\r
-subsequent substitutions will go wrong. That's why we can't use\r
-mkCoPredTy in the ForAll case, where this note appears. \r
-\r
-\begin{code}\r
-optCoercion :: TvSubst -> Coercion -> NormalCo\r
--- ^ optCoercion applies a substitution to a coercion, \r
--- *and* optimises it to reduce its size\r
-optCoercion env co \r
- | opt_NoOptCoercion = substTy env co\r
- | otherwise = opt_co env False co\r
-\r
-type NormalCo = Coercion\r
- -- Invariants: \r
- -- * The substitution has been fully applied\r
- -- * For trans coercions (co1 `trans` co2)\r
- -- co1 is not a trans, and neither co1 nor co2 is identity\r
- -- * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types)\r
-\r
-type NormalNonIdCo = NormalCo -- Extra invariant: not the identity\r
-\r
-opt_co, opt_co' :: TvSubst\r
- -> Bool -- True <=> return (sym co)\r
- -> Coercion\r
- -> NormalCo \r
-opt_co = opt_co'\r
-\r
-{- Debuggery \r
-opt_co env sym co \r
--- = pprTrace "opt_co {" (ppr sym <+> ppr co) $\r
--- co1 `seq` \r
--- pprTrace "opt_co done }" (ppr co1) \r
--- WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (s1,t1) \r
--- $$ ppr co1 <+> dcolon <+> pprEqPred (s2,t2) )\r
- = WARN( not (coreEqType co1 simple_result), \r
- (text "env=" <+> ppr env) $$\r
- (text "input=" <+> ppr co) $$\r
- (text "simple=" <+> ppr simple_result) $$\r
- (text "opt=" <+> ppr co1) )\r
- co1\r
- where\r
- co1 = opt_co' env sym co\r
- same_co_kind = s1 `coreEqType` s2 && t1 `coreEqType` t2\r
- (s,t) = coercionKind (substTy env co)\r
- (s1,t1) | sym = (t,s)\r
- | otherwise = (s,t)\r
- (s2,t2) = coercionKind co1\r
-\r
- simple_result | sym = mkSymCoercion (substTy env co)\r
- | otherwise = substTy env co\r
--}\r
-\r
-opt_co' env sym (AppTy ty1 ty2) = mkAppTy (opt_co env sym ty1) (opt_co env sym ty2)\r
-opt_co' env sym (FunTy ty1 ty2) = FunTy (opt_co env sym ty1) (opt_co env sym ty2)\r
-opt_co' env sym (PredTy (ClassP cls tys)) = PredTy (ClassP cls (map (opt_co env sym) tys))\r
-opt_co' env sym (PredTy (IParam n ty)) = PredTy (IParam n (opt_co env sym ty))\r
-opt_co' _ _ co@(PredTy (EqPred {})) = pprPanic "optCoercion" (ppr co)\r
-\r
-opt_co' env sym co@(TyVarTy tv)\r
- | Just ty <- lookupTyVar env tv = opt_co' (zapTvSubstEnv env) sym ty\r
- | not (isCoVar tv) = co -- Identity; does not mention a CoVar\r
- | ty1 `coreEqType` ty2 = ty1 -- Identity; ..ditto..\r
- | not sym = co\r
- | otherwise = mkSymCoercion co\r
- where\r
- (ty1,ty2) = coVarKind tv\r
-\r
-opt_co' env sym (ForAllTy tv cor) \r
- | isTyVar tv = case substTyVarBndr env tv of\r
- (env', tv') -> ForAllTy tv' (opt_co' env' sym cor)\r
-\r
-opt_co' env sym co@(ForAllTy co_var cor) \r
- | isCoVar co_var \r
- = WARN( co_var `elemVarSet` tyVarsOfType cor, ppr co )\r
- ForAllTy co_var' cor'\r
- where\r
- (co1,co2) = coVarKind co_var\r
- co1' = opt_co' env sym co1\r
- co2' = opt_co' env sym co2\r
- cor' = opt_co' env sym cor\r
- co_var' = uniqAway (getTvInScope env) (mkWildCoVar (mkCoKind co1' co2'))\r
- -- See Note [Subtle shadowing in coercions]\r
-\r
-opt_co' env sym (TyConApp tc cos)\r
- | Just (arity, desc) <- isCoercionTyCon_maybe tc\r
- = mkAppTys (opt_co_tc_app env sym tc desc (take arity cos))\r
- (map (opt_co env sym) (drop arity cos))\r
- | otherwise\r
- = TyConApp tc (map (opt_co env sym) cos)\r
-\r
---------\r
-opt_co_tc_app :: TvSubst -> Bool -> TyCon -> CoTyConDesc -> [Coercion] -> NormalCo\r
--- Used for CoercionTyCons only\r
--- Arguments are *not* already simplified/substituted\r
-opt_co_tc_app env sym tc desc cos\r
- = case desc of\r
- CoAxiom {} -- Do *not* push sym inside top-level axioms\r
- -- e.g. if g is a top-level axiom\r
- -- g a : F a ~ a\r
- -- Then (sym (g ty)) /= g (sym ty) !!\r
- | sym -> mkSymCoercion the_co \r
- | otherwise -> the_co\r
- where\r
- the_co = TyConApp tc (map (opt_co env False) cos)\r
- -- Note that the_co does *not* have sym pushed into it\r
- \r
- CoTrans \r
- | sym -> opt_trans opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g\r
- | otherwise -> opt_trans opt_co1 opt_co2\r
-\r
- CoUnsafe\r
- | sym -> mkUnsafeCoercion ty2' ty1'\r
- | otherwise -> mkUnsafeCoercion ty1' ty2'\r
-\r
- CoSym -> opt_co env (not sym) co1\r
- CoLeft -> opt_lr fst\r
- CoRight -> opt_lr snd\r
- CoCsel1 -> opt_csel fstOf3\r
- CoCsel2 -> opt_csel sndOf3\r
- CoCselR -> opt_csel thirdOf3\r
-\r
- CoInst -- See if the first arg is already a forall\r
- -- ...then we can just extend the current substitution\r
- | Just (tv, co1_body) <- splitForAllTy_maybe co1\r
- -> opt_co (extendTvSubst env tv ty2') sym co1_body\r
-\r
- -- See if is *now* a forall\r
- | Just (tv, opt_co1_body) <- splitForAllTy_maybe opt_co1\r
- -> substTyWith [tv] [ty2'] opt_co1_body -- An inefficient one-variable substitution\r
-\r
- | otherwise\r
- -> TyConApp tc [opt_co1, ty2']\r
-\r
- where\r
- (co1 : cos1) = cos\r
- (co2 : _) = cos1\r
-\r
- ty1' = substTy env co1\r
- ty2' = substTy env co2\r
-\r
- -- These opt_cos have the sym pushed into them\r
- opt_co1 = opt_co env sym co1\r
- opt_co2 = opt_co env sym co2\r
-\r
- the_unary_opt_co = TyConApp tc [opt_co1]\r
-\r
- opt_lr sel = case splitAppTy_maybe opt_co1 of\r
- Nothing -> the_unary_opt_co \r
- Just lr -> sel lr\r
- opt_csel sel = case splitCoPredTy_maybe opt_co1 of\r
- Nothing -> the_unary_opt_co \r
- Just lr -> sel lr\r
-\r
--------------\r
-opt_transL :: [NormalCo] -> [NormalCo] -> [NormalCo]\r
-opt_transL = zipWith opt_trans\r
-\r
-opt_trans :: NormalCo -> NormalCo -> NormalCo\r
-opt_trans co1 co2\r
- | isIdNormCo co1 = co2\r
- | otherwise = opt_trans1 co1 co2\r
-\r
-opt_trans1 :: NormalNonIdCo -> NormalCo -> NormalCo\r
--- First arg is not the identity\r
-opt_trans1 co1 co2\r
- | isIdNormCo co2 = co1\r
- | otherwise = opt_trans2 co1 co2\r
-\r
-opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo\r
--- Neither arg is the identity\r
-opt_trans2 (TyConApp tc [co1a,co1b]) co2\r
- | tc `hasKey` transCoercionTyConKey\r
- = opt_trans1 co1a (opt_trans2 co1b co2)\r
-\r
-opt_trans2 co1 co2 \r
- | Just co <- opt_trans_rule co1 co2\r
- = co\r
-\r
-opt_trans2 co1 (TyConApp tc [co2a,co2b])\r
- | tc `hasKey` transCoercionTyConKey\r
- , Just co1_2a <- opt_trans_rule co1 co2a\r
- = if isIdNormCo co1_2a\r
- then co2b\r
- else opt_trans2 co1_2a co2b\r
-\r
-opt_trans2 co1 co2\r
- = mkTransCoercion co1 co2\r
-\r
-------\r
-opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo\r
-opt_trans_rule (TyConApp tc1 args1) (TyConApp tc2 args2)\r
- | tc1 == tc2\r
- = case isCoercionTyCon_maybe tc1 of\r
- Nothing \r
- -> Just (TyConApp tc1 (opt_transL args1 args2))\r
- Just (arity, desc) \r
- | arity == length args1\r
- -> opt_trans_rule_equal_tc desc args1 args2\r
- | otherwise\r
- -> case opt_trans_rule_equal_tc desc \r
- (take arity args1) \r
- (take arity args2) of\r
- Just co -> Just $ mkAppTys co $ \r
- opt_transL (drop arity args1) (drop arity args2)\r
- Nothing -> Nothing \r
- \r
--- Push transitivity inside apply\r
-opt_trans_rule co1 co2\r
- | Just (co1a, co1b) <- splitAppTy_maybe co1\r
- , Just (co2a, co2b) <- etaApp_maybe co2\r
- = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b))\r
-\r
- | Just (co2a, co2b) <- splitAppTy_maybe co2\r
- , Just (co1a, co1b) <- etaApp_maybe co1\r
- = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b))\r
-\r
--- Push transitivity inside (s~t)=>r\r
--- We re-use the CoVar rather than using mkCoPredTy\r
--- See Note [Subtle shadowing in coercions]\r
-opt_trans_rule co1 co2\r
- | Just (cv1,r1) <- splitForAllTy_maybe co1\r
- , isCoVar cv1\r
- , Just (s1,t1) <- coVarKind_maybe cv1\r
- , Just (s2,t2,r2) <- etaCoPred_maybe co2\r
- = Just (ForAllTy (mkCoVar (coVarName cv1) (mkCoKind (opt_trans s1 s2) (opt_trans t1 t2)))\r
- (opt_trans r1 r2))\r
-\r
- | Just (cv2,r2) <- splitForAllTy_maybe co2\r
- , isCoVar cv2\r
- , Just (s2,t2) <- coVarKind_maybe cv2\r
- , Just (s1,t1,r1) <- etaCoPred_maybe co1\r
- = Just (ForAllTy (mkCoVar (coVarName cv2) (mkCoKind (opt_trans s1 s2) (opt_trans t1 t2)))\r
- (opt_trans r1 r2))\r
-\r
--- Push transitivity inside forall\r
-opt_trans_rule co1 co2\r
- | Just (tv1,r1) <- splitTypeForAll_maybe co1\r
- , Just (tv2,r2) <- etaForAll_maybe co2\r
- , let r2' = substTyWith [tv2] [TyVarTy tv1] r2\r
- = Just (ForAllTy tv1 (opt_trans2 r1 r2'))\r
-\r
- | Just (tv2,r2) <- splitTypeForAll_maybe co2\r
- , Just (tv1,r1) <- etaForAll_maybe co1\r
- , let r1' = substTyWith [tv1] [TyVarTy tv2] r1\r
- = Just (ForAllTy tv1 (opt_trans2 r1' r2))\r
-\r
-opt_trans_rule co1 co2\r
-{- Omitting for now, because unsound\r
- | Just (sym1, (ax_tc1, ax1_args, ax_tvs, ax_lhs, ax_rhs)) <- co1_is_axiom_maybe\r
- , Just (sym2, (ax_tc2, ax2_args, _, _, _)) <- co2_is_axiom_maybe\r
- , ax_tc1 == ax_tc2\r
- , sym1 /= sym2\r
- = Just $\r
- if sym1 \r
- then substTyWith ax_tvs (opt_transL (map mkSymCoercion ax1_args) ax2_args) ax_rhs\r
- else substTyWith ax_tvs (opt_transL ax1_args (map mkSymCoercion ax2_args)) ax_lhs\r
--}\r
-\r
- | Just (sym, (ax_tc, ax_args, ax_tvs, ax_lhs, _)) <- co1_is_axiom_maybe\r
- , Just cos <- matchesAxiomLhs ax_tvs ax_lhs co2\r
- = Just $ \r
- if sym \r
- then mkSymCoercion $ TyConApp ax_tc (opt_transL (map mkSymCoercion cos) ax_args)\r
- else TyConApp ax_tc (opt_transL ax_args cos)\r
-\r
- | Just (sym, (ax_tc, ax_args, ax_tvs, ax_lhs, _)) <- isAxiom_maybe co2\r
- , Just cos <- matchesAxiomLhs ax_tvs ax_lhs co1\r
- = Just $ \r
- if sym \r
- then mkSymCoercion $ TyConApp ax_tc (opt_transL ax_args (map mkSymCoercion cos))\r
- else TyConApp ax_tc (opt_transL cos ax_args)\r
- where\r
- co1_is_axiom_maybe = isAxiom_maybe co1\r
- co2_is_axiom_maybe = isAxiom_maybe co2\r
-\r
-opt_trans_rule co1 co2 -- Identity rule\r
- | (ty1,_) <- coercionKind co1\r
- , (_,ty2) <- coercionKind co2\r
- , ty1 `coreEqType` ty2\r
- = Just ty2\r
-\r
-opt_trans_rule _ _ = Nothing\r
-\r
------------ \r
-isAxiom_maybe :: Coercion -> Maybe (Bool, (TyCon, [Coercion], [TyVar], Type, Type))\r
-isAxiom_maybe co\r
- | Just (tc, args) <- splitTyConApp_maybe co\r
- , Just (_, desc) <- isCoercionTyCon_maybe tc\r
- = case desc of\r
- CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs } \r
- -> Just (False, (tc, args, tvs, lhs, rhs))\r
- CoSym | (arg1:_) <- args \r
- -> case isAxiom_maybe arg1 of\r
- Nothing -> Nothing\r
- Just (sym, stuff) -> Just (not sym, stuff)\r
- _ -> Nothing\r
- | otherwise\r
- = Nothing\r
-\r
-matchesAxiomLhs :: [TyVar] -> Type -> Type -> Maybe [Type]\r
-matchesAxiomLhs tvs ty_tmpl ty \r
- = case tcMatchTy (mkVarSet tvs) ty_tmpl ty of\r
- Nothing -> Nothing\r
- Just subst -> Just (map (substTyVar subst) tvs)\r
-\r
------------ \r
-opt_trans_rule_equal_tc :: CoTyConDesc -> [Coercion] -> [Coercion] -> Maybe Coercion\r
--- Rules for Coercion TyCons only\r
-\r
--- Push transitivity inside instantiation\r
-opt_trans_rule_equal_tc desc [co1,ty1] [co2,ty2]\r
- | CoInst <- desc\r
- , ty1 `coreEqType` ty2\r
- , co1 `compatible_co` co2\r
- = Just (mkInstCoercion (opt_trans2 co1 co2) ty1) \r
-\r
-opt_trans_rule_equal_tc desc [co1] [co2]\r
- | CoLeft <- desc, is_compat = Just (mkLeftCoercion res_co)\r
- | CoRight <- desc, is_compat = Just (mkRightCoercion res_co)\r
- | CoCsel1 <- desc, is_compat = Just (mkCsel1Coercion res_co)\r
- | CoCsel2 <- desc, is_compat = Just (mkCsel2Coercion res_co)\r
- | CoCselR <- desc, is_compat = Just (mkCselRCoercion res_co)\r
- where\r
- is_compat = co1 `compatible_co` co2\r
- res_co = opt_trans2 co1 co2\r
-\r
-opt_trans_rule_equal_tc _ _ _ = Nothing\r
-\r
--------------\r
-compatible_co :: Coercion -> Coercion -> Bool\r
--- Check whether (co1 . co2) will be well-kinded\r
-compatible_co co1 co2\r
- = x1 `coreEqType` x2 \r
- where\r
- (_,x1) = coercionKind co1\r
- (x2,_) = coercionKind co2\r
-\r
--------------\r
-etaForAll_maybe :: Coercion -> Maybe (TyVar, Coercion)\r
--- Try to make the coercion be of form (forall tv. co)\r
-etaForAll_maybe co\r
- | Just (tv, r) <- splitForAllTy_maybe co\r
- , not (isCoVar tv) -- Check it is a *type* forall, not a (t1~t2)=>co\r
- = Just (tv, r)\r
-\r
- | (ty1,ty2) <- coercionKind co\r
- , Just (tv1, _) <- splitTypeForAll_maybe ty1\r
- , Just (tv2, _) <- splitTypeForAll_maybe ty2\r
- , tyVarKind tv1 `eqKind` tyVarKind tv2\r
- = Just (tv1, mkInstCoercion co (mkTyVarTy tv1))\r
-\r
- | otherwise\r
- = Nothing\r
-\r
-etaCoPred_maybe :: Coercion -> Maybe (Coercion, Coercion, Coercion)\r
-etaCoPred_maybe co \r
- | Just (s,t,r) <- splitCoPredTy_maybe co\r
- = Just (s,t,r)\r
- \r
- -- co :: (s1~t1)=>r1 ~ (s2~t2)=>r2\r
- | (ty1,ty2) <- coercionKind co -- We know ty1,ty2 have same kind\r
- , Just (s1,_,_) <- splitCoPredTy_maybe ty1\r
- , Just (s2,_,_) <- splitCoPredTy_maybe ty2\r
- , typeKind s1 `eqKind` typeKind s2 -- t1,t2 have same kinds\r
- = Just (mkCsel1Coercion co, mkCsel2Coercion co, mkCselRCoercion co)\r
- \r
- | otherwise\r
- = Nothing\r
-\r
-etaApp_maybe :: Coercion -> Maybe (Coercion, Coercion)\r
--- Split a coercion g :: t1a t1b ~ t2a t2b\r
--- into (left g, right g) if possible\r
-etaApp_maybe co\r
- | Just (co1, co2) <- splitAppTy_maybe co\r
- = Just (co1, co2)\r
-\r
- | (ty1,ty2) <- coercionKind co\r
- , Just (ty1a, _) <- splitAppTy_maybe ty1\r
- , Just (ty2a, _) <- splitAppTy_maybe ty2\r
- , typeKind ty1a `eqKind` typeKind ty2a\r
- = Just (mkLeftCoercion co, mkRightCoercion co)\r
-\r
- | otherwise\r
- = Nothing\r
-\r
--------------\r
-splitTypeForAll_maybe :: Type -> Maybe (TyVar, Type)\r
--- Returns Just only for a *type* forall, not a (t1~t2)=>co\r
-splitTypeForAll_maybe ty\r
- | Just (tv, rty) <- splitForAllTy_maybe ty\r
- , not (isCoVar tv)\r
- = Just (tv, rty)\r
-\r
- | otherwise\r
- = Nothing\r
-\r
--------------\r
-isIdNormCo :: NormalCo -> Bool\r
--- Cheap identity test: look for coercions with no coercion variables at all\r
--- So it'll return False for (sym g `trans` g)\r
-isIdNormCo ty = go ty\r
- where\r
- go (TyVarTy tv) = not (isCoVar tv)\r
- go (AppTy t1 t2) = go t1 && go t2\r
- go (FunTy t1 t2) = go t1 && go t2\r
- go (ForAllTy tv ty) = go (tyVarKind tv) && go ty\r
- go (TyConApp tc tys) = not (isCoercionTyCon tc) && all go tys\r
- go (PredTy (IParam _ ty)) = go ty\r
- go (PredTy (ClassP _ tys)) = all go tys\r
- go (PredTy (EqPred t1 t2)) = go t1 && go t2\r
-\end{code} \r
+%
+% (c) The University of Glasgow 2006
+%
+
+\begin{code}
+module OptCoercion ( optCoercion ) where
+
+#include "HsVersions.h"
+
+import Coercion
+import Type hiding( substTyVarBndr, substTy, extendTvSubst )
+import TyCon
+import Var
+import VarSet
+import VarEnv
+import StaticFlags ( opt_NoOptCoercion )
+import Outputable
+import Pair
+import Maybes( allMaybes )
+import FastString
+\end{code}
+
+%************************************************************************
+%* *
+ Optimising coercions
+%* *
+%************************************************************************
+
+Note [Subtle shadowing in coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Supose we optimising a coercion
+ optCoercion (forall (co_X5:t1~t2). ...co_B1...)
+The co_X5 is a wild-card; the bound variable of a coercion for-all
+should never appear in the body of the forall. Indeed we often
+write it like this
+ optCoercion ( (t1~t2) => ...co_B1... )
+
+Just because it's a wild-card doesn't mean we are free to choose
+whatever variable we like. For example it'd be wrong for optCoercion
+to return
+ forall (co_B1:t1~t2). ...co_B1...
+because now the co_B1 (which is really free) has been captured, and
+subsequent substitutions will go wrong. That's why we can't use
+mkCoPredTy in the ForAll case, where this note appears.
+
+\begin{code}
+optCoercion :: CvSubst -> Coercion -> NormalCo
+-- ^ optCoercion applies a substitution to a coercion,
+-- *and* optimises it to reduce its size
+optCoercion env co
+ | opt_NoOptCoercion = substCo env co
+ | otherwise = opt_co env False co
+
+type NormalCo = Coercion
+ -- Invariants:
+ -- * The substitution has been fully applied
+ -- * For trans coercions (co1 `trans` co2)
+ -- co1 is not a trans, and neither co1 nor co2 is identity
+ -- * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types)
+
+type NormalNonIdCo = NormalCo -- Extra invariant: not the identity
+
+opt_co, opt_co' :: CvSubst
+ -> Bool -- True <=> return (sym co)
+ -> Coercion
+ -> NormalCo
+opt_co = opt_co'
+{-
+opt_co env sym co
+ = pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $
+ co1 `seq`
+ pprTrace "opt_co done }" (ppr co1) $
+ (WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (Pair s1 t1)
+ $$ ppr co1 <+> dcolon <+> pprEqPred (Pair s2 t2) )
+ WARN( not (coreEqCoercion co1 simple_result),
+ (text "env=" <+> ppr env) $$
+ (text "input=" <+> ppr co) $$
+ (text "simple=" <+> ppr simple_result) $$
+ (text "opt=" <+> ppr co1) )
+ co1)
+ where
+ co1 = opt_co' env sym co
+ same_co_kind = s1 `eqType` s2 && t1 `eqType` t2
+ Pair s t = coercionKind (substCo env co)
+ (s1,t1) | sym = (t,s)
+ | otherwise = (s,t)
+ Pair s2 t2 = coercionKind co1
+
+ simple_result | sym = mkSymCo (substCo env co)
+ | otherwise = substCo env co
+-}
+
+opt_co' env _ (Refl ty) = Refl (substTy env ty)
+opt_co' env sym (SymCo co) = opt_co env (not sym) co
+opt_co' env sym (TyConAppCo tc cos) = mkTyConAppCo tc (map (opt_co env sym) cos)
+opt_co' env sym (AppCo co1 co2) = mkAppCo (opt_co env sym co1) (opt_co env sym co2)
+opt_co' env sym (ForAllCo tv co) = case substTyVarBndr env tv of
+ (env', tv') -> mkForAllCo tv' (opt_co env' sym co)
+ -- Use the "mk" functions to check for nested Refls
+
+opt_co' env sym (CoVarCo cv)
+ | Just co <- lookupCoVar env cv
+ = opt_co (zapCvSubstEnv env) sym co
+
+ | Just cv1 <- lookupInScope (getCvInScope env) cv
+ = ASSERT( isCoVar cv1 ) wrapSym sym (CoVarCo cv1)
+ -- cv1 might have a substituted kind!
+
+ | otherwise = WARN( True, ptext (sLit "opt_co: not in scope:") <+> ppr cv $$ ppr env)
+ ASSERT( isCoVar cv )
+ wrapSym sym (CoVarCo cv)
+
+opt_co' env sym (AxiomInstCo con cos)
+ -- Do *not* push sym inside top-level axioms
+ -- e.g. if g is a top-level axiom
+ -- g a : f a ~ a
+ -- then (sym (g ty)) /= g (sym ty) !!
+ = wrapSym sym $ AxiomInstCo con (map (opt_co env False) cos)
+ -- Note that the_co does *not* have sym pushed into it
+
+opt_co' env sym (UnsafeCo ty1 ty2)
+ | ty1' `eqType` ty2' = Refl ty1'
+ | sym = mkUnsafeCo ty2' ty1'
+ | otherwise = mkUnsafeCo ty1' ty2'
+ where
+ ty1' = substTy env ty1
+ ty2' = substTy env ty2
+
+opt_co' env sym (TransCo co1 co2)
+ | sym = opt_trans opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g
+ | otherwise = opt_trans opt_co1 opt_co2
+ where
+ opt_co1 = opt_co env sym co1
+ opt_co2 = opt_co env sym co2
+
+opt_co' env sym (NthCo n co)
+ | TyConAppCo tc cos <- co'
+ , isDecomposableTyCon tc -- Not synonym families
+ = ASSERT( n < length cos )
+ cos !! n
+ | otherwise
+ = NthCo n co'
+ where
+ co' = opt_co env sym co
+
+opt_co' env sym (InstCo co ty)
+ -- See if the first arg is already a forall
+ -- ...then we can just extend the current substitution
+ | Just (tv, co_body) <- splitForAllCo_maybe co
+ = opt_co (extendTvSubst env tv ty') sym co_body
+
+ -- See if it is a forall after optimization
+ | Just (tv, co'_body) <- splitForAllCo_maybe co'
+ = substCoWithTy tv ty' co'_body -- An inefficient one-variable substitution
+
+ | otherwise = InstCo co' ty'
+
+ where
+ co' = opt_co env sym co
+ ty' = substTy env ty
+
+-------------
+opt_transList :: [NormalCo] -> [NormalCo] -> [NormalCo]
+opt_transList = zipWith opt_trans
+
+opt_trans :: NormalCo -> NormalCo -> NormalCo
+opt_trans co1 co2
+ | isReflCo co1 = co2
+ | otherwise = opt_trans1 co1 co2
+
+opt_trans1 :: NormalNonIdCo -> NormalCo -> NormalCo
+-- First arg is not the identity
+opt_trans1 co1 co2
+ | isReflCo co2 = co1
+ | otherwise = opt_trans2 co1 co2
+
+opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo
+-- Neither arg is the identity
+opt_trans2 (TransCo co1a co1b) co2
+ -- Don't know whether the sub-coercions are the identity
+ = opt_trans co1a (opt_trans co1b co2)
+
+opt_trans2 co1 co2
+ | Just co <- opt_trans_rule co1 co2
+ = co
+
+opt_trans2 co1 (TransCo co2a co2b)
+ | Just co1_2a <- opt_trans_rule co1 co2a
+ = if isReflCo co1_2a
+ then co2b
+ else opt_trans1 co1_2a co2b
+
+opt_trans2 co1 co2
+ = mkTransCo co1 co2
+
+------
+-- Optimize coercions with a top-level use of transitivity.
+opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
+
+-- push transitivity down through matching top-level constructors.
+opt_trans_rule in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2)
+ | tc1 == tc2 = fireTransRule "PushTyConApp" in_co1 in_co2 $
+ TyConAppCo tc1 (opt_transList cos1 cos2)
+
+-- push transitivity through matching destructors
+opt_trans_rule in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2)
+ | d1 == d2
+ , co1 `compatible_co` co2
+ = fireTransRule "PushNth" in_co1 in_co2 $
+ mkNthCo d1 (opt_trans co1 co2)
+
+-- Push transitivity inside instantiation
+opt_trans_rule in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)
+ | ty1 `eqType` ty2
+ , co1 `compatible_co` co2
+ = fireTransRule "TrPushInst" in_co1 in_co2 $
+ mkInstCo (opt_trans co1 co2) ty1
+
+-- Push transitivity inside apply
+opt_trans_rule in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
+ = fireTransRule "TrPushApp" in_co1 in_co2 $
+ mkAppCo (opt_trans co1a co2a) (opt_trans co1b co2b)
+
+opt_trans_rule co1@(TyConAppCo tc cos1) co2
+ | Just cos2 <- etaTyConAppCo_maybe tc co2
+ = ASSERT( length cos1 == length cos2 )
+ fireTransRule "EtaCompL" co1 co2 $
+ TyConAppCo tc (zipWith opt_trans cos1 cos2)
+
+opt_trans_rule co1 co2@(TyConAppCo tc cos2)
+ | Just cos1 <- etaTyConAppCo_maybe tc co1
+ = ASSERT( length cos1 == length cos2 )
+ fireTransRule "EtaCompR" co1 co2 $
+ TyConAppCo tc (zipWith opt_trans cos1 cos2)
+
+-- Push transitivity inside forall
+opt_trans_rule co1 co2
+ | Just (tv1,r1) <- splitForAllCo_maybe co1
+ , Just (tv2,r2) <- etaForAllCo_maybe co2
+ , let r2' = substCoWithTy tv2 (mkTyVarTy tv1) r2
+ = fireTransRule "EtaAllL" co1 co2 $
+ mkForAllCo tv1 (opt_trans2 r1 r2')
+
+ | Just (tv2,r2) <- splitForAllCo_maybe co2
+ , Just (tv1,r1) <- etaForAllCo_maybe co1
+ , let r1' = substCoWithTy tv1 (mkTyVarTy tv2) r1
+ = fireTransRule "EtaAllR" co1 co2 $
+ mkForAllCo tv1 (opt_trans2 r1' r2)
+
+-- Push transitivity inside axioms
+opt_trans_rule co1 co2
+
+ -- TrPushAxR/TrPushSymAxR
+ | Just (sym, con, cos1) <- co1_is_axiom_maybe
+ , Just cos2 <- matchAxiom sym con co2
+ = fireTransRule "TrPushAxR" co1 co2 $
+ if sym
+ then SymCo $ AxiomInstCo con (opt_transList (map mkSymCo cos2) cos1)
+ else AxiomInstCo con (opt_transList cos1 cos2)
+
+ -- TrPushAxL/TrPushSymAxL
+ | Just (sym, con, cos2) <- co2_is_axiom_maybe
+ , Just cos1 <- matchAxiom (not sym) con co1
+ = fireTransRule "TrPushAxL" co1 co2 $
+ if sym
+ then SymCo $ AxiomInstCo con (opt_transList cos2 (map mkSymCo cos1))
+ else AxiomInstCo con (opt_transList cos1 cos2)
+
+ -- TrPushAxSym/TrPushSymAx
+ | Just (sym1, con1, cos1) <- co1_is_axiom_maybe
+ , Just (sym2, con2, cos2) <- co2_is_axiom_maybe
+ , con1 == con2
+ , sym1 == not sym2
+ , let qtvs = co_ax_tvs con1
+ lhs = co_ax_lhs con1
+ rhs = co_ax_rhs con1
+ pivot_tvs = exactTyVarsOfType (if sym2 then rhs else lhs)
+ , all (`elemVarSet` pivot_tvs) qtvs
+ = fireTransRule "TrPushAxSym" co1 co2 $
+ if sym2
+ then liftCoSubstWith qtvs (opt_transList cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym
+ else liftCoSubstWith qtvs (opt_transList (map mkSymCo cos1) cos2) rhs -- TrPushSymAx
+ where
+ co1_is_axiom_maybe = isAxiom_maybe co1
+ co2_is_axiom_maybe = isAxiom_maybe co2
+
+opt_trans_rule co1 co2 -- Identity rule
+ | Pair ty1 _ <- coercionKind co1
+ , Pair _ ty2 <- coercionKind co2
+ , ty1 `eqType` ty2
+ = fireTransRule "RedTypeDirRefl" co1 co2 $
+ Refl ty2
+
+opt_trans_rule _ _ = Nothing
+
+fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion
+fireTransRule _rule _co1 _co2 res
+ = -- pprTrace ("Trans rule fired: " ++ _rule) (vcat [ppr _co1, ppr _co2, ppr res]) $
+ Just res
+
+-----------
+wrapSym :: Bool -> Coercion -> Coercion
+wrapSym sym co | sym = SymCo co
+ | otherwise = co
+
+-----------
+isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom, [Coercion])
+isAxiom_maybe (SymCo co)
+ | Just (sym, con, cos) <- isAxiom_maybe co
+ = Just (not sym, con, cos)
+isAxiom_maybe (AxiomInstCo con cos)
+ = Just (False, con, cos)
+isAxiom_maybe _ = Nothing
+
+matchAxiom :: Bool -- True = match LHS, False = match RHS
+ -> CoAxiom -> Coercion -> Maybe [Coercion]
+-- If we succeed in matching, then *all the quantified type variables are bound*
+-- E.g. if tvs = [a,b], lhs/rhs = [b], we'll fail
+matchAxiom sym (CoAxiom { co_ax_tvs = qtvs, co_ax_lhs = lhs, co_ax_rhs = rhs }) co
+ = case liftCoMatch (mkVarSet qtvs) (if sym then lhs else rhs) co of
+ Nothing -> Nothing
+ Just subst -> allMaybes (map (liftCoSubstTyVar subst) qtvs)
+
+-------------
+compatible_co :: Coercion -> Coercion -> Bool
+-- Check whether (co1 . co2) will be well-kinded
+compatible_co co1 co2
+ = x1 `eqType` x2
+ where
+ Pair _ x1 = coercionKind co1
+ Pair x2 _ = coercionKind co2
+
+-------------
+etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion)
+-- Try to make the coercion be of form (forall tv. co)
+etaForAllCo_maybe co
+ | Just (tv, r) <- splitForAllCo_maybe co
+ = Just (tv, r)
+
+ | Pair ty1 ty2 <- coercionKind co
+ , Just (tv1, _) <- splitForAllTy_maybe ty1
+ , Just (tv2, _) <- splitForAllTy_maybe ty2
+ , tyVarKind tv1 `eqKind` tyVarKind tv2
+ = Just (tv1, mkInstCo co (mkTyVarTy tv1))
+
+ | otherwise
+ = Nothing
+
+etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]
+-- If possible, split a coercion
+-- g :: T s1 .. sn ~ T t1 .. tn
+-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ]
+etaTyConAppCo_maybe tc (TyConAppCo tc2 cos2)
+ = ASSERT( tc == tc2 ) Just cos2
+
+etaTyConAppCo_maybe tc co
+ | isDecomposableTyCon tc
+ , Pair ty1 ty2 <- coercionKind co
+ , Just (tc1, tys1) <- splitTyConApp_maybe ty1
+ , Just (tc2, tys2) <- splitTyConApp_maybe ty2
+ , tc1 == tc2
+ , let n = length tys1
+ = ASSERT( tc == tc1 )
+ ASSERT( n == length tys2 )
+ Just (decomposeCo n co)
+ -- NB: n might be <> tyConArity tc
+ -- e.g. data family T a :: * -> *
+ -- g :: T a b ~ T c d
+
+ | otherwise
+ = Nothing
+\end{code}
AlgTyConRhs(..), visibleDataCons,
TyConParent(..), isNoParent,
SynTyConRhs(..),
- CoTyConDesc(..),
+
+ -- ** Coercion axiom constructors
+ CoAxiom(..), coAxiomName, coAxiomArity,
-- ** Constructing TyCons
mkAlgTyCon,
mkTupleTyCon,
mkSynTyCon,
mkSuperKindTyCon,
- mkCoercionTyCon,
mkForeignTyCon,
mkAnyTyCon,
isFunTyCon,
isPrimTyCon,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,
- isSynTyCon, isClosedSynTyCon,
+ isSynTyCon, isClosedSynTyCon,
isSuperKindTyCon, isDecomposableTyCon,
- isCoercionTyCon, isCoercionTyCon_maybe,
isForeignTyCon, isAnyTyCon, tyConHasKind,
isInjectiveTyCon,
isDataTyCon, isProductTyCon, isEnumerationTyCon,
- isNewTyCon, isAbstractTyCon,
+ isNewTyCon, isAbstractTyCon,
isFamilyTyCon, isSynFamilyTyCon, isDataFamilyTyCon,
isUnLiftedTyCon,
isGadtSyntaxTyCon,
isTyConAssoc,
isRecursiveTyCon,
isHiBootTyCon,
- isImplicitTyCon, tyConHasGenerics,
+ isImplicitTyCon,
-- ** Extracting information out of TyCons
tyConName,
tyConParent,
tyConClass_maybe,
tyConFamInst_maybe, tyConFamilyCoercion_maybe,tyConFamInstSig_maybe,
- synTyConDefn, synTyConRhs, synTyConType,
- tyConExtName, -- External name for foreign types
+ synTyConDefn, synTyConRhs, synTyConType,
+ tyConExtName, -- External name for foreign types
algTyConRhs,
newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe,
- tupleTyConBoxity,
+ tupleTyConBoxity, tupleTyConArity,
-- ** Manipulating TyCons
tcExpandTyCon_maybe, coreExpandTyCon_maybe,
makeTyConAbstract,
- newTyConCo_maybe,
+ newTyConCo, newTyConCo_maybe,
-- * Primitive representations of Types
PrimRep(..),
* Reply "yes" to isSynFamilyTyCon, and isFamilyTyCon
-* From the user's point of view (F Int) and Bool are simply
+* From the user's point of view (F Int) and Bool are simply
equivalent types.
* A Haskell 98 type synonym is a degenerate form of a type synonym
TyCon. In turn this means that type and data families can be
treated uniformly.
+* Translation of type family decl:
+ type family F a :: *
+ translates to
+ a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon
+
+* Translation of type instance decl:
+ type instance F [a] = Maybe a
+ translates to
+ A SynTyCon 'R:FList a', whose
+ SynTyConRhs is (SynonymTyCon (Maybe a))
+ TyConParent is (FamInstTyCon F [a] co)
+ where co :: F [a] ~ R:FList a
+ Notice that we introduce a gratuitous vanilla type synonym
+ type R:FList a = Maybe a
+ solely so that type and data families can be treated more
+ uniformly, via a single FamInstTyCon descriptor
+
* In the future we might want to support
* closed type families (esp when we have proper kinds)
* injective type families (allow decomposition)
* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon
+* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon
+
* The user does not see any "equivalent types" as he did with type
synonym families. He just sees constructors with types
T1 :: T Int
--
-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor of kind @*@
--
--- 5) Type coercions! This is because we represent a coercion from @t1@ to @t2@
--- as a 'Type', where that type has kind @t1 ~ t2@. See "Coercion" for more on this
---
-- This data type also encodes a number of primitive, built in type constructors such as those
-- for function and tuple types.
data TyCon
algTcRec :: RecFlag, -- ^ Tells us whether the data type is part
-- of a mutually-recursive group or not
-
- hasGenerics :: Bool, -- ^ Whether generic (in the -XGenerics sense)
- -- to\/from functions are available in the exports
- -- of the data type's source module.
-
+
algTcParent :: TyConParent -- ^ Gives the class or family declaration 'TyCon'
-- for derived 'TyCon's representing class
-- or family instances, respectively.
tyConArity :: Arity,
tyConBoxed :: Boxity,
tyConTyVars :: [TyVar],
- dataCon :: DataCon, -- ^ Corresponding tuple data constructor
- hasGenerics :: Bool
+ dataCon :: DataCon -- ^ Corresponding tuple data constructor
}
-- | Represents type synonyms
-- holds the name of the imported thing
}
- -- | Type coercions, such as @(~)@, @sym@, @trans@, @left@ and @right@.
- -- INVARIANT: Coercion TyCons are always fully applied
- -- But note that a CoTyCon can be *over*-saturated in a type.
- -- E.g. (sym g1) Int will be represented as (TyConApp sym [g1,Int])
- | CoTyCon {
- tyConUnique :: Unique,
- tyConName :: Name,
- tyConArity :: Arity,
- coTcDesc :: CoTyConDesc
- }
-
-- | Any types. Like tuples, this is a potentially-infinite family of TyCons
-- one for each distinct Kind. They have no values at all.
-- Because there are infinitely many of them (like tuples) they are
| AnyTyCon {
tyConUnique :: Unique,
tyConName :: Name,
- tc_kind :: Kind -- Never = *; that is done via PrimTyCon
+ tc_kind :: Kind -- Never = *; that is done via PrimTyCon
-- See Note [Any types] in TysPrim
}
-- shorter than the declared arity of the 'TyCon'.
-- See Note [Newtype eta]
-
- nt_co :: Maybe TyCon -- ^ A 'TyCon' (which is always a 'CoTyCon') that can
- -- have a 'Coercion' extracted from it to create
- -- the @newtype@ from the representation 'Type'.
- --
- -- This field is optional for non-recursive @newtype@s only.
-
- -- See Note [Newtype coercions]
- -- Invariant: arity = #tvs in nt_etad_rhs;
- -- See Note [Newtype eta]
- -- Watch out! If any newtypes become transparent
- -- again check Trac #1072.
+ nt_co :: CoAxiom -- The axiom coercion that creates the @newtype@ from
+ -- the representation 'Type'.
+
+ -- See Note [Newtype coercions]
+ -- Invariant: arity = #tvs in nt_etad_rhs;
+ -- See Note [Newtype eta]
+ -- Watch out! If any newtypes become transparent
+ -- again check Trac #1072.
}
-- | Extract those 'DataCon's that we are able to learn about. Note
-- and Note [Type synonym families]
TyCon -- The family TyCon
[Type] -- Argument types (mentions the tyConTyVars of this TyCon)
- TyCon -- The coercion constructor
+ CoAxiom -- The coercion constructor
-- E.g. data intance T [a] = ...
-- gives a representation tycon:
-- | A type synonym family e.g. @type family F x y :: * -> *@
| SynFamilyTyCon
-
---------------------
-data CoTyConDesc
- = CoSym | CoTrans
- | CoLeft | CoRight
- | CoCsel1 | CoCsel2 | CoCselR
- | CoInst
-
- | CoAxiom -- C tvs : F lhs-tys ~ rhs-ty
- { co_ax_tvs :: [TyVar]
- , co_ax_lhs :: Type
- , co_ax_rhs :: Type }
-
- | CoUnsafe
\end{code}
Note [Enumeration types]
%************************************************************************
%* *
+ Coercion axioms
+%* *
+%************************************************************************
+
+\begin{code}
+-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom.
+data CoAxiom
+ = CoAxiom -- type equality axiom.
+ { co_ax_unique :: Unique -- unique identifier
+ , co_ax_name :: Name -- name for pretty-printing
+ , co_ax_tvs :: [TyVar] -- bound type variables
+ , co_ax_lhs :: Type -- left-hand side of the equality
+ , co_ax_rhs :: Type -- right-hand side of the equality
+ }
+
+coAxiomArity :: CoAxiom -> Arity
+coAxiomArity ax = length (co_ax_tvs ax)
+
+coAxiomName :: CoAxiom -> Name
+coAxiomName = co_ax_name
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{PrimRep}
%* *
%************************************************************************
-> AlgTyConRhs -- ^ Information about dat aconstructors
-> TyConParent
-> RecFlag -- ^ Is the 'TyCon' recursive?
- -> Bool -- ^ Does it have generic functions? See 'hasGenerics'
-> Bool -- ^ Was the 'TyCon' declared with GADT syntax?
-> TyCon
-mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn
+mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn
= AlgTyCon {
tyConName = name,
tyConUnique = nameUnique name,
algTcRhs = rhs,
algTcParent = ASSERT( okParent name parent ) parent,
algTcRec = is_rec,
- algTcGadtSyntax = gadt_syn,
- hasGenerics = gen_info
+ algTcGadtSyntax = gadt_syn
}
-- | Simpler specialization of 'mkAlgTyCon' for classes
mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon
mkClassTyCon name kind tyvars rhs clas is_rec =
- mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False False
+ mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False
mkTupleTyCon :: Name
-> Kind -- ^ Kind of the resulting 'TyCon'
-> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'
-> DataCon
-> Boxity -- ^ Whether the tuple is boxed or unboxed
- -> Bool -- ^ Does it have generic functions? See 'hasGenerics'
-> TyCon
-mkTupleTyCon name kind arity tyvars con boxed gen_info
+mkTupleTyCon name kind arity tyvars con boxed
= TupleTyCon {
tyConUnique = nameUnique name,
tyConName = name,
tyConArity = arity,
tyConBoxed = boxed,
tyConTyVars = tyvars,
- dataCon = con,
- hasGenerics = gen_info
+ dataCon = con
}
-- ^ Foreign-imported (.NET) type constructors are represented
synTcParent = parent
}
--- | Create a coercion 'TyCon'
-mkCoercionTyCon :: Name -> Arity
- -> CoTyConDesc
- -> TyCon
-mkCoercionTyCon name arity desc
- = CoTyCon {
- tyConName = name,
- tyConUnique = nameUnique name,
- tyConArity = arity,
- coTcDesc = desc }
-
mkAnyTyCon :: Name -> Kind -> TyCon
mkAnyTyCon name kind
= AnyTyCon { tyConName = name,
-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it expands
-- into, and (possibly) a coercion from the representation type to the @newtype@.
-- Returns @Nothing@ if this is not possible.
-unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, Maybe TyCon)
+unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom)
unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs,
- algTcRhs = NewTyCon { nt_co = mb_co,
+ algTcRhs = NewTyCon { nt_co = co,
nt_rhs = rhs }})
- = Just (tvs, rhs, mb_co)
+ = Just (tvs, rhs, co)
unwrapNewTyCon_maybe _ = Nothing
isProductTyCon :: TyCon -> Bool
isDecomposableTyCon :: TyCon -> Bool
-- True iff we can decompose (T a b c) into ((T a b) c)
--- Specifically NOT true of synonyms (open and otherwise) and coercions
+-- Specifically NOT true of synonyms (open and otherwise)
isDecomposableTyCon (SynTyCon {}) = False
-isDecomposableTyCon (CoTyCon {}) = False
isDecomposableTyCon _other = True
-- | Is this an algebraic 'TyCon' declared with the GADT syntax?
-- Ultimately we may have injective associated types
-- in which case this test will become more interesting
--
- -- It'd be unusual to call isInjectiveTyCon on a regular H98
+ -- It'd be unusual to call isInjectiveTyCon on a regular H98
-- type synonym, because you should probably have expanded it first
-- But regardless, it's not injective!
tupleTyConBoxity :: TyCon -> Boxity
tupleTyConBoxity tc = tyConBoxed tc
+-- | Extract the arity of the given 'TyCon', if it is a 'TupleTyCon'.
+-- Panics otherwise
+tupleTyConArity :: TyCon -> Arity
+tupleTyConArity tc = tyConArity tc
+
-- | Is this a recursive 'TyCon'?
isRecursiveTyCon :: TyCon -> Bool
isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True
isAnyTyCon (AnyTyCon {}) = True
isAnyTyCon _ = False
--- | Attempt to pull a 'TyCon' apart into the arity and 'coKindFun' of
--- a coercion 'TyCon'. Returns @Nothing@ if the 'TyCon' is not of the
--- appropriate kind
-isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, CoTyConDesc)
-isCoercionTyCon_maybe (CoTyCon {tyConArity = ar, coTcDesc = desc})
- = Just (ar, desc)
-isCoercionTyCon_maybe _ = Nothing
-
--- | Is this a 'TyCon' that represents a coercion?
-isCoercionTyCon :: TyCon -> Bool
-isCoercionTyCon (CoTyCon {}) = True
-isCoercionTyCon _ = False
-
-- | Identifies implicit tycons that, in particular, do not go into interface
-- files (because they are implicitly reconstructed when the interface is
-- read).
\begin{code}
tcExpandTyCon_maybe, coreExpandTyCon_maybe
:: TyCon
- -> [Type] -- ^ Arguments to 'TyCon'
- -> Maybe ([(TyVar,Type)],
+ -> [tyco] -- ^ Arguments to 'TyCon'
+ -> Maybe ([(TyVar,tyco)],
Type,
- [Type]) -- ^ Returns a 'TyVar' substitution, the body type
- -- of the synonym (not yet substituted) and any arguments
- -- remaining from the application
+ [tyco]) -- ^ Returns a 'TyVar' substitution, the body type
+ -- of the synonym (not yet substituted) and any arguments
+ -- remaining from the application
--- ^ Used to create the view the /typechecker/ has on 'TyCon's. We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe'
+-- ^ Used to create the view the /typechecker/ has on 'TyCon's.
+-- We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe'
tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs,
synTcRhs = SynonymTyCon rhs }) tys
= expand tvs rhs tys
---------------
--- ^ Used to create the view /Core/ has on 'TyCon's. We expand not only closed synonyms like 'tcExpandTyCon_maybe',
+-- ^ Used to create the view /Core/ has on 'TyCon's. We expand
+-- not only closed synonyms like 'tcExpandTyCon_maybe',
-- but also non-recursive @newtype@s
-coreExpandTyCon_maybe (AlgTyCon {
- algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs, nt_co = Nothing }}) tys
- = case etad_rhs of -- Don't do this in the pattern match, lest we accidentally
- -- match the etad_rhs of a *recursive* newtype
- (tvs,rhs) -> expand tvs rhs tys
-
coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys
----------------
-expand :: [TyVar] -> Type -- Template
- -> [Type] -- Args
- -> Maybe ([(TyVar,Type)], Type, [Type]) -- Expansion
+expand :: [TyVar] -> Type -- Template
+ -> [a] -- Args
+ -> Maybe ([(TyVar,a)], Type, [a]) -- Expansion
expand tvs rhs tys
= case n_tvs `compare` length tys of
LT -> Just (tvs `zip` tys, rhs, drop n_tvs tys)
EQ -> Just (tvs `zip` tys, rhs, [])
- GT -> Nothing
+ GT -> Nothing
where
n_tvs = length tvs
\end{code}
\begin{code}
--- | Does this 'TyCon' have any generic to\/from functions available? See also 'hasGenerics'
-tyConHasGenerics :: TyCon -> Bool
-tyConHasGenerics (AlgTyCon {hasGenerics = hg}) = hg
-tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg
-tyConHasGenerics _ = False -- Synonyms
tyConKind :: TyCon -> Kind
tyConKind (FunTyCon { tc_kind = k }) = k
tyConHasKind :: TyCon -> Bool
tyConHasKind (SuperKindTyCon {}) = False
-tyConHasKind (CoTyCon {}) = False
tyConHasKind _ = True
-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors
-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to construct something
-- with the @newtype@s type from its representation type (right hand side). If the supplied 'TyCon'
-- is not a @newtype@, returns @Nothing@
-newTyConCo_maybe :: TyCon -> Maybe TyCon
-newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = co
-newTyConCo_maybe _ = Nothing
+newTyConCo_maybe :: TyCon -> Maybe CoAxiom
+newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co
+newTyConCo_maybe _ = Nothing
+
+newTyConCo :: TyCon -> CoAxiom
+newTyConCo tc = case newTyConCo_maybe tc of
+ Just co -> co
+ Nothing -> pprPanic "newTyConCo" (ppr tc)
-- | Find the primitive representation of a 'TyCon'
tyConPrimRep :: TyCon -> PrimRep
tyConParent (SynTyCon {synTcParent = parent}) = parent
tyConParent _ = NoParentTyCon
+----------------------------------------------------------------------------
-- | Is this 'TyCon' that for a family instance, be that for a synonym or an
-- algebraic family instance?
isFamInstTyCon :: TyCon -> Bool
FamInstTyCon {} -> True
_ -> False
-tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], TyCon)
+tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom)
tyConFamInstSig_maybe tc
= case tyConParent tc of
FamInstTyCon f ts co_tc -> Just (f, ts, co_tc)
-- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents
-- a coercion identifying the representation type with the type instance family.
-- Otherwise, return @Nothing@
-tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon
+tyConFamilyCoercion_maybe :: TyCon -> Maybe CoAxiom
tyConFamilyCoercion_maybe tc
= case tyConParent tc of
FamInstTyCon _ _ co -> Just co
instance Uniquable TyCon where
getUnique tc = tyConUnique tc
-instance Outputable CoTyConDesc where
- ppr CoSym = ptext (sLit "SYM")
- ppr CoTrans = ptext (sLit "TRANS")
- ppr CoLeft = ptext (sLit "LEFT")
- ppr CoRight = ptext (sLit "RIGHT")
- ppr CoCsel1 = ptext (sLit "CSEL1")
- ppr CoCsel2 = ptext (sLit "CSEL2")
- ppr CoCselR = ptext (sLit "CSELR")
- ppr CoInst = ptext (sLit "INST")
- ppr CoUnsafe = ptext (sLit "UNSAFE")
- ppr (CoAxiom {}) = ptext (sLit "AXIOM")
-
instance Outputable TyCon where
ppr tc = ppr (getName tc)
toConstr _ = abstractConstr "TyCon"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "TyCon"
+
+-------------------
+instance Eq CoAxiom where
+ a == b = case (a `compare` b) of { EQ -> True; _ -> False }
+ a /= b = case (a `compare` b) of { EQ -> False; _ -> True }
+
+instance Ord CoAxiom where
+ a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False }
+ a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False }
+ a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True }
+ a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True }
+ compare a b = getUnique a `compare` getUnique b
+
+instance Uniquable CoAxiom where
+ getUnique = co_ax_unique
+
+instance Outputable CoAxiom where
+ ppr = ppr . getName
+
+instance NamedThing CoAxiom where
+ getName = co_ax_name
+
+instance Data.Typeable CoAxiom where
+ typeOf _ = Data.mkTyConApp (Data.mkTyCon "CoAxiom") []
+
+instance Data.Data CoAxiom where
+ -- don't traverse?
+ toConstr _ = abstractConstr "CoAxiom"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "CoAxiom"
\end{code}
-- $type_classification
-- $representation_types
- TyThing(..), Type, PredType(..), ThetaType,
+ TyThing(..), Type, Pred(..), PredType, ThetaType,
+ Var, TyVar, isTyVar,
-- ** Constructing and deconstructing types
mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe,
-- (Type families)
tyFamInsts, predFamInsts,
- -- (Source types)
- mkPredTy, mkPredTys, mkFamilyTyConApp, isEqPred, coVarPred,
+ -- Pred types
+ mkPredTy, mkPredTys, mkFamilyTyConApp,
+ mkDictTy, isDictLikeTy, isClassPred,
+ isEqPred, allPred, mkEqPred,
+ mkClassPred, getClassPredTys, getClassPredTys_maybe,
+ isTyVarClassPred,
+ mkIPPred, isIPPred,
-- ** Common type constructors
funTyCon,
-- ** Predicates on types
- isTyVarTy, isFunTy, isDictTy,
+ isTyVarTy, isFunTy, isPredTy,
+ isDictTy, isEqPredTy, isReflPredTy, splitPredTy_maybe, splitEqPredTy_maybe,
-- (Lifting and boxity)
isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType,
-- ** Common Kinds and SuperKinds
liftedTypeKind, unliftedTypeKind, openTypeKind,
argTypeKind, ubxTupleKind,
-
- tySuperKind, coSuperKind,
+ tySuperKind,
-- ** Common Kind type constructors
liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
-- * Type free variables
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
- expandTypeSynonyms,
+ exactTyVarsOfType, exactTyVarsOfTypes, expandTypeSynonyms,
typeSize,
-- * Type comparison
- coreEqType, coreEqType2,
- tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
- tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred,
+ eqType, eqTypeX, eqTypes, cmpType, cmpTypes,
+ eqPred, eqPredX, cmpPred, eqKind,
-- * Forcing evaluation of types
- seqType, seqTypes,
+ seqType, seqTypes, seqPred,
-- * Other views onto Types
- coreView, tcView, kindView,
+ coreView, tcView,
repType,
emptyTvSubstEnv, emptyTvSubst,
mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
- getTvSubstEnv, setTvSubstEnv, zapTvSubstEnv, getTvInScope,
+ getTvSubstEnv, setTvSubstEnv,
+ zapTvSubstEnv, getTvInScope,
extendTvInScope, extendTvInScopeList,
- extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv,
+ extendTvSubst, extendTvSubstList,
+ isInScope, composeTvSubst, zipTyEnv,
isEmptyTvSubst, unionTvSubst,
-- ** Performing substitution on types
substTy, substTys, substTyWith, substTysWith, substTheta,
- substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar,
+ substPred, substTyVar, substTyVars, substTyVarBndr,
+ deShadowTy, lookupTyVar,
-- * Pretty-printing
pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll,
- pprPred, pprEqPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind,
+ pprPred, pprPredTy, pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred,
+ pprKind, pprParendKind,
pprSourceTyCon
) where
import Class
import TyCon
+import TysPrim
-- others
+import BasicTypes ( IPName )
+import Name ( Name )
import StaticFlags
import Util
import Outputable
-- its underlying representation type.
-- Returns Nothing if there is nothing to look through.
--
--- In the case of @newtype@s, it returns one of:
---
--- 1) A vanilla 'TyConApp' (recursive newtype, or non-saturated)
---
--- 2) The newtype representation (otherwise), meaning the
--- type written in the RHS of the newtype declaration,
--- which may itself be a newtype
---
--- For example, with:
---
--- > newtype R = MkR S
--- > newtype S = MkS T
--- > newtype T = MkT (T -> T)
---
--- 'expandNewTcApp' on:
---
--- * @R@ gives @Just S@
--- * @S@ gives @Just T@
--- * @T@ gives @Nothing@ (no expansion)
-
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
-coreView (PredTy p)
- | isEqPred p = Nothing
- | otherwise = Just (predTypeRep p)
+coreView (PredTy p) = Just (predTypeRep p)
coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys
= Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
-- Its important to use mkAppTys, rather than (foldl AppTy),
coreView _ = Nothing
-
-----------------------------------------------
{-# INLINE tcView #-}
tcView :: Type -> Maybe Type
go_pred (ClassP c ts) = ClassP c (map go ts)
go_pred (IParam ip t) = IParam ip (go t)
go_pred (EqPred t1 t2) = EqPred (go t1) (go t2)
-
------------------------------------------------
-{-# INLINE kindView #-}
-kindView :: Kind -> Maybe Kind
--- ^ Similar to 'coreView' or 'tcView', but works on 'Kind's
-
--- For the moment, we don't even handle synonyms in kinds
-kindView _ = Nothing
\end{code}
TyVarTy
~~~~~~~
\begin{code}
-mkTyVarTy :: TyVar -> Type
-mkTyVarTy = TyVarTy
-
-mkTyVarTys :: [TyVar] -> [Type]
-mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
-
-- | Attempts to obtain the type variable underlying a 'Type', and panics with the
-- given message if this is not a type variable type. See also 'getTyVar_maybe'
getTyVar :: String -> Type -> TyVar
repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
repSplitAppTy_maybe (TyConApp tc tys)
- | isDecomposableTyCon tc || length tys > tyConArity tc
- = case snocView tys of -- never create unsaturated type family apps
- Just (tys', ty') -> Just (TyConApp tc tys', ty')
- Nothing -> Nothing
+ | isDecomposableTyCon tc || tys `lengthExceeds` tyConArity tc
+ , Just (tys', ty') <- snocView tys
+ = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps!
repSplitAppTy_maybe _other = Nothing
-------------
splitAppTy :: Type -> (Type, Type)
\begin{code}
mkFunTy :: Type -> Type -> Type
-- ^ Creates a function type from the given argument and result type
-mkFunTy arg@(PredTy (EqPred {})) res = ForAllTy (mkWildCoVar arg) res
-mkFunTy arg res = FunTy arg res
+mkFunTy arg res = FunTy arg res
mkFunTys :: [Type] -> Type -> Type
mkFunTys tys ty = foldr mkFunTy ty tys
~~~~~~~~
\begin{code}
--- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments.
--- Applies its arguments to the constructor from left to right
-mkTyConApp :: TyCon -> [Type] -> Type
-mkTyConApp tycon tys
- | isFunTyCon tycon, [ty1,ty2] <- tys
- = FunTy ty1 ty2
-
- | otherwise
- = TyConApp tycon tys
-
--- | Create the plain type constructor type which has been applied to no type arguments at all.
-mkTyConTy :: TyCon -> Type
-mkTyConTy tycon = mkTyConApp tycon []
-
-- splitTyConApp "looks through" synonyms, because they don't
-- mean a distinct type, but all other type-constructor applications
-- including functions are returned as Just ..
= go [] ty
where
go :: [TyCon] -> Type -> Type
- go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms
- = go rec_nts ty'
-
- go rec_nts (ForAllTy _ ty) -- Look through foralls
+ go rec_nts (ForAllTy _ ty) -- Look through foralls
= go rec_nts ty
- go rec_nts (TyConApp tc tys) -- Expand newtypes
+ go rec_nts (PredTy p) -- Expand predicates
+ = go rec_nts (predTypeRep p)
+
+ go rec_nts (TyConApp tc tys) -- Expand newtypes and synonyms
+ | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys
+ = go rec_nts (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
+
| Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys
= go rec_nts' ty'
%************************************************************************
%* *
-\subsection{Source types}
+ Pred
%* *
%************************************************************************
-Source types are always lifted.
+Polymorphic functions over Pred
-The key function is predTypeRep which gives the representation of a source type:
+\begin{code}
+allPred :: (a -> Bool) -> Pred a -> Bool
+allPred p (ClassP _ ts) = all p ts
+allPred p (IParam _ t) = p t
+allPred p (EqPred t1 t2) = p t1 && p t2
+
+isClassPred :: Pred a -> Bool
+isClassPred (ClassP {}) = True
+isClassPred _ = False
+
+isEqPred :: Pred a -> Bool
+isEqPred (EqPred {}) = True
+isEqPred _ = False
+
+isIPPred :: Pred a -> Bool
+isIPPred (IParam {}) = True
+isIPPred _ = False
+\end{code}
+
+Make PredTypes
\begin{code}
mkPredTy :: PredType -> Type
mkPredTys :: ThetaType -> [Type]
mkPredTys preds = map PredTy preds
-isEqPred :: PredType -> Bool
-isEqPred (EqPred _ _) = True
-isEqPred _ = False
-
predTypeRep :: PredType -> Type
-- ^ Convert a 'PredType' to its representation type. However, it unwraps
-- only the outermost level; for example, the result might be a newtype application
predTypeRep (IParam _ ty) = ty
predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
- -- Result might be a newtype application, but the consumer will
- -- look through that too if necessary
-predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2))
-
-mkFamilyTyConApp :: TyCon -> [Type] -> Type
--- ^ Given a family instance TyCon and its arg types, return the
--- corresponding family type. E.g:
---
--- > data family T a
--- > data instance T (Maybe b) = MkT b
---
--- Where the instance tycon is :RTL, so:
---
--- > mkFamilyTyConApp :RTL Int = T (Maybe Int)
-mkFamilyTyConApp tc tys
- | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
- , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys
- = mkTyConApp fam_tc (substTys fam_subst fam_tys)
- | otherwise
- = mkTyConApp tc tys
+predTypeRep (EqPred ty1 ty2) = mkTyConApp eqPredPrimTyCon [ty1,ty2]
--- | Pretty prints a 'TyCon', using the family instance in case of a
--- representation tycon. For example:
---
--- > data T [a] = ...
---
--- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'
-pprSourceTyCon :: TyCon -> SDoc
-pprSourceTyCon tycon
- | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
- = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon
- | otherwise
- = ppr tycon
+splitPredTy_maybe :: Type -> Maybe PredType
+-- Returns Just for predicates only
+splitPredTy_maybe ty | Just ty' <- tcView ty = splitPredTy_maybe ty'
+splitPredTy_maybe (PredTy p) = Just p
+splitPredTy_maybe _ = Nothing
-isDictTy :: Type -> Bool
-isDictTy ty = case splitTyConApp_maybe ty of
- Just (tc, _) -> isClassTyCon tc
- Nothing -> False
+isPredTy :: Type -> Bool
+isPredTy ty = isJust (splitPredTy_maybe ty)
\end{code}
+--------------------- Equality types ---------------------------------
+\begin{code}
+isReflPredTy :: Type -> Bool
+isReflPredTy ty = case splitPredTy_maybe ty of
+ Just (EqPred ty1 ty2) -> ty1 `eqType` ty2
+ _ -> False
+
+splitEqPredTy_maybe :: Type -> Maybe (Type,Type)
+splitEqPredTy_maybe ty = case splitPredTy_maybe ty of
+ Just (EqPred ty1 ty2) -> Just (ty1,ty2)
+ _ -> Nothing
+
+isEqPredTy :: Type -> Bool
+isEqPredTy ty = case splitPredTy_maybe ty of
+ Just (EqPred {}) -> True
+ _ -> False
+
+-- | Creates a type equality predicate
+mkEqPred :: (a, a) -> Pred a
+mkEqPred (ty1, ty2) = EqPred ty1 ty2
+\end{code}
-%************************************************************************
-%* *
- The free variables of a type
-%* *
-%************************************************************************
-
+--------------------- Dictionary types ---------------------------------
\begin{code}
-tyVarsOfType :: Type -> TyVarSet
--- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym
-tyVarsOfType (TyVarTy tv) = unitVarSet tv
-tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys
-tyVarsOfType (PredTy sty) = tyVarsOfPred sty
-tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
-tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
-tyVarsOfType (ForAllTy tv ty) -- The kind of a coercion binder
- -- can mention type variables!
- | isTyVar tv = inner_tvs `delVarSet` tv
- | otherwise {- Coercion -} = -- ASSERT( not (tv `elemVarSet` inner_tvs) )
- inner_tvs `unionVarSet` tyVarsOfType (tyVarKind tv)
- where
- inner_tvs = tyVarsOfType ty
+mkClassPred :: Class -> [Type] -> PredType
+mkClassPred clas tys = ClassP clas tys
-tyVarsOfTypes :: [Type] -> TyVarSet
-tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
+isDictTy :: Type -> Bool
+isDictTy ty = case splitPredTy_maybe ty of
+ Just p -> isClassPred p
+ Nothing -> False
+
+isTyVarClassPred :: PredType -> Bool
+isTyVarClassPred (ClassP _ tys) = all isTyVarTy tys
+isTyVarClassPred _ = False
+
+getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
+getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
+getClassPredTys_maybe _ = Nothing
+
+getClassPredTys :: PredType -> (Class, [Type])
+getClassPredTys (ClassP clas tys) = (clas, tys)
+getClassPredTys _ = panic "getClassPredTys"
+
+mkDictTy :: Class -> [Type] -> Type
+mkDictTy clas tys = mkPredTy (ClassP clas tys)
+
+isDictLikeTy :: Type -> Bool
+-- Note [Dictionary-like types]
+isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty'
+isDictLikeTy (PredTy p) = isClassPred p
+isDictLikeTy (TyConApp tc tys)
+ | isTupleTyCon tc = all isDictLikeTy tys
+isDictLikeTy _ = False
+\end{code}
-tyVarsOfPred :: PredType -> TyVarSet
-tyVarsOfPred (IParam _ ty) = tyVarsOfType ty
-tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys
-tyVarsOfPred (EqPred ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+Note [Dictionary-like types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Being "dictionary-like" means either a dictionary type or a tuple thereof.
+In GHC 6.10 we build implication constraints which construct such tuples,
+and if we land up with a binding
+ t :: (C [a], Eq [a])
+ t = blah
+then we want to treat t as cheap under "-fdicts-cheap" for example.
+(Implication constraints are normally inlined, but sadly not if the
+occurrence is itself inside an INLINE function! Until we revise the
+handling of implication constraints, that is.) This turned out to
+be important in getting good arities in DPH code. Example:
+
+ class C a
+ class D a where { foo :: a -> a }
+ instance C a => D (Maybe a) where { foo x = x }
+
+ bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b)
+ {-# INLINE bar #-}
+ bar x y = (foo (Just x), foo (Just y))
+
+Then 'bar' should jolly well have arity 4 (two dicts, two args), but
+we ended up with something like
+ bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ...
+ in \x,y. <blah>)
+
+This is all a bit ad-hoc; eg it relies on knowing that implication
+constraints build tuples.
+
+--------------------- Implicit parameters ---------------------------------
-tyVarsOfTheta :: ThetaType -> TyVarSet
-tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
+\begin{code}
+mkIPPred :: IPName Name -> Type -> PredType
+mkIPPred ip ty = IParam ip ty
\end{code}
-
%************************************************************************
%* *
Size
typeSize (TyVarTy _) = 1
typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2
typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2
-typeSize (PredTy p) = predSize p
+typeSize (PredTy p) = predSize typeSize p
typeSize (ForAllTy _ t) = 1 + typeSize t
typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts)
-
-predSize :: PredType -> Int
-predSize (IParam _ t) = 1 + typeSize t
-predSize (ClassP _ ts) = 1 + sum (map typeSize ts)
-predSize (EqPred t1 t2) = typeSize t1 + typeSize t2
\end{code}
predFamInsts (ClassP _cla tys) = concat (map tyFamInsts tys)
predFamInsts (IParam _ ty) = tyFamInsts ty
predFamInsts (EqPred ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2
-\end{code}
+mkFamilyTyConApp :: TyCon -> [Type] -> Type
+-- ^ Given a family instance TyCon and its arg types, return the
+-- corresponding family type. E.g:
+--
+-- > data family T a
+-- > data instance T (Maybe b) = MkT b
+--
+-- Where the instance tycon is :RTL, so:
+--
+-- > mkFamilyTyConApp :RTL Int = T (Maybe Int)
+mkFamilyTyConApp tc tys
+ | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
+ , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys
+ = mkTyConApp fam_tc (substTys fam_subst fam_tys)
+ | otherwise
+ = mkTyConApp tc tys
+
+-- | Pretty prints a 'TyCon', using the family instance in case of a
+-- representation tycon. For example:
+--
+-- > data T [a] = ...
+--
+-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'
+pprSourceTyCon :: TyCon -> SDoc
+pprSourceTyCon tycon
+ | Just (fam_tc, tys) <- tyConFamInst_maybe tycon
+ = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon
+ | otherwise
+ = ppr tycon
+\end{code}
%************************************************************************
%* *
isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty'
isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty
+isUnLiftedType (PredTy p) = isEqPred p
isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc
isUnLiftedType _ = False
isClosedAlgType :: Type -> Bool
isClosedAlgType ty
= case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
- isAlgTyCon tc && not (isFamilyTyCon tc)
- _other -> False
+ Just (tc, ty_args) | isAlgTyCon tc && not (isFamilyTyCon tc)
+ -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True
+ _other -> False
\end{code}
\begin{code}
-- poking the dictionary component, which is wrong.)
isStrictPred :: PredType -> Bool
isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas))
-isStrictPred _ = False
+isStrictPred (EqPred {}) = True
+isStrictPred (IParam {}) = False
\end{code}
\begin{code}
%************************************************************************
%* *
+ The "exact" free variables of a type
+%* *
+%************************************************************************
+
+Note [Silly type synonym]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ type T a = Int
+What are the free tyvars of (T x)? Empty, of course!
+Here's the example that Ralf Laemmel showed me:
+ foo :: (forall a. C u a -> C u a) -> u
+ mappend :: Monoid u => u -> u -> u
+
+ bar :: Monoid u => u
+ bar = foo (\t -> t `mappend` t)
+We have to generalise at the arg to f, and we don't
+want to capture the constraint (Monad (C u a)) because
+it appears to mention a. Pretty silly, but it was useful to him.
+
+exactTyVarsOfType is used by the type checker to figure out exactly
+which type variables are mentioned in a type. It's also used in the
+smart-app checking code --- see TcExpr.tcIdApp
+
+On the other hand, consider a *top-level* definition
+ f = (\x -> x) :: T a -> T a
+If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then
+if we have an application like (f "x") we get a confusing error message
+involving Any. So the conclusion is this: when generalising
+ - at top level use tyVarsOfType
+ - in nested bindings use exactTyVarsOfType
+See Trac #1813 for example.
+
+\begin{code}
+exactTyVarsOfType :: Type -> TyVarSet
+-- Find the free type variables (of any kind)
+-- but *expand* type synonyms. See Note [Silly type synonym] above.
+exactTyVarsOfType ty
+ = go ty
+ where
+ go ty | Just ty' <- tcView ty = go ty' -- This is the key line
+ go (TyVarTy tv) = unitVarSet tv
+ go (TyConApp _ tys) = exactTyVarsOfTypes tys
+ go (PredTy ty) = go_pred ty
+ go (FunTy arg res) = go arg `unionVarSet` go res
+ go (AppTy fun arg) = go fun `unionVarSet` go arg
+ go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
+
+ go_pred (IParam _ ty) = go ty
+ go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
+ go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2
+
+exactTyVarsOfTypes :: [Type] -> TyVarSet
+exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Sequencing on types}
%* *
%************************************************************************
seqType (TyVarTy tv) = tv `seq` ()
seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
-seqType (PredTy p) = seqPred p
+seqType (PredTy p) = seqPred seqType p
seqType (TyConApp tc tys) = tc `seq` seqTypes tys
seqType (ForAllTy tv ty) = tv `seq` seqType ty
seqTypes [] = ()
seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
-seqPred :: PredType -> ()
-seqPred (ClassP c tys) = c `seq` seqTypes tys
-seqPred (IParam n ty) = n `seq` seqType ty
-seqPred (EqPred ty1 ty2) = seqType ty1 `seq` seqType ty2
+seqPred :: (a -> ()) -> Pred a -> ()
+seqPred seqt (ClassP c tys) = c `seq` foldr (seq . seqt) () tys
+seqPred seqt (IParam n ty) = n `seq` seqt ty
+seqPred seqt (EqPred ty1 ty2) = seqt ty1 `seq` seqt ty2
\end{code}
%************************************************************************
%* *
- Equality for Core types
+ Comparision for types
(We don't use instances so that we know where it happens)
%* *
%************************************************************************
-Note that eqType works right even for partial applications of newtypes.
-See Note [Newtype eta] in TyCon.lhs
-
\begin{code}
--- | Type equality test for Core types (i.e. ignores predicate-types, synonyms etc.)
-coreEqType :: Type -> Type -> Bool
-coreEqType t1 t2 = coreEqType2 rn_env t1 t2
- where
- rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2))
-
-coreEqType2 :: RnEnv2 -> Type -> Type -> Bool
-coreEqType2 rn_env t1 t2
- = eq rn_env t1 t2
- where
- eq env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2
- eq env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = eq (rnBndr2 env tv1 tv2) t1 t2
- eq env (AppTy s1 t1) (AppTy s2 t2) = eq env s1 s2 && eq env t1 t2
- eq env (FunTy s1 t1) (FunTy s2 t2) = eq env s1 s2 && eq env t1 t2
- eq env (TyConApp tc1 tys1) (TyConApp tc2 tys2)
- | tc1 == tc2, all2 (eq env) tys1 tys2 = True
- -- The lengths should be equal because
- -- the two types have the same kind
- -- NB: if the type constructors differ that does not
- -- necessarily mean that the types aren't equal
- -- (synonyms, newtypes)
- -- Even if the type constructors are the same, but the arguments
- -- differ, the two types could be the same (e.g. if the arg is just
- -- ignored in the RHS). In both these cases we fall through to an
- -- attempt to expand one side or the other.
-
- -- Now deal with newtypes, synonyms, pred-tys
- eq env t1 t2 | Just t1' <- coreView t1 = eq env t1' t2
- | Just t2' <- coreView t2 = eq env t1 t2'
-
- -- Fall through case; not equal!
- eq _ _ _ = False
-\end{code}
-
+eqKind :: Kind -> Kind -> Bool
+eqKind = eqType
-%************************************************************************
-%* *
- Comparision for source types
- (We don't use instances so that we know where it happens)
-%* *
-%************************************************************************
-
-\begin{code}
-tcEqType :: Type -> Type -> Bool
+eqType :: Type -> Type -> Bool
-- ^ Type equality on source types. Does not look through @newtypes@ or
-- 'PredType's, but it does look through type synonyms.
-tcEqType t1 t2 = isEqual $ cmpType t1 t2
-
-tcEqTypes :: [Type] -> [Type] -> Bool
-tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
-
-tcCmpType :: Type -> Type -> Ordering
--- ^ Type ordering on source types. Does not look through @newtypes@ or
--- 'PredType's, but it does look through type synonyms.
-tcCmpType t1 t2 = cmpType t1 t2
+eqType t1 t2 = isEqual $ cmpType t1 t2
-tcCmpTypes :: [Type] -> [Type] -> Ordering
-tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2
+eqTypeX :: RnEnv2 -> Type -> Type -> Bool
+eqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2
-tcEqPred :: PredType -> PredType -> Bool
-tcEqPred p1 p2 = isEqual $ cmpPred p1 p2
+eqTypes :: [Type] -> [Type] -> Bool
+eqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
-tcEqPredX :: RnEnv2 -> PredType -> PredType -> Bool
-tcEqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2
+eqPred :: PredType -> PredType -> Bool
+eqPred p1 p2 = isEqual $ cmpPred p1 p2
-tcCmpPred :: PredType -> PredType -> Ordering
-tcCmpPred p1 p2 = cmpPred p1 p2
-
-tcEqTypeX :: RnEnv2 -> Type -> Type -> Bool
-tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2
-\end{code}
-
-\begin{code}
--- | Checks whether the second argument is a subterm of the first. (We don't care
--- about binders, as we are only interested in syntactic subterms.)
-tcPartOfType :: Type -> Type -> Bool
-tcPartOfType t1 t2
- | tcEqType t1 t2 = True
-tcPartOfType t1 t2
- | Just t2' <- tcView t2 = tcPartOfType t1 t2'
-tcPartOfType _ (TyVarTy _) = False
-tcPartOfType t1 (ForAllTy _ t2) = tcPartOfType t1 t2
-tcPartOfType t1 (AppTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
-tcPartOfType t1 (FunTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
-tcPartOfType t1 (PredTy p2) = tcPartOfPred t1 p2
-tcPartOfType t1 (TyConApp _ ts) = any (tcPartOfType t1) ts
-
-tcPartOfPred :: Type -> PredType -> Bool
-tcPartOfPred t1 (IParam _ t2) = tcPartOfType t1 t2
-tcPartOfPred t1 (ClassP _ ts) = any (tcPartOfType t1) ts
-tcPartOfPred t1 (EqPred s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
+eqPredX :: RnEnv2 -> PredType -> PredType -> Bool
+eqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2
\end{code}
Now here comes the real worker
rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfPred p1 `unionVarSet` tyVarsOfPred p2))
cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse
-cmpTypeX env t1 t2 | Just t1' <- tcView t1 = cmpTypeX env t1' t2
- | Just t2' <- tcView t2 = cmpTypeX env t1 t2'
+cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2
+ | Just t2' <- coreView t2 = cmpTypeX env t1 t2'
+-- We expand predicate types, because in Core-land we have
+-- lots of definitions like
+-- fOrdBool :: Ord Bool
+-- fOrdBool = D:Ord .. .. ..
+-- So the RHS has a data type
cmpTypeX env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 `compare` rnOccR env tv2
cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX (rnBndr2 env tv1 tv2) t1 t2
so we take the easy path and make them an instance of Ord
\begin{code}
-instance Eq PredType where { (==) = tcEqPred }
-instance Ord PredType where { compare = tcCmpPred }
+instance Eq PredType where { (==) = eqPred }
+instance Ord PredType where { compare = cmpPred }
\end{code}
%************************************************************************
\begin{code}
--- | Type substitution
---
--- #tvsubst_invariant#
--- The following invariants must hold of a 'TvSubst':
---
--- 1. The in-scope set is needed /only/ to
--- guide the generation of fresh uniques
---
--- 2. In particular, the /kind/ of the type variables in
--- the in-scope set is not relevant
---
--- 3. The substition is only applied ONCE! This is because
--- in general such application will not reached a fixed point.
-data TvSubst
- = TvSubst InScopeSet -- The in-scope type variables
- TvSubstEnv -- The substitution itself
- -- See Note [Apply Once]
- -- and Note [Extending the TvSubstEnv]
-
-{- ----------------------------------------------------------
-
-Note [Apply Once]
-~~~~~~~~~~~~~~~~~
-We use TvSubsts to instantiate things, and we might instantiate
- forall a b. ty
-\with the types
- [a, b], or [b, a].
-So the substition might go [a->b, b->a]. A similar situation arises in Core
-when we find a beta redex like
- (/\ a /\ b -> e) b a
-Then we also end up with a substition that permutes type variables. Other
-variations happen to; for example [a -> (a, b)].
-
- ***************************************************
- *** So a TvSubst must be applied precisely once ***
- ***************************************************
-
-A TvSubst is not idempotent, but, unlike the non-idempotent substitution
-we use during unifications, it must not be repeatedly applied.
-
-Note [Extending the TvSubst]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #tvsubst_invariant# for the invariants that must hold.
-
-This invariant allows a short-cut when the TvSubstEnv is empty:
-if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds ---
-then (substTy subst ty) does nothing.
-
-For example, consider:
- (/\a. /\b:(a~Int). ...b..) Int
-We substitute Int for 'a'. The Unique of 'b' does not change, but
-nevertheless we add 'b' to the TvSubstEnv, because b's kind does change
-
-This invariant has several crucial consequences:
-
-* In substTyVarBndr, we need extend the TvSubstEnv
- - if the unique has changed
- - or if the kind has changed
-
-* In substTyVar, we do not need to consult the in-scope set;
- the TvSubstEnv is enough
-
-* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty
-
-
--------------------------------------------------------------- -}
-
--- | A substitition of 'Type's for 'TyVar's
-type TvSubstEnv = TyVarEnv Type
- -- A TvSubstEnv is used both inside a TvSubst (with the apply-once
- -- invariant discussed in Note [Apply Once]), and also independently
- -- in the middle of matching, and unification (see Types.Unify)
- -- So you have to look at the context to know if it's idempotent or
- -- apply-once or whatever
-
emptyTvSubstEnv :: TvSubstEnv
emptyTvSubstEnv = emptyVarEnv
subst1 = TvSubst in_scope env1
emptyTvSubst :: TvSubst
-emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv
+emptyTvSubst = TvSubst emptyInScopeSet emptyTvSubstEnv
isEmptyTvSubst :: TvSubst -> Bool
-- See Note [Extending the TvSubstEnv]
-isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env
+isEmptyTvSubst (TvSubst _ tenv) = isEmptyVarEnv tenv
mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst
mkTvSubst = TvSubst
isInScope :: Var -> TvSubst -> Bool
isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope
-notElemTvSubst :: TyVar -> TvSubst -> Bool
-notElemTvSubst tv (TvSubst _ env) = not (tv `elemVarEnv` env)
+notElemTvSubst :: TyCoVar -> TvSubst -> Bool
+notElemTvSubst v (TvSubst _ tenv) = not (v `elemVarEnv` tenv)
setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst
-setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env
+setTvSubstEnv (TvSubst in_scope _) tenv = TvSubst in_scope tenv
zapTvSubstEnv :: TvSubst -> TvSubst
zapTvSubstEnv (TvSubst in_scope _) = TvSubst in_scope emptyVarEnv
extendTvInScope :: TvSubst -> Var -> TvSubst
-extendTvInScope (TvSubst in_scope env) var = TvSubst (extendInScopeSet in_scope var) env
+extendTvInScope (TvSubst in_scope tenv) var = TvSubst (extendInScopeSet in_scope var) tenv
extendTvInScopeList :: TvSubst -> [Var] -> TvSubst
-extendTvInScopeList (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env
+extendTvInScopeList (TvSubst in_scope tenv) vars = TvSubst (extendInScopeSetList in_scope vars) tenv
extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst
-extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty)
+extendTvSubst (TvSubst in_scope tenv) tv ty = TvSubst in_scope (extendVarEnv tenv tv ty)
extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst
-extendTvSubstList (TvSubst in_scope env) tvs tys
- = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys))
+extendTvSubstList (TvSubst in_scope tenv) tvs tys
+ = TvSubst in_scope (extendVarEnvList tenv (tvs `zip` tys))
unionTvSubst :: TvSubst -> TvSubst -> TvSubst
-- Works when the ranges are disjoint
-unionTvSubst (TvSubst in_scope1 env1) (TvSubst in_scope2 env2)
- = ASSERT( not (env1 `intersectsVarEnv` env2) )
+unionTvSubst (TvSubst in_scope1 tenv1) (TvSubst in_scope2 tenv2)
+ = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) )
TvSubst (in_scope1 `unionInScope` in_scope2)
- (env1 `plusVarEnv` env2)
+ (tenv1 `plusVarEnv` tenv2)
-- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from
-- the types given; but it's just a thunk so with a bit of luck
-- | Generates the in-scope set for the 'TvSubst' from the types in the incoming
-- environment, hence "open"
mkOpenTvSubst :: TvSubstEnv -> TvSubst
-mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env
+mkOpenTvSubst tenv = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts tenv))) tenv
-- | Generates the in-scope set for the 'TvSubst' from the types in the incoming
-- environment, hence "open"
zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv tyvars tys
| debugIsOn && (length tyvars /= length tys)
- = pprTrace "mkTopTvSubst" (ppr tyvars $$ ppr tys) emptyVarEnv
+ = pprTrace "zipTyEnv" (ppr tyvars $$ ppr tys) emptyVarEnv
| otherwise
= zip_ty_env tyvars tys emptyVarEnv
-- zip_ty_env _ _ env = env
instance Outputable TvSubst where
- ppr (TvSubst ins env)
+ ppr (TvSubst ins tenv)
= brackets $ sep[ ptext (sLit "TvSubst"),
nest 2 (ptext (sLit "In scope:") <+> ppr ins),
- nest 2 (ptext (sLit "Env:") <+> ppr env) ]
+ nest 2 (ptext (sLit "Type env:") <+> ppr tenv) ]
\end{code}
%************************************************************************
ForAllTy tv' $! (subst_ty subst' ty)
substTyVar :: TvSubst -> TyVar -> Type
-substTyVar subst@(TvSubst _ _) tv
- = case lookupTyVar subst tv of {
- Nothing -> TyVarTy tv;
- Just ty -> ty -- See Note [Apply Once]
- }
+substTyVar (TvSubst _ tenv) tv
+ | Just ty <- lookupVarEnv tenv tv = ty -- See Note [Apply Once]
+ | otherwise = ASSERT( isTyVar tv ) TyVarTy tv
+ -- We do not require that the tyvar is in scope
+ -- Reason: we do quite a bit of (substTyWith [tv] [ty] tau)
+ -- and it's a nuisance to bring all the free vars of tau into
+ -- scope --- and then force that thunk at every tyvar
+ -- Instead we have an ASSERT in substTyVarBndr to check for capture
substTyVars :: TvSubst -> [TyVar] -> [Type]
substTyVars subst tvs = map (substTyVar subst) tvs
lookupTyVar :: TvSubst -> TyVar -> Maybe Type
-- See Note [Extending the TvSubst]
-lookupTyVar (TvSubst _ env) tv = lookupVarEnv env tv
+lookupTyVar (TvSubst _ tenv) tv = lookupVarEnv tenv tv
-substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar)
-substTyVarBndr subst@(TvSubst in_scope env) old_var
- = (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var)
+substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar)
+substTyVarBndr subst@(TvSubst in_scope tenv) old_var
+ = ASSERT2( _no_capture, ppr old_var $$ ppr subst )
+ (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var)
where
- is_co_var = isCoVar old_var
+ new_env | no_change = delVarEnv tenv old_var
+ | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)
- new_env | no_change = delVarEnv env old_var
- | otherwise = extendVarEnv env old_var (TyVarTy new_var)
+ _no_capture = not (new_var `elemVarSet` tyVarsOfTypes (varEnvElts tenv))
+ -- Check that we are not capturing something in the substitution
- no_change = new_var == old_var && not is_co_var
+ no_change = new_var == old_var
-- no_change means that the new_var is identical in
-- all respects to the old_var (same unique, same kind)
-- See Note [Extending the TvSubst]
-- (\x.e) with id_subst = [x |-> e']
-- Here we must simply zap the substitution for x
- new_var = uniqAway in_scope subst_old_var
+ new_var = uniqAway in_scope old_var
-- The uniqAway part makes sure the new variable is not already in scope
-
- subst_old_var -- subst_old_var is old_var with the substitution applied to its kind
- -- It's only worth doing the substitution for coercions,
- -- becuase only they can have free type variables
- | is_co_var = setTyVarKind old_var (substTy subst (tyVarKind old_var))
- | otherwise = old_var
\end{code}
----------------------------------------------------
\begin{code}
-- We expose the relevant stuff from this module via the Type module
{-# OPTIONS_HADDOCK hide #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
module TypeRep (
TyThing(..),
Type(..),
- PredType(..), -- to friends
+ Pred(..), -- to friends
- Kind, ThetaType, -- Synonyms
+ Kind, SuperKind,
+ PredType, ThetaType, -- Synonyms
- funTyCon, funTyConName,
+ -- Functions over types
+ mkTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys,
+ isLiftedTypeKind, isCoercionKind,
- -- Pretty-printing
+ -- Pretty-printing
pprType, pprParendType, pprTypeApp,
pprTyThing, pprTyThingCategory,
- pprPred, pprEqPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
-
- -- Kinds
- liftedTypeKind, unliftedTypeKind, openTypeKind,
- argTypeKind, ubxTupleKind, ecKind,
- isLiftedTypeKindCon, isLiftedTypeKind,
- mkArrowKind, mkArrowKinds, isCoercionKind,
- coVarPred,
-
- -- Kind constructors...
- liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
- argTypeKindTyCon, ubxTupleKindTyCon,
-
- -- And their names
- unliftedTypeKindTyConName, openTypeKindTyConName,
- ubxTupleKindTyConName, argTypeKindTyConName,
- liftedTypeKindTyConName,
-
- -- Super Kinds
- tySuperKind, coSuperKind,
- isTySuperKind, isCoSuperKind,
- tySuperKindTyCon, coSuperKindTyCon,
-
- pprKind, pprParendKind
+ pprPredTy, pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred,
+ pprKind, pprParendKind,
+ Prec(..), maybeParen, pprTcApp, pprTypeNameApp,
+ pprPrefixApp, pprPred, pprArrowChain, pprThetaArrow,
+
+ -- Free variables
+ tyVarsOfType, tyVarsOfTypes,
+ tyVarsOfPred, tyVarsOfTheta,
+ varsOfPred, varsOfTheta,
+ predSize,
+
+ -- Substitutions
+ TvSubst(..), TvSubstEnv
) where
#include "HsVersions.h"
-- friends:
import Var
+import VarEnv
+import VarSet
import Name
import BasicTypes
import TyCon
import PrelNames
import Outputable
import FastString
+import Pair
-- libraries
-import Data.Data hiding ( TyCon )
+import qualified Data.Data as Data hiding ( TyCon )
+import qualified Data.Foldable as Data
+import qualified Data.Traversable as Data
\end{code}
----------------------
\begin{code}
-- | The key representation of types within the compiler
data Type
- = TyVarTy TyVar -- ^ Vanilla type variable
+ = TyVarTy TyVar -- ^ Vanilla type variable (*never* a coercion variable)
| AppTy
Type
Type -- ^ Type application to something other than a 'TyCon'. Parameters:
--
- -- 1) Function: must /not/ be a 'TyConApp', must be another 'AppTy', or 'TyVarTy'
+ -- 1) Function: must /not/ be a 'TyConApp',
+ -- must be another 'AppTy', or 'TyVarTy'
--
-- 2) Argument type
[Type] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms.
-- Invariant: saturated appliations of 'FunTyCon' must
-- use 'FunTy' and saturated synonyms must use their own
- -- constructors. However, /unsaturated/ 'FunTyCon's do appear as 'TyConApp's.
+ -- constructors. However, /unsaturated/ 'FunTyCon's
+ -- do appear as 'TyConApp's.
-- Parameters:
--
-- 1) Type constructor being applied to.
--
- -- 2) Type arguments. Might not have enough type arguments here to saturate the constructor.
- -- Even type synonyms are not necessarily saturated; for example unsaturated type synonyms
- -- can appear as the right hand side of a type synonym.
+ -- 2) Type arguments. Might not have enough type arguments
+ -- here to saturate the constructor.
+ -- Even type synonyms are not necessarily saturated;
+ -- for example unsaturated type synonyms
+ -- can appear as the right hand side of a type synonym.
| FunTy
- Type
+ Type
Type -- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@
+ -- See Note [Equality-constrained types]
| ForAllTy
- TyVar
+ TyCoVar -- Type variable
Type -- ^ A polymorphic type
| PredTy
PredType -- ^ The type of evidence for a type predictate.
-- Note that a @PredTy (EqPred _ _)@ can appear only as the kind
- -- of a coercion variable; never as the argument or result
- -- of a 'FunTy' (unlike the 'PredType' constructors 'ClassP' or 'IParam')
+ -- of a coercion variable; never as the argument or result of a
+ -- 'FunTy' (unlike the 'PredType' constructors 'ClassP' or 'IParam')
-- See Note [PredTy], and Note [Equality predicates]
- deriving (Data, Typeable)
+ deriving (Data.Data, Data.Typeable)
-- | The key type representing kinds in the compiler.
-- Invariant: a kind is always in one of these forms:
type SuperKind = Type
\end{code}
+Note [Equality-constrained types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The type forall ab. (a ~ [b]) => blah
+is encoded like this:
+
+ ForAllTy (a:*) $ ForAllTy (b:*) $
+ FunTy (PredTy (EqPred a [b]) $
+ blah
+
-------------------------------------
Note [PredTy]
-- > h :: (r\l) => {r} => {l::Int | r}
--
-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\"
-data PredType
- = ClassP Class [Type] -- ^ Class predicate e.g. @Eq a@
- | IParam (IPName Name) Type -- ^ Implicit parameter e.g. @?x :: Int@
- | EqPred Type Type -- ^ Equality predicate e.g @ty1 ~ ty2@
- deriving (Data, Typeable)
+type PredType = Pred Type
+
+data Pred a -- Typically 'a' is instantiated with Type or Coercion
+ = ClassP Class [a] -- ^ Class predicate e.g. @Eq a@
+ | IParam (IPName Name) a -- ^ Implicit parameter e.g. @?x :: Int@
+ | EqPred a a -- ^ Equality predicate e.g @ty1 ~ ty2@
+ deriving (Data.Data, Data.Typeable, Data.Foldable, Data.Traversable, Functor)
-- | A collection of 'PredType's
type ThetaType = [PredType]
%************************************************************************
%* *
+ Simple constructors
+%* *
+%************************************************************************
+
+These functions are here so that they can be used by TysPrim,
+which in turn is imported by Type
+
+\begin{code}
+mkTyVarTy :: TyVar -> Type
+mkTyVarTy = TyVarTy
+
+mkTyVarTys :: [TyVar] -> [Type]
+mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
+
+-- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments.
+-- Applies its arguments to the constructor from left to right
+mkTyConApp :: TyCon -> [Type] -> Type
+mkTyConApp tycon tys
+ | isFunTyCon tycon, [ty1,ty2] <- tys
+ = FunTy ty1 ty2
+
+ | otherwise
+ = TyConApp tycon tys
+
+-- | Create the plain type constructor type which has been applied to no type arguments at all.
+mkTyConTy :: TyCon -> Type
+mkTyConTy tycon = mkTyConApp tycon []
+
+isLiftedTypeKind :: Kind -> Bool
+-- This function is here because it's used in the pretty printer
+isLiftedTypeKind (TyConApp tc []) = tc `hasKey` liftedTypeKindTyConKey
+isLiftedTypeKind _ = False
+
+isCoercionKind :: Kind -> Bool
+-- All coercions are of form (ty1 ~ ty2)
+-- This function is here rather than in Coercion, because it
+-- is used in a knot-tied way to enforce invariants in Var
+isCoercionKind (PredTy (EqPred {})) = True
+isCoercionKind _ = False
+\end{code}
+
+
+%************************************************************************
+%* *
+ Free variables of types and coercions
+%* *
+%************************************************************************
+
+\begin{code}
+tyVarsOfPred :: PredType -> TyCoVarSet
+tyVarsOfPred = varsOfPred tyVarsOfType
+
+tyVarsOfTheta :: ThetaType -> TyCoVarSet
+tyVarsOfTheta = varsOfTheta tyVarsOfType
+
+tyVarsOfType :: Type -> VarSet
+-- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym
+tyVarsOfType (TyVarTy v) = unitVarSet v
+tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys
+tyVarsOfType (PredTy sty) = varsOfPred tyVarsOfType sty
+tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
+tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
+tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar
+
+tyVarsOfTypes :: [Type] -> TyVarSet
+tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys
+
+varsOfPred :: (a -> VarSet) -> Pred a -> VarSet
+varsOfPred f (IParam _ ty) = f ty
+varsOfPred f (ClassP _ tys) = foldr (unionVarSet . f) emptyVarSet tys
+varsOfPred f (EqPred ty1 ty2) = f ty1 `unionVarSet` f ty2
+
+varsOfTheta :: (a -> VarSet) -> [Pred a] -> VarSet
+varsOfTheta f = foldr (unionVarSet . varsOfPred f) emptyVarSet
+
+predSize :: (a -> Int) -> Pred a -> Int
+predSize size (IParam _ t) = 1 + size t
+predSize size (ClassP _ ts) = 1 + sum (map size ts)
+predSize size (EqPred t1 t2) = size t1 + size t2
+\end{code}
+
+%************************************************************************
+%* *
TyThing
%* *
%************************************************************************
data TyThing = AnId Id
| ADataCon DataCon
| ATyCon TyCon
+ | ACoAxiom CoAxiom
| AClass Class
instance Outputable TyThing where
pprTyThingCategory :: TyThing -> SDoc
pprTyThingCategory (ATyCon _) = ptext (sLit "Type constructor")
+pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom")
pprTyThingCategory (AClass _) = ptext (sLit "Class")
pprTyThingCategory (AnId _) = ptext (sLit "Identifier")
pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor")
instance NamedThing TyThing where -- Can't put this with the type
getName (AnId id) = getName id -- decl, because the DataCon instance
getName (ATyCon tc) = getName tc -- isn't visible there
+ getName (ACoAxiom cc) = getName cc
getName (AClass cl) = getName cl
getName (ADataCon dc) = dataConName dc
\end{code}
%************************************************************************
%* *
- Wired-in type constructors
+ Substitutions
+ Data type defined here to avoid unnecessary mutual recursion
%* *
%************************************************************************
-We define a few wired-in type constructors here to avoid module knots
-
\begin{code}
---------------------------
--- First the TyCons...
-
--- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's
-funTyCon, tySuperKindTyCon, coSuperKindTyCon, liftedTypeKindTyCon,
- openTypeKindTyCon, unliftedTypeKindTyCon,
- ubxTupleKindTyCon, argTypeKindTyCon
- :: TyCon
-funTyConName, tySuperKindTyConName, coSuperKindTyConName, liftedTypeKindTyConName,
- openTypeKindTyConName, unliftedTypeKindTyConName,
- ubxTupleKindTyConName, argTypeKindTyConName
- :: Name
-
-funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind)
- -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
- -- But if we do that we get kind errors when saying
- -- instance Control.Arrow (->)
- -- becuase the expected kind is (*->*->*). The trouble is that the
- -- expected/actual stuff in the unifier does not go contra-variant, whereas
- -- the kind sub-typing does. Sigh. It really only matters if you use (->) in
- -- a prefix way, thus: (->) Int# Int#. And this is unusual.
-
-
-tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName
-coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName
-
-liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind
-openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind
-unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
-ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind
-argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind
-
---------------------------
--- ... and now their names
-
-tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon
-coSuperKindTyConName = mkPrimTyConName (fsLit "COERCION") coSuperKindTyConKey coSuperKindTyCon
-liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon
-openTypeKindTyConName = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon
-unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
-ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon
-argTypeKindTyConName = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon
-funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
-
-mkPrimTyConName :: FastString -> Unique -> TyCon -> Name
-mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ)
- key
- (ATyCon tycon)
- BuiltInSyntax
- -- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax,
- -- because they are never in scope in the source
-
-------------------
--- We also need Kinds and SuperKinds, locally and in TyCon
-
-kindTyConType :: TyCon -> Type
-kindTyConType kind = TyConApp kind []
-
--- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
-liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, ecKind :: Kind
-
-liftedTypeKind = kindTyConType liftedTypeKindTyCon
-unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
-openTypeKind = kindTyConType openTypeKindTyCon
-argTypeKind = kindTyConType argTypeKindTyCon
-ubxTupleKind = kindTyConType ubxTupleKindTyCon
-ecKind = liftedTypeKind `mkArrowKind` (liftedTypeKind `mkArrowKind` liftedTypeKind)
--- NOTE: if you change ecKind, you must also change the explicit kind signatures
--- on hetmet_{brak,esc,csp} in GHC.Hetmet.CodeTypes
+-- | Type substitution
+--
+-- #tvsubst_invariant#
+-- The following invariants must hold of a 'TvSubst':
+--
+-- 1. The in-scope set is needed /only/ to
+-- guide the generation of fresh uniques
+--
+-- 2. In particular, the /kind/ of the type variables in
+-- the in-scope set is not relevant
+--
+-- 3. The substition is only applied ONCE! This is because
+-- in general such application will not reached a fixed point.
+data TvSubst
+ = TvSubst InScopeSet -- The in-scope type variables
+ TvSubstEnv -- Substitution of types
+ -- See Note [Apply Once]
+ -- and Note [Extending the TvSubstEnv]
+
+-- | A substitition of 'Type's for 'TyVar's
+type TvSubstEnv = TyVarEnv Type
+ -- A TvSubstEnv is used both inside a TvSubst (with the apply-once
+ -- invariant discussed in Note [Apply Once]), and also independently
+ -- in the middle of matching, and unification (see Types.Unify)
+ -- So you have to look at the context to know if it's idempotent or
+ -- apply-once or whatever
+\end{code}
--- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
-mkArrowKind :: Kind -> Kind -> Kind
-mkArrowKind k1 k2 = FunTy k1 k2
+Note [Apply Once]
+~~~~~~~~~~~~~~~~~
+We use TvSubsts to instantiate things, and we might instantiate
+ forall a b. ty
+\with the types
+ [a, b], or [b, a].
+So the substition might go [a->b, b->a]. A similar situation arises in Core
+when we find a beta redex like
+ (/\ a /\ b -> e) b a
+Then we also end up with a substition that permutes type variables. Other
+variations happen to; for example [a -> (a, b)].
--- | Iterated application of 'mkArrowKind'
-mkArrowKinds :: [Kind] -> Kind -> Kind
-mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds
+ ***************************************************
+ *** So a TvSubst must be applied precisely once ***
+ ***************************************************
-tySuperKind, coSuperKind :: SuperKind
-tySuperKind = kindTyConType tySuperKindTyCon
-coSuperKind = kindTyConType coSuperKindTyCon
+A TvSubst is not idempotent, but, unlike the non-idempotent substitution
+we use during unifications, it must not be repeatedly applied.
-isTySuperKind :: SuperKind -> Bool
-isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
-isTySuperKind _ = False
+Note [Extending the TvSubst]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See #tvsubst_invariant# for the invariants that must hold.
-isCoSuperKind :: SuperKind -> Bool
-isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey
-isCoSuperKind _ = False
+This invariant allows a short-cut when the TvSubstEnv is empty:
+if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds ---
+then (substTy subst ty) does nothing.
--------------------
--- Lastly we need a few functions on Kinds
+For example, consider:
+ (/\a. /\b:(a~Int). ...b..) Int
+We substitute Int for 'a'. The Unique of 'b' does not change, but
+nevertheless we add 'b' to the TvSubstEnv, because b's kind does change
-isLiftedTypeKindCon :: TyCon -> Bool
-isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey
+This invariant has several crucial consequences:
-isLiftedTypeKind :: Kind -> Bool
-isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindCon tc
-isLiftedTypeKind _ = False
+* In substTyVarBndr, we need extend the TvSubstEnv
+ - if the unique has changed
+ - or if the kind has changed
-isCoercionKind :: Kind -> Bool
--- All coercions are of form (ty1 ~ ty2)
--- This function is here rather than in Coercion,
--- because it's used in a knot-tied way to enforce invariants in Var
-isCoercionKind (PredTy (EqPred {})) = True
-isCoercionKind _ = False
+* In substTyVar, we do not need to consult the in-scope set;
+ the TvSubstEnv is enough
-coVarPred :: CoVar -> PredType
-coVarPred tv
- = ASSERT( isCoVar tv )
- case tyVarKind tv of
- PredTy eq -> eq
- other -> pprPanic "coVarPred" (ppr tv $$ ppr other)
+* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty
\end{code}
%************************************************************************
%* *
-\subsection{The external interface}
-%* *
+ Pretty-printing types
+
+ Defined very early because of debug printing in assertions
+%* *
%************************************************************************
@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is
------------------
pprType, pprParendType :: Type -> SDoc
-pprType ty = ppr_type TopPrec ty
+pprType ty = ppr_type TopPrec ty
pprParendType ty = ppr_type TyConPrec ty
-pprTypeApp :: NamedThing a => a -> [Type] -> SDoc
--- The first arg is the tycon, or sometimes class
--- Print infix if the tycon/class looks like an operator
-pprTypeApp tc tys = ppr_type_app TopPrec (getName tc) tys
+pprKind, pprParendKind :: Kind -> SDoc
+pprKind = pprType
+pprParendKind = pprParendType
------------------
-pprPred :: PredType -> SDoc
-pprPred (ClassP cls tys) = pprClassPred cls tys
-pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty
-pprPred (EqPred ty1 ty2) = pprEqPred (ty1,ty2)
-
-pprEqPred :: (Type,Type) -> SDoc
-pprEqPred (ty1,ty2) = sep [ ppr_type FunPrec ty1
- , nest 2 (ptext (sLit "~"))
- , ppr_type FunPrec ty2]
+pprPredTy :: PredType -> SDoc
+pprPredTy = pprPred ppr_type
+
+pprPred :: (Prec -> a -> SDoc) -> Pred a -> SDoc
+pprPred pp (ClassP cls tys) = ppr_class_pred pp cls tys
+pprPred pp (IParam ip ty) = ppr ip <> dcolon <> pp TopPrec ty
+pprPred pp (EqPred ty1 ty2) = ppr_eq_pred pp (Pair ty1 ty2)
+
+------------
+pprEqPred :: Pair Type -> SDoc
+pprEqPred = ppr_eq_pred ppr_type
+
+ppr_eq_pred :: (Prec -> a -> SDoc) -> Pair a -> SDoc
+ppr_eq_pred pp (Pair ty1 ty2) = sep [ pp FunPrec ty1
+ , nest 2 (ptext (sLit "~"))
+ , pp FunPrec ty2]
-- Precedence looks like (->) so that we get
-- Maybe a ~ Bool
-- (a->a) ~ Bool
-- Note parens on the latter!
+------------
pprClassPred :: Class -> [Type] -> SDoc
-pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys
+pprClassPred = ppr_class_pred ppr_type
+
+ppr_class_pred :: (Prec -> a -> SDoc) -> Class -> [a] -> SDoc
+ppr_class_pred pp clas tys = pprTypeNameApp TopPrec pp (getName clas) tys
+------------
pprTheta :: ThetaType -> SDoc
-- pprTheta [pred] = pprPred pred -- I'm in two minds about this
-pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
+pprTheta theta = parens (sep (punctuate comma (map pprPredTy theta)))
+
+pprThetaArrowTy :: ThetaType -> SDoc
+pprThetaArrowTy = pprThetaArrow ppr_type
-pprThetaArrow :: ThetaType -> SDoc
-pprThetaArrow [] = empty
-pprThetaArrow [pred]
- | noParenPred pred = pprPred pred <+> darrow
-pprThetaArrow preds = parens (sep (punctuate comma (map pprPred preds))) <+> darrow
+pprThetaArrow :: (Prec -> a -> SDoc) -> [Pred a] -> SDoc
+pprThetaArrow _ [] = empty
+pprThetaArrow pp [pred]
+ | noParenPred pred = pprPred pp pred <+> darrow
+pprThetaArrow pp preds = parens (sep (punctuate comma (map (pprPred pp) preds)))
+ <+> darrow
-noParenPred :: PredType -> Bool
+noParenPred :: Pred a -> Bool
-- A predicate that can appear without parens before a "=>"
-- C a => a -> a
-- a~b => a -> b
instance Outputable Type where
ppr ty = pprType ty
-instance Outputable PredType where
- ppr = pprPred
+instance Outputable (Pred Type) where
+ ppr = pprPredTy -- Not for arbitrary (Pred a), because the
+ -- (Outputable a) doesn't give precedence
instance Outputable name => OutputableBndr (IPName name) where
pprBndr _ n = ppr n -- Simple for now
------------------
-- OK, here's the main printer
-pprKind, pprParendKind :: Kind -> SDoc
-pprKind = pprType
-pprParendKind = pprParendType
-
ppr_type :: Prec -> Type -> SDoc
ppr_type _ (TyVarTy tv) = ppr_tvar tv
ppr_type p (PredTy pred) = maybeParen p TyConPrec $
- ifPprDebug (ptext (sLit "<pred>")) <> (ppr pred)
-ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
+ ifPprDebug (ptext (sLit "<pred>")) <> (pprPredTy pred)
+ppr_type p (TyConApp tc tys) = pprTcApp p ppr_type tc tys
ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
pprType t1 <+> ppr_type TyConPrec t2
-ppr_type p ty@(ForAllTy _ _) = ppr_forall_type p ty
+ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty
ppr_type p ty@(FunTy (PredTy _) _) = ppr_forall_type p ty
ppr_type p (FunTy ty1 ty2)
- = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
- maybeParen p FunPrec $
- sep (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
+ = pprArrowChain p (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
where
- ppr_fun_tail (FunTy ty1 ty2)
- | not (is_pred ty1) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2
- ppr_fun_tail other_ty = [arrow <+> pprType other_ty]
+ -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
+ ppr_fun_tail (FunTy ty1 ty2)
+ | not (is_pred ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2
+ ppr_fun_tail other_ty = [ppr_type TopPrec other_ty]
+
is_pred (PredTy {}) = True
is_pred _ = False
ppr_forall_type :: Prec -> Type -> SDoc
ppr_forall_type p ty
= maybeParen p FunPrec $
- sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
+ sep [pprForAll tvs, pprThetaArrowTy ctxt, pprType tau]
where
(tvs, rho) = split1 [] ty
(ctxt, tau) = split2 [] rho
- -- We need to be extra careful here as equality constraints will occur as
- -- type variables with an equality kind. So, while collecting quantified
- -- variables, we separate the coercion variables out and turn them into
- -- equality predicates.
- split1 tvs (ForAllTy tv ty)
- | not (isCoVar tv) = split1 (tv:tvs) ty
- split1 tvs ty = (reverse tvs, ty)
+ split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
+ split1 tvs ty = (reverse tvs, ty)
split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
- split2 ps (ForAllTy tv ty)
- | isCoVar tv = split2 (coVarPred tv : ps) ty
split2 ps ty = (reverse ps, ty)
-ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
-ppr_tc_app _ tc []
- = ppr_tc tc
-ppr_tc_app _ tc [ty]
- | tc `hasKey` listTyConKey = brackets (pprType ty)
- | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pprType ty <> ptext (sLit ":]")
- | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*")
- | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#")
- | tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)")
- | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)")
- | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??")
-
-ppr_tc_app p tc tys
- | [ecvar,ty] <- tys, tc `hasKey` hetMetCodeTypeTyConKey
- = ptext (sLit "<[") <> pprType ty <> ptext (sLit "]>@") <> ppr ecvar
- | isTupleTyCon tc && tyConArity tc == length tys
- = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
- | otherwise
- = ppr_type_app p (getName tc) tys
-
-ppr_type_app :: Prec -> Name -> [Type] -> SDoc
--- Used for classes as well as types; that's why it's separate from ppr_tc_app
-ppr_type_app p tc tys
- | is_sym_occ -- Print infix if possible
- , [ty1,ty2] <- tys -- We know nothing of precedence though
- = maybeParen p FunPrec (sep [ppr_type FunPrec ty1,
- pprInfixVar True (ppr tc) <+> ppr_type FunPrec ty2])
- | otherwise
- = maybeParen p TyConPrec (hang (pprPrefixVar is_sym_occ (ppr tc))
- 2 (sep (map pprParendType tys)))
- where
- is_sym_occ = isSymOcc (getOccName tc)
-
-ppr_tc :: TyCon -> SDoc -- No brackets for SymOcc
-ppr_tc tc
- = pp_nt_debug <> ppr tc
- where
- pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
- then ptext (sLit "<recnt>")
- else ptext (sLit "<nt>"))
- | otherwise = empty
-
ppr_tvar :: TyVar -> SDoc
ppr_tvar tv -- Note [Infix type variables]
| isSymOcc (getOccName tv) = parens (ppr tv)
pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot
pprTvBndr :: TyVar -> SDoc
-pprTvBndr tv | isLiftedTypeKind kind = ppr_tvar tv
- | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind)
+pprTvBndr tv
+ | isLiftedTypeKind kind = ppr_tvar tv
+ | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind)
where
kind = tyVarKind tv
\end{code}
See Trac #2766.
+\begin{code}
+pprTcApp :: Prec -> (Prec -> a -> SDoc) -> TyCon -> [a] -> SDoc
+pprTcApp _ _ tc [] -- No brackets for SymOcc
+ = pp_nt_debug <> ppr tc
+ where
+ pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
+ then ptext (sLit "<recnt>")
+ else ptext (sLit "<nt>"))
+ | otherwise = empty
+pprTcApp _ pp tc [ty]
+ | tc `hasKey` listTyConKey = brackets (pp TopPrec ty)
+ | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pp TopPrec ty <> ptext (sLit ":]")
+ | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*")
+ | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#")
+ | tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)")
+ | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)")
+ | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??")
+pprTcApp p pp tc tys
+ | isTupleTyCon tc && tyConArity tc == length tys
+ = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map (pp TopPrec) tys)))
+ | otherwise
+ = pprTypeNameApp p pp (getName tc) tys
+
+----------------
+pprTypeApp :: NamedThing a => a -> [Type] -> SDoc
+-- The first arg is the tycon, or sometimes class
+-- Print infix if the tycon/class looks like an operator
+pprTypeApp tc tys = pprTypeNameApp TopPrec ppr_type (getName tc) tys
+
+pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc
+-- Used for classes and coercions as well as types; that's why it's separate from pprTcApp
+pprTypeNameApp p pp tc tys
+ | is_sym_occ -- Print infix if possible
+ , [ty1,ty2] <- tys -- We know nothing of precedence though
+ = maybeParen p FunPrec $
+ sep [pp FunPrec ty1, pprInfixVar True (ppr tc) <+> pp FunPrec ty2]
+ | otherwise
+ = pprPrefixApp p (pprPrefixVar is_sym_occ (ppr tc)) (map (pp TyConPrec) tys)
+ where
+ is_sym_occ = isSymOcc (getOccName tc)
+
+----------------
+pprPrefixApp :: Prec -> SDoc -> [SDoc] -> SDoc
+pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $
+ hang pp_fun 2 (sep pp_tys)
+
+----------------
+pprArrowChain :: Prec -> [SDoc] -> SDoc
+-- pprArrowChain p [a,b,c] generates a -> b -> c
+pprArrowChain _ [] = empty
+pprArrowChain p (arg:args) = maybeParen p FunPrec $
+ sep [arg, sep (map (arrow <+>) args)]
+\end{code}
module TypeRep where
data Type
-data PredType
+data Pred a
data TyThing
+type PredType = Pred Type
type Kind = Type
isCoercionKind :: Kind -> Bool
-- the "tc" prefix indicates that matching always
-- respects newtypes (rather than looking through them)
tcMatchTy, tcMatchTys, tcMatchTyX,
- ruleMatchTyX, tcMatchPreds, MatchEnv(..),
-
- dataConCannotMatch,
+ ruleMatchTyX, tcMatchPreds,
+
+ MatchEnv(..), matchList,
+
+ typesCantMatch,
-- Side-effect free unification
tcUnifyTys, BindFlag(..),
import Var
import VarEnv
import VarSet
+import Kind
import Type
-import Coercion
import TyCon
-import DataCon
import TypeRep
import Outputable
import ErrUtils
import Util
import Maybes
import FastString
+
+import Control.Monad (guard)
\end{code}
\begin{code}
data MatchEnv
- = ME { me_tmpls :: VarSet -- Template tyvars
+ = ME { me_tmpls :: VarSet -- Template variables
, me_env :: RnEnv2 -- Renaming envt for nested foralls
- } -- In-scope set includes template tyvars
+ } -- In-scope set includes template variables
+ -- Nota Bene: MatchEnv isn't specific to Types. It is used
+ -- for matching terms and coercions as well as types
tcMatchTy :: TyVarSet -- Template tyvars
-> Type -- Template
-> [PredType] -> [PredType]
-> Maybe TvSubstEnv
tcMatchPreds tmpls ps1 ps2
- = match_list (match_pred menv) emptyTvSubstEnv ps1 ps2
+ = matchList (match_pred menv) emptyTvSubstEnv ps1 ps2
where
menv = ME { me_tmpls = mkVarSet tmpls, me_env = mkRnEnv2 in_scope_tyvars }
in_scope_tyvars = mkInScopeSet (tyVarsOfTheta ps1 `unionVarSet` tyVarsOfTheta ps2)
match menv subst (TyVarTy tv1) ty2
| Just ty1' <- lookupVarEnv subst tv1' -- tv1' is already bound
- = if tcEqTypeX (nukeRnEnvL rn_env) ty1' ty2
+ = if eqTypeX (nukeRnEnvL rn_env) ty1' ty2
-- ty1 has no locally-bound variables, hence nukeRnEnvL
- -- Note tcEqType...we are doing source-type matching here
then Just subst
else Nothing -- ty2 doesn't match
match_kind :: MatchEnv -> TvSubstEnv -> TyVar -> Type -> Maybe TvSubstEnv
-- Match the kind of the template tyvar with the kind of Type
-- Note [Matching kinds]
-match_kind menv subst tv ty
- | isCoVar tv = do { let (ty1,ty2) = coVarKind tv
- (ty3,ty4) = coercionKind ty
- ; subst1 <- match menv subst ty1 ty3
- ; match menv subst1 ty2 ty4 }
- | otherwise = if typeKind ty `isSubKind` tyVarKind tv
- then Just subst
- else Nothing
+match_kind _ subst tv ty
+ = guard (typeKind ty `isSubKind` tyVarKind tv) >> return subst
-- Note [Matching kinds]
-- ~~~~~~~~~~~~~~~~~~~~~
--------------
match_tys :: MatchEnv -> TvSubstEnv -> [Type] -> [Type] -> Maybe TvSubstEnv
-match_tys menv subst tys1 tys2 = match_list (match menv) subst tys1 tys2
+match_tys menv subst tys1 tys2 = matchList (match menv) subst tys1 tys2
--------------
-match_list :: (TvSubstEnv -> a -> a -> Maybe TvSubstEnv)
- -> TvSubstEnv -> [a] -> [a] -> Maybe TvSubstEnv
-match_list _ subst [] [] = Just subst
-match_list fn subst (ty1:tys1) (ty2:tys2) = do { subst' <- fn subst ty1 ty2
- ; match_list fn subst' tys1 tys2 }
-match_list _ _ _ _ = Nothing
+matchList :: (env -> a -> b -> Maybe env)
+ -> env -> [a] -> [b] -> Maybe env
+matchList _ subst [] [] = Just subst
+matchList fn subst (a:as) (b:bs) = do { subst' <- fn subst a b
+ ; matchList fn subst' as bs }
+matchList _ _ _ _ = Nothing
--------------
match_pred :: MatchEnv -> TvSubstEnv -> PredType -> PredType -> Maybe TvSubstEnv
distinct data types fail to match. We can elaborate later.
\begin{code}
-dataConCannotMatch :: [Type] -> DataCon -> Bool
--- Returns True iff the data con *definitely cannot* match a
--- scrutinee of type (T tys)
--- where T is the type constructor for the data con
---
-dataConCannotMatch tys con
- | null eq_spec = False -- Common
- | all isTyVarTy tys = False -- Also common
- | otherwise
- = cant_match_s (map (substTyVar subst . fst) eq_spec)
- (map snd eq_spec)
+typesCantMatch :: [(Type,Type)] -> Bool
+typesCantMatch prs = any (\(s,t) -> cant_match s t) prs
where
- dc_tvs = dataConUnivTyVars con
- eq_spec = dataConEqSpec con
- subst = zipTopTvSubst dc_tvs tys
-
- cant_match_s :: [Type] -> [Type] -> Bool
- cant_match_s tys1 tys2 = ASSERT( equalLength tys1 tys2 )
- or (zipWith cant_match tys1 tys2)
-
cant_match :: Type -> Type -> Bool
cant_match t1 t2
| Just t1' <- coreView t1 = cant_match t1' t2
cant_match (TyConApp tc1 tys1) (TyConApp tc2 tys2)
| isDataTyCon tc1 && isDataTyCon tc2
- = tc1 /= tc2 || cant_match_s tys1 tys2
+ = tc1 /= tc2 || typesCantMatch (zipEqual "typesCantMatch" tys1 tys2)
cant_match (FunTy {}) (TyConApp tc _) = isDataTyCon tc
cant_match (TyConApp tc _) (FunTy {}) = isDataTyCon tc
\end{code}
-
%************************************************************************
%* *
Unification
| otherwise = subst
where
range_tvs = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet e
- subst = mkTvSubst (mkInScopeSet range_tvs) e
+ subst = mkTvSubst (mkInScopeSet range_tvs) e
not_fixpoint = foldVarSet ((||) . in_domain) False range_tvs
in_domain tv = tv `elemVarEnv` e
Outputable(..), OutputableBndr(..),
-- * Pretty printing combinators
- SDoc,
+ SDoc, runSDoc, initSDocContext,
docToSDoc,
interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
empty, nest,
hang, punctuate, ppWhen, ppUnless,
speakNth, speakNTimes, speakN, speakNOf, plural,
+ coloured, PprColour, colType, colCoerc, colDataCon,
+ colBinder, bold, keyword,
+
-- * Converting 'SDoc' into strings and outputing it
printSDoc, printErrs, printOutput, hPrintDump, printDump,
printForC, printForAsm, printForUser, printForUserPartWay,
showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
showPpr,
showSDocUnqual, showsPrecSDoc,
+ renderWithStyle,
pprInfixVar, pprPrefixVar,
pprHsChar, pprHsString, pprHsInfix, pprHsVar,
%************************************************************************
\begin{code}
-type SDoc = PprStyle -> Doc
+newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
+
+data SDocContext = SDC
+ { sdocStyle :: !PprStyle
+ , sdocLastColour :: !PprColour
+ -- ^ The most recently used colour. This allows nesting colours.
+ }
+
+initSDocContext :: PprStyle -> SDocContext
+initSDocContext sty = SDC
+ { sdocStyle = sty
+ , sdocLastColour = colReset
+ }
withPprStyle :: PprStyle -> SDoc -> SDoc
-withPprStyle sty d _sty' = d sty
+withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
withPprStyleDoc :: PprStyle -> SDoc -> Doc
-withPprStyleDoc sty d = d sty
+withPprStyleDoc sty d = runSDoc d (initSDocContext sty)
pprDeeper :: SDoc -> SDoc
-pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
-pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
-pprDeeper d other_sty = d other_sty
+pprDeeper d = SDoc $ \ctx -> case ctx of
+ SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..."
+ SDC{sdocStyle=PprUser q (PartWay n)} ->
+ runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))}
+ _ -> runSDoc d ctx
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
-- Truncate a list that list that is longer than the current depth
-pprDeeperList f ds (PprUser q (PartWay n))
- | n==0 = Pretty.text "..."
- | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
- where
- go _ [] = []
- go i (d:ds) | i >= n = [text "...."]
- | otherwise = d : go (i+1) ds
-
-pprDeeperList f ds other_sty
- = f ds other_sty
+pprDeeperList f ds = SDoc work
+ where
+ work ctx@SDC{sdocStyle=PprUser q (PartWay n)}
+ | n==0 = Pretty.text "..."
+ | otherwise =
+ runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))}
+ where
+ go _ [] = []
+ go i (d:ds) | i >= n = [text "...."]
+ | otherwise = d : go (i+1) ds
+ work other_ctx = runSDoc (f ds) other_ctx
pprSetDepth :: Depth -> SDoc -> SDoc
-pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth)
-pprSetDepth _depth doc other_sty = doc other_sty
+pprSetDepth depth doc = SDoc $ \ctx -> case ctx of
+ SDC{sdocStyle=PprUser q _} ->
+ runSDoc doc ctx{sdocStyle = PprUser q depth}
+ _ ->
+ runSDoc doc ctx
getPprStyle :: (PprStyle -> SDoc) -> SDoc
-getPprStyle df sty = df sty sty
+getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
\end{code}
\begin{code}
userStyle _other = False
ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
-ifPprDebug d sty@PprDebug = d sty
-ifPprDebug _ _ = Pretty.empty
+ifPprDebug d = SDoc $ \ctx -> case ctx of
+ SDC{sdocStyle=PprDebug} -> runSDoc d ctx
+ _ -> Pretty.empty
\end{code}
\begin{code}
-- Unused [7/02 sof]
printSDoc :: SDoc -> PprStyle -> IO ()
printSDoc d sty = do
- Pretty.printDoc PageMode stdout (d sty)
+ Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext sty))
hFlush stdout
-- I'm not sure whether the direct-IO approach of Pretty.printDoc
-- above is better or worse than the put-big-string approach here
-printErrs :: Doc -> IO ()
-printErrs doc = do Pretty.printDoc PageMode stderr doc
- hFlush stderr
+printErrs :: SDoc -> PprStyle -> IO ()
+printErrs doc sty = do
+ Pretty.printDoc PageMode stderr (runSDoc doc (initSDocContext sty))
+ hFlush stderr
printOutput :: Doc -> IO ()
printOutput doc = Pretty.printDoc PageMode stdout doc
hPrintDump :: Handle -> SDoc -> IO ()
hPrintDump h doc = do
- Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
+ Pretty.printDoc PageMode h
+ (runSDoc better_doc (initSDocContext defaultDumpStyle))
hFlush h
where
better_doc = doc $$ blankLine
printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
printForUser handle unqual doc
- = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
+ = Pretty.printDoc PageMode handle
+ (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
printForUserPartWay handle d unqual doc
- = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
+ = Pretty.printDoc PageMode handle
+ (runSDoc doc (initSDocContext (mkUserStyle unqual (PartWay d))))
-- printForC, printForAsm do what they sound like
printForC :: Handle -> SDoc -> IO ()
-printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
+printForC handle doc =
+ Pretty.printDoc LeftMode handle
+ (runSDoc doc (initSDocContext (PprCode CStyle)))
printForAsm :: Handle -> SDoc -> IO ()
-printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
+printForAsm handle doc =
+ Pretty.printDoc LeftMode handle
+ (runSDoc doc (initSDocContext (PprCode AsmStyle)))
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
-- However, Doc *is* an instance of Show
-- showSDoc just blasts it out as a string
showSDoc :: SDoc -> String
-showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
+showSDoc d =
+ Pretty.showDocWith PageMode
+ (runSDoc d (initSDocContext defaultUserStyle))
+
+renderWithStyle :: SDoc -> PprStyle -> String
+renderWithStyle sdoc sty =
+ Pretty.render (runSDoc sdoc (initSDocContext sty))
-- This shows an SDoc, but on one line only. It's cheaper than a full
-- showSDoc, designed for when we're getting results like "Foo.bar"
-- and "foo{uniq strictness}" so we don't want fancy layout anyway.
showSDocOneLine :: SDoc -> String
-showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
+showSDocOneLine d =
+ Pretty.showDocWith PageMode
+ (runSDoc d (initSDocContext defaultUserStyle))
showSDocForUser :: PrintUnqualified -> SDoc -> String
-showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
+showSDocForUser unqual doc =
+ show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
showSDocUnqual :: SDoc -> String
-- Only used in the gruesome isOperator
-showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
+showSDocUnqual d =
+ show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay)))
showsPrecSDoc :: Int -> SDoc -> ShowS
-showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
+showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle))
showSDocDump :: SDoc -> String
-showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
+showSDocDump d =
+ Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump))
showSDocDumpOneLine :: SDoc -> String
-showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
+showSDocDumpOneLine d =
+ Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump))
showSDocDebug :: SDoc -> String
-showSDocDebug d = show (d PprDebug)
+showSDocDebug d = show (runSDoc d (initSDocContext PprDebug))
showPpr :: Outputable a => a -> String
showPpr = showSDoc . ppr
\begin{code}
docToSDoc :: Doc -> SDoc
-docToSDoc d = \_ -> d
+docToSDoc d = SDoc (\_ -> d)
empty :: SDoc
char :: Char -> SDoc
double :: Double -> SDoc
rational :: Rational -> SDoc
-empty _sty = Pretty.empty
-char c _sty = Pretty.char c
-text s _sty = Pretty.text s
-ftext s _sty = Pretty.ftext s
-ptext s _sty = Pretty.ptext s
-int n _sty = Pretty.int n
-integer n _sty = Pretty.integer n
-float n _sty = Pretty.float n
-double n _sty = Pretty.double n
-rational n _sty = Pretty.rational n
+empty = docToSDoc $ Pretty.empty
+char c = docToSDoc $ Pretty.char c
+text s = docToSDoc $ Pretty.text s
+ftext s = docToSDoc $ Pretty.ftext s
+ptext s = docToSDoc $ Pretty.ptext s
+int n = docToSDoc $ Pretty.int n
+integer n = docToSDoc $ Pretty.integer n
+float n = docToSDoc $ Pretty.float n
+double n = docToSDoc $ Pretty.double n
+rational n = docToSDoc $ Pretty.rational n
parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
-parens d sty = Pretty.parens (d sty)
-braces d sty = Pretty.braces (d sty)
-brackets d sty = Pretty.brackets (d sty)
-doubleQuotes d sty = Pretty.doubleQuotes (d sty)
-angleBrackets d = char '<' <> d <> char '>'
+parens d = SDoc $ Pretty.parens . runSDoc d
+braces d = SDoc $ Pretty.braces . runSDoc d
+brackets d = SDoc $ Pretty.brackets . runSDoc d
+doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
+angleBrackets d = char '<' <> d <> char '>'
cparen :: Bool -> SDoc -> SDoc
-cparen b d sty = Pretty.cparen b (d sty)
+cparen b d = SDoc $ Pretty.cparen b . runSDoc d
-- quotes encloses something in single quotes...
-- but it omits them if the thing ends in a single quote
-- so that we don't get `foo''. Instead we just have foo'.
-quotes d sty = case show pp_d of
- ('\'' : _) -> pp_d
- _other -> Pretty.quotes pp_d
- where
- pp_d = d sty
+quotes d = SDoc $ \sty ->
+ let pp_d = runSDoc d sty in
+ case show pp_d of
+ ('\'' : _) -> pp_d
+ _other -> Pretty.quotes pp_d
semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
-blankLine _sty = Pretty.ptext (sLit "")
-dcolon _sty = Pretty.ptext (sLit "::")
-arrow _sty = Pretty.ptext (sLit "->")
-darrow _sty = Pretty.ptext (sLit "=>")
-semi _sty = Pretty.semi
-comma _sty = Pretty.comma
-colon _sty = Pretty.colon
-equals _sty = Pretty.equals
-space _sty = Pretty.space
-underscore = char '_'
-dot = char '.'
-lparen _sty = Pretty.lparen
-rparen _sty = Pretty.rparen
-lbrack _sty = Pretty.lbrack
-rbrack _sty = Pretty.rbrack
-lbrace _sty = Pretty.lbrace
-rbrace _sty = Pretty.rbrace
+blankLine = docToSDoc $ Pretty.ptext (sLit "")
+dcolon = docToSDoc $ Pretty.ptext (sLit "::")
+arrow = docToSDoc $ Pretty.ptext (sLit "->")
+darrow = docToSDoc $ Pretty.ptext (sLit "=>")
+semi = docToSDoc $ Pretty.semi
+comma = docToSDoc $ Pretty.comma
+colon = docToSDoc $ Pretty.colon
+equals = docToSDoc $ Pretty.equals
+space = docToSDoc $ Pretty.space
+underscore = char '_'
+dot = char '.'
+lparen = docToSDoc $ Pretty.lparen
+rparen = docToSDoc $ Pretty.rparen
+lbrack = docToSDoc $ Pretty.lbrack
+rbrack = docToSDoc $ Pretty.rbrack
+lbrace = docToSDoc $ Pretty.lbrace
+rbrace = docToSDoc $ Pretty.rbrace
nest :: Int -> SDoc -> SDoc
-- ^ Indent 'SDoc' some specified amount
($+$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically
-nest n d sty = Pretty.nest n (d sty)
-(<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
-(<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
-($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
-($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
+nest n d = SDoc $ Pretty.nest n . runSDoc d
+(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty)
+(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)
+($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty)
+($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)
hcat :: [SDoc] -> SDoc
-- ^ Concatenate 'SDoc' horizontally
-- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
-hcat ds sty = Pretty.hcat [d sty | d <- ds]
-hsep ds sty = Pretty.hsep [d sty | d <- ds]
-vcat ds sty = Pretty.vcat [d sty | d <- ds]
-sep ds sty = Pretty.sep [d sty | d <- ds]
-cat ds sty = Pretty.cat [d sty | d <- ds]
-fsep ds sty = Pretty.fsep [d sty | d <- ds]
-fcat ds sty = Pretty.fcat [d sty | d <- ds]
+hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
+hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
+vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
+sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds]
+cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds]
+fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
+fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
hang :: SDoc -- ^ The header
-> Int -- ^ Amount to indent the hung body
-> SDoc -- ^ The hung body, indented and placed below the header
-> SDoc
-hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
+hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
punctuate :: SDoc -- ^ The punctuation
-> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
ppUnless True _ = empty
ppUnless False doc = doc
+
+-- | A colour\/style for use with 'coloured'.
+newtype PprColour = PprColour String
+
+-- Colours
+
+colType :: PprColour
+colType = PprColour "\27[34m"
+
+colBold :: PprColour
+colBold = PprColour "\27[;1m"
+
+colCoerc :: PprColour
+colCoerc = PprColour "\27[34m"
+
+colDataCon :: PprColour
+colDataCon = PprColour "\27[31m"
+
+colBinder :: PprColour
+colBinder = PprColour "\27[32m"
+
+colReset :: PprColour
+colReset = PprColour "\27[0m"
+
+-- | Apply the given colour\/style for the argument.
+--
+-- Only takes effect if colours are enabled.
+coloured :: PprColour -> SDoc -> SDoc
+-- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
+coloured col@(PprColour c) sdoc =
+ SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
+ let ctx' = ctx{ sdocLastColour = col } in
+ Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
+
+bold :: SDoc -> SDoc
+bold = coloured colBold
+
+keyword :: SDoc -> SDoc
+keyword = bold
+
\end{code}
pprPanicFastInt :: String -> SDoc -> FastInt
-- ^ Specialization of pprPanic that can be safely used with 'FastInt'
-pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
- where
- doc = text heading <+> pretty_msg
+pprPanicFastInt heading pretty_msg =
+ panicFastInt (show (runSDoc doc (initSDocContext PprDebug)))
+ where
+ doc = text heading <+> pretty_msg
pprAndThen :: (String -> a) -> String -> SDoc -> a
-pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
- where
+pprAndThen cont heading pretty_msg =
+ cont (show (runSDoc doc (initSDocContext PprDebug)))
+ where
doc = sep [text heading, nest 4 pretty_msg]
assertPprPanic :: String -> Int -> SDoc -> a
-- ^ Panic with an assertation failure, recording the given file and line number.
-- Should typically be accessed with the ASSERT family of macros
assertPprPanic file line msg
- = panic (show (doc PprDebug))
+ = panic (show (runSDoc doc (initSDocContext PprDebug)))
where
doc = sep [hsep[text "ASSERT failed! file",
text file,
warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
warnPprTrace False _file _line _msg x = x
warnPprTrace True file line msg x
- = trace (show (doc defaultDumpStyle)) x
+ = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x
where
doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
msg]
--- /dev/null
+
+A simple homogeneous pair type with useful Functor, Applicative, and
+Traversable instances.
+
+\begin{code}
+module Pair ( Pair(..), unPair, toPair, swap ) where
+
+#include "HsVersions.h"
+
+import Outputable
+import Data.Monoid
+import Control.Applicative
+import Data.Foldable
+import Data.Traversable
+
+data Pair a = Pair { pFst :: a, pSnd :: a }
+-- Note that Pair is a *unary* type constructor
+-- whereas (,) is binary
+
+-- The important thing about Pair is that it has a *homogenous*
+-- Functor instance, so you can easily apply the same function
+-- to both components
+instance Functor Pair where
+ fmap f (Pair x y) = Pair (f x) (f y)
+
+instance Applicative Pair where
+ pure x = Pair x x
+ (Pair f g) <*> (Pair x y) = Pair (f x) (g y)
+
+instance Foldable Pair where
+ foldMap f (Pair x y) = f x `mappend` f y
+
+instance Traversable Pair where
+ traverse f (Pair x y) = Pair <$> f x <*> f y
+
+instance Outputable a => Outputable (Pair a) where
+ ppr (Pair a b) = ppr a <+> char '~' <+> ppr b
+
+unPair :: Pair a -> (a,a)
+unPair (Pair x y) = (x,y)
+
+toPair :: (a,a) -> Pair a
+toPair (x,y) = Pair x y
+
+swap :: Pair a -> Pair a
+swap (Pair x y) = Pair y x
+\end{code}
\ No newline at end of file
-- about what instruction set extensions an architecture might support.
--
data Arch
- = ArchAlpha
- | ArchX86
+ = ArchX86
| ArchX86_64
| ArchPPC
| ArchPPC_64
-- | Move the evil TARGET_ARCH #ifdefs into Haskell land.
defaultTargetArch :: Arch
-#if alpha_TARGET_ARCH
-defaultTargetArch = ArchAlpha
-#elif i386_TARGET_ARCH
+#if i386_TARGET_ARCH
defaultTargetArch = ArchX86
#elif x86_64_TARGET_ARCH
defaultTargetArch = ArchX86_64
empty, isEmpty, nest,
- char, text, ftext, ptext,
+ char, text, ftext, ptext, zeroWidthText,
int, integer, float, double, rational,
parens, brackets, braces, quotes, doubleQuotes,
semi, comma, colon, space, equals,
\begin{code}
empty :: Doc
isEmpty :: Doc -> Bool
+-- | Some text, but without any width. Use for non-printing text
+-- such as a HTML or Latex tags
+zeroWidthText :: String -> Doc
+
text :: String -> Doc
char :: Char -> Doc
ptext :: LitString -> Doc
ptext s_= case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty}
where s = {-castPtr-} s_
+zeroWidthText s = textBeside_ (Str s) (_ILIT(0)) Empty
#if defined(__GLASGOW_HASKELL__)
-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
import CoreSyn
import CoreMonad ( CoreM, getHscEnv )
import Type
-import Var
import Id
import OccName
import DynFlags
; case vectDecl of
Nothing -> return ()
Just (vdty, _)
- | coreEqType vty vdty -> return ()
+ | eqType vty vdty -> return ()
| otherwise ->
cantVectorise ("Type mismatch in vectorisation pragma for " ++ show var) $
(text "Expected type" <+> ppr vty)
indexBuiltin,
-- * Projections
- selTy,
+ selTy,
selReplicate,
selPick,
selTags,
import Type
import TyCon
import DataCon
-import Var
import Outputable
import Data.Array
import Type
import Name
import Module
-import Var
import Id
import FastString
import Outputable
initBuiltins pkg
= do mapM_ load dph_Orphans
- -- From dph-common:Data.Array.Parallel.Lifted.PArray
- parrayTyCon <- externalTyCon dph_PArray (fsLit "PArray")
- let [parrayDataCon] = tyConDataCons parrayTyCon
+ -- From dph-common:Data.Array.Parallel.PArray.PData
+ -- PData is a type family that maps an element type onto the type
+ -- we use to hold an array of those elements.
+ pdataTyCon <- externalTyCon dph_PArray_PData (fsLit "PData")
- pdataTyCon <- externalTyCon dph_PArray (fsLit "PData")
- paClass <- externalClass dph_PArray (fsLit "PA")
+ -- PR is a type class that holds the primitive operators we can
+ -- apply to array data. Its functions take arrays in terms of PData types.
+ prClass <- externalClass dph_PArray_PData (fsLit "PR")
+ let prTyCon = classTyCon prClass
+ [prDataCon] = tyConDataCons prTyCon
+
+
+ -- From dph-common:Data.Array.Parallel.PArray.PRepr
+ preprTyCon <- externalTyCon dph_PArray_PRepr (fsLit "PRepr")
+ paClass <- externalClass dph_PArray_PRepr (fsLit "PA")
let paTyCon = classTyCon paClass
[paDataCon] = tyConDataCons paTyCon
paPRSel = classSCSelId paClass 0
- preprTyCon <- externalTyCon dph_PArray (fsLit "PRepr")
- prClass <- externalClass dph_PArray (fsLit "PR")
- let prTyCon = classTyCon prClass
- [prDataCon] = tyConDataCons prTyCon
+ replicatePDVar <- externalVar dph_PArray_PRepr (fsLit "replicatePD")
+ emptyPDVar <- externalVar dph_PArray_PRepr (fsLit "emptyPD")
+ packByTagPDVar <- externalVar dph_PArray_PRepr (fsLit "packByTagPD")
+ combines <- mapM (externalVar dph_PArray_PRepr)
+ [mkFastString ("combine" ++ show i ++ "PD")
+ | i <- [2..mAX_DPH_COMBINE]]
+
+ let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
+
- closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
+ -- From dph-common:Data.Array.Parallel.PArray.Scalar
+ -- Scalar is the class of scalar values.
+ -- The dictionary contains functions to coerce U.Arrays of scalars
+ -- to and from the PData representation.
+ scalarClass <- externalClass dph_PArray_Scalar (fsLit "Scalar")
+
+
+ -- From dph-common:Data.Array.Parallel.Lifted.PArray
+ -- A PArray (Parallel Array) holds the array length and some array elements
+ -- represented by the PData type family.
+ parrayTyCon <- externalTyCon dph_PArray_Base (fsLit "PArray")
+ let [parrayDataCon] = tyConDataCons parrayTyCon
+
+ -- From dph-common:Data.Array.Parallel.PArray.Types
+ voidTyCon <- externalTyCon dph_PArray_Types (fsLit "Void")
+ voidVar <- externalVar dph_PArray_Types (fsLit "void")
+ fromVoidVar <- externalVar dph_PArray_Types (fsLit "fromVoid")
+ wrapTyCon <- externalTyCon dph_PArray_Types (fsLit "Wrap")
+ sum_tcs <- mapM (externalTyCon dph_PArray_Types) (numbered "Sum" 2 mAX_DPH_SUM)
+
+ -- from dph-common:Data.Array.Parallel.PArray.PDataInstances
+ pvoidVar <- externalVar dph_PArray_PDataInstances (fsLit "pvoid")
+ punitVar <- externalVar dph_PArray_PDataInstances (fsLit "punit")
+
+
+ closureTyCon <- externalTyCon dph_Closure (fsLit ":->")
- -- From dph-common:Data.Array.Parallel.Lifted.Repr
- voidTyCon <- externalTyCon dph_Repr (fsLit "Void")
- wrapTyCon <- externalTyCon dph_Repr (fsLit "Wrap")
-- From dph-common:Data.Array.Parallel.Lifted.Unboxed
sel_tys <- mapM (externalType dph_Unboxed)
sel_els <- mapM mk_elements
[(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]]
- sum_tcs <- mapM (externalTyCon dph_Repr)
- (numbered "Sum" 2 mAX_DPH_SUM)
let selTys = listArray (2, mAX_DPH_SUM) sel_tys
selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates
sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs
- voidVar <- externalVar dph_Repr (fsLit "void")
- pvoidVar <- externalVar dph_Repr (fsLit "pvoid")
- fromVoidVar <- externalVar dph_Repr (fsLit "fromVoid")
- punitVar <- externalVar dph_Repr (fsLit "punit")
+
closureVar <- externalVar dph_Closure (fsLit "closure")
applyVar <- externalVar dph_Closure (fsLit "$:")
liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure")
liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply")
- replicatePDVar <- externalVar dph_PArray (fsLit "replicatePD")
- emptyPDVar <- externalVar dph_PArray (fsLit "emptyPD")
- packByTagPDVar <- externalVar dph_PArray (fsLit "packByTagPD")
-
- combines <- mapM (externalVar dph_PArray)
- [mkFastString ("combine" ++ show i ++ "PD")
- | i <- [2..mAX_DPH_COMBINE]]
- let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines
- scalarClass <- externalClass dph_PArray (fsLit "Scalar")
scalar_map <- externalVar dph_Scalar (fsLit "scalar_map")
- scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith")
+ scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith")
scalar_zips <- mapM (externalVar dph_Scalar)
(numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
, liftingContext = liftingContext
}
where
- mods@(Modules {
- dph_PArray = dph_PArray
- , dph_Repr = dph_Repr
- , dph_Closure = dph_Closure
- , dph_Scalar = dph_Scalar
- , dph_Unboxed = dph_Unboxed
- })
+ -- Extract out all the modules we'll use.
+ -- These are the modules from the DPH base library that contain
+ -- the primitive array types and functions that vectorised code uses.
+ mods@(Modules
+ { dph_PArray_Base = dph_PArray_Base
+ , dph_PArray_Scalar = dph_PArray_Scalar
+ , dph_PArray_PRepr = dph_PArray_PRepr
+ , dph_PArray_PData = dph_PArray_PData
+ , dph_PArray_PDataInstances = dph_PArray_PDataInstances
+ , dph_PArray_Types = dph_PArray_Types
+ , dph_Closure = dph_Closure
+ , dph_Scalar = dph_Scalar
+ , dph_Unboxed = dph_Unboxed
+ })
= dph_Modules pkg
load get_mod = dsLoadModule doc mod
-- | Get the names of all buildin instance functions for the PA class.
initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
initBuiltinPAs (Builtins { dphModules = mods }) insts
- = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PA"))
+ = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PRepr mods) (fsLit "PA"))
-- | Get the names of all builtin instance functions for the PR class.
initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)]
initBuiltinPRs (Builtins { dphModules = mods }) insts
- = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PR"))
+ = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PData mods) (fsLit "PR"))
-- | Get the names of all DPH instance functions for this class.
-- | Ids of the modules that contain our DPH builtins.
data Modules
- = Modules
- { dph_PArray :: Module
- , dph_Repr :: Module
- , dph_Closure :: Module
- , dph_Unboxed :: Module
- , dph_Instances :: Module
- , dph_Combinators :: Module
- , dph_Scalar :: Module
- , dph_Prelude_PArr :: Module
- , dph_Prelude_Int :: Module
- , dph_Prelude_Word8 :: Module
- , dph_Prelude_Double :: Module
- , dph_Prelude_Bool :: Module
- , dph_Prelude_Tuple :: Module
- }
+ = Modules
+ { dph_PArray_Base :: Module
+ , dph_PArray_Scalar :: Module
+ , dph_PArray_ScalarInstances :: Module
+ , dph_PArray_PRepr :: Module
+ , dph_PArray_PReprInstances :: Module
+ , dph_PArray_PData :: Module
+ , dph_PArray_PDataInstances :: Module
+ , dph_PArray_Types :: Module
+
+ , dph_Closure :: Module
+ , dph_Unboxed :: Module
+ , dph_Combinators :: Module
+ , dph_Scalar :: Module
+
+ , dph_Prelude_Int :: Module
+ , dph_Prelude_Word8 :: Module
+ , dph_Prelude_Double :: Module
+ , dph_Prelude_Bool :: Module
+ , dph_Prelude_Tuple :: Module
+ }
-- | The locations of builtins in the current DPH library.
dph_Modules :: PackageId -> Modules
dph_Modules pkg
- = Modules
- { dph_PArray = mk (fsLit "Data.Array.Parallel.Lifted.PArray")
- , dph_Repr = mk (fsLit "Data.Array.Parallel.Lifted.Repr")
- , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
- , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
- , dph_Instances = mk (fsLit "Data.Array.Parallel.Lifted.Instances")
- , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators")
- , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar")
+ = Modules
+ { dph_PArray_Base = mk (fsLit "Data.Array.Parallel.PArray.Base")
+ , dph_PArray_Scalar = mk (fsLit "Data.Array.Parallel.PArray.Scalar")
+ , dph_PArray_ScalarInstances = mk (fsLit "Data.Array.Parallel.PArray.ScalarInstances")
+ , dph_PArray_PRepr = mk (fsLit "Data.Array.Parallel.PArray.PRepr")
+ , dph_PArray_PReprInstances = mk (fsLit "Data.Array.Parallel.PArray.PReprInstances")
+ , dph_PArray_PData = mk (fsLit "Data.Array.Parallel.PArray.PData")
+ , dph_PArray_PDataInstances = mk (fsLit "Data.Array.Parallel.PArray.PDataInstances")
+ , dph_PArray_Types = mk (fsLit "Data.Array.Parallel.PArray.Types")
+
+ , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure")
+ , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed")
+ , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators")
+ , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar")
- , dph_Prelude_PArr = mk (fsLit "Data.Array.Parallel.Prelude.Base.PArr")
- , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int")
- , dph_Prelude_Word8 = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8")
- , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double")
- , dph_Prelude_Bool = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool")
- , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple")
- }
- where mk = mkModule pkg . mkModuleNameFS
+ , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int")
+ , dph_Prelude_Word8 = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8")
+ , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double")
+ , dph_Prelude_Bool = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool")
+ , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple")
+ }
+ where mk = mkModule pkg . mkModuleNameFS
--- | Project out ids of modules that contain orphan instances that we need to load.
dph_Orphans :: [Modules -> Module]
-dph_Orphans = [dph_Repr, dph_Instances]
+dph_Orphans
+ = [ dph_PArray_Scalar
+ , dph_PArray_ScalarInstances
+ , dph_PArray_PReprInstances
+ , dph_PArray_PDataInstances
+ , dph_Scalar
+ ]
-> [( Module, FastString -- Maps the original variable to the one in the DPH
, Module, FastString)] -- packages that it should be rewritten to.
preludeVars (Modules { dph_Combinators = _dph_Combinators
- , dph_PArray = _dph_PArray
, dph_Prelude_Int = dph_Prelude_Int
, dph_Prelude_Word8 = dph_Prelude_Word8
, dph_Prelude_Double = dph_Prelude_Double
, dph_Prelude_Bool = dph_Prelude_Bool
- , dph_Prelude_PArr = _dph_Prelude_PArr
})
- -- Functions that work on whole PArrays, defined in GHC.PArr
- = [ {- mk gHC_PARR' (fsLit "mapP") dph_Combinators (fsLit "mapPA")
- , mk gHC_PARR' (fsLit "zipWithP") dph_Combinators (fsLit "zipWithPA")
- , mk gHC_PARR' (fsLit "zipP") dph_Combinators (fsLit "zipPA")
- , mk gHC_PARR' (fsLit "unzipP") dph_Combinators (fsLit "unzipPA")
- , mk gHC_PARR' (fsLit "filterP") dph_Combinators (fsLit "filterPA")
- , mk gHC_PARR' (fsLit "lengthP") dph_Combinators (fsLit "lengthPA")
- , mk gHC_PARR' (fsLit "replicateP") dph_Combinators (fsLit "replicatePA")
- , mk gHC_PARR' (fsLit "!:") dph_Combinators (fsLit "indexPA")
- , mk gHC_PARR' (fsLit "sliceP") dph_Combinators (fsLit "slicePA")
- , mk gHC_PARR' (fsLit "crossMapP") dph_Combinators (fsLit "crossMapPA")
- , mk gHC_PARR' (fsLit "singletonP") dph_Combinators (fsLit "singletonPA")
- , mk gHC_PARR' (fsLit "concatP") dph_Combinators (fsLit "concatPA")
- , mk gHC_PARR' (fsLit "+:+") dph_Combinators (fsLit "appPA")
- , mk gHC_PARR' (fsLit "emptyP") dph_PArray (fsLit "emptyPA")
-
+ = [
-- Map scalar functions to versions using closures.
- , -} mk' dph_Prelude_Int "div" "divV"
+ mk' dph_Prelude_Int "div" "divV"
, mk' dph_Prelude_Int "mod" "modV"
, mk' dph_Prelude_Int "sqrt" "sqrtV"
, mk' dph_Prelude_Int "enumFromToP" "enumFromToPA"
- -- , mk' dph_Prelude_Int "upToP" "upToPA"
]
++ vars_Ord dph_Prelude_Int
++ vars_Num dph_Prelude_Int
, mk gHC_CLASSES (fsLit "not") dph_Prelude_Bool (fsLit "notV")
, mk gHC_CLASSES (fsLit "&&") dph_Prelude_Bool (fsLit "andV")
, mk gHC_CLASSES (fsLit "||") dph_Prelude_Bool (fsLit "orV")
-
-{-
- -- FIXME: temporary
- , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA")
- , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA")
- , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA")
- , mk dph_Prelude_PArr (fsLit "combineP") dph_Combinators (fsLit "combine2PA")
- , mk dph_Prelude_PArr (fsLit "updateP") dph_Combinators (fsLit "updatePA")
- , mk dph_Prelude_PArr (fsLit "bpermuteP") dph_Combinators (fsLit "bpermutePA")
- , mk dph_Prelude_PArr (fsLit "indexedP") dph_Combinators (fsLit "indexedPA")
--} ]
+ ]
where
mk = (,,,)
mk' mod v v' = mk mod (fsLit v) mod (fsLit v')
scalars' = scalars `extendVarSet` var
is_scalar scalars (Cast e _coe) = is_scalar scalars e
is_scalar scalars (Note _ e ) = is_scalar scalars e
- is_scalar _scalars (Type _) = True
+ is_scalar _scalars (Type {}) = True
+ is_scalar _scalars (Coercion {}) = True
-- Result: (<is this binding group scalar>, scalars ++ variables bound in this group)
is_scalar_bind scalars (NonRec var e) = (is_scalar scalars e, scalars `extendVarSet` var)
import OccName
import Id
import MkId
-import Var
import NameEnv
import Unique
[] -- no stupid theta
rhs
rec_flag -- FIXME: is this ok?
- False -- FIXME: no generics
False -- not GADT syntax
NoParentTyCon
(Just $ mk_fam_inst pdata vect_tc)
import MkCore ( mkWildCase )
import TyCon
import Type
+import Kind
import BuildTyCl
import OccName
import Coercion
pdata_co <- mkBuiltinCo pdataTyCon
let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
- co = mkAppCoercion pdata_co
- . mkSymCoercion
- $ mkTyConApp repr_co ty_args
+ co = mkAppCo pdata_co
+ . mkSymCo
+ $ mkAxInstCo repr_co ty_args
scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg)
pdata_co <- mkBuiltinCo pdataTyCon
let Just repr_co = tyConFamilyCoercion_maybe prepr_tc
- co = mkAppCoercion pdata_co
- $ mkTyConApp repr_co var_tys
+ co = mkAppCo pdata_co
+ $ mkAxInstCo repr_co var_tys
scrut = mkCoerce co (Var arg)
[] -- no stupid theta.
rhs' -- new constructor defs.
rec_flag -- FIXME: is this ok?
- False -- FIXME: no generics
False -- not GADT syntax
NoParentTyCon
Nothing -- not a family instance
import TypeRep
import Type
import TyCon
-import Var
import Outputable
import Control.Monad
import Data.List
import CoreSyn
import CoreUtils
import Type
-import Var
import Control.Monad
collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
collectAnnTypeBinders expr = go [] expr
where
- go bs (_, AnnLam b e) | isTyCoVar b = go (b:bs) e
+ go bs (_, AnnLam b e) | isTyVar b = go (b:bs) e
go bs e = (reverse bs, e)
collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
mkBuiltinCo get_tc
= do
tc <- builtin get_tc
- return $ mkTyConApp tc []
+ return $ mkTyConAppCo tc []
mkVScrut :: VExpr -> VM (CoreExpr, CoreExpr, TyCon, [Type])
import CoreSyn
import Type
-import Var
import MkCore
import CoreUtils
import TyCon
import CoreUtils
import CoreUnfold
import Type
-import Var
import Id
import BasicTypes( Arity )
import FastString
paDictArgType :: TyVar -> VM (Maybe Type)
paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
where
- go ty k | Just k' <- kindView k = go ty k'
go ty (FunTy k1 k2)
= do
tv <- newTyVar (fsLit "a") k1
dict <- prDictOfReprType' rhs
pr_co <- mkBuiltinCo prTyCon
let Just arg_co = tyConFamilyCoercion_maybe prepr_tc
- let co = mkAppCoercion pr_co
- $ mkSymCoercion
- $ mkTyConApp arg_co prepr_args
+ let co = mkAppCo pr_co
+ $ mkSymCo
+ $ mkAxInstCo arg_co prepr_args
return $ mkCoerce co dict
| otherwise = cantVectorise "Invalid PRepr type instance" (ppr ty)
import Vectorise.Utils.PADict
import CoreSyn
import Type
-import Var
import FastString
import Control.Monad
import Vectorise.Type.Type
import CoreSyn
import Type
-import Var
import VarEnv
import Literal
import Id
AC_SUBST(ghc_ge_613)dnl
BOOTSTRAPPING_GHC_INFO_FIELD([CC_STAGE0],[C compiler command],['$(CC)'])
+ BOOTSTRAPPING_GHC_INFO_FIELD([AR_STAGE0],[ar command],['$(AR)'])
+ BOOTSTRAPPING_GHC_INFO_FIELD([AR_OPTS_STAGE0],[ar flags],['$(AR_OPTS)'])
+ BOOTSTRAPPING_GHC_INFO_FIELD([ArSupportsAtFile_STAGE0],[ar supports at file],['$(ArSupportsAtFile)'])
fi
dnl ** Must have GHC to build GHC, unless --enable-hc-boot is on
;;
esac
-# Sync this with cTargetArch in compiler/ghc.mk
checkArch() {
case $1 in
alpha|arm|hppa|hppa1_1|i386|ia64|m68k|mips|mipseb|mipsel|powerpc|powerpc64|rs6000|s390|sparc|sparc64|vax|x86_64)
# Verify that the installed (bootstrap) GHC is capable of generating
# code for the requested build platform.
-if test "$BuildPlatform" != "$bootstrap_target"
+if test "$BootingFromHc" = "NO"
then
- echo "This GHC (${WithGhc}) does not generate code for the build platform"
- echo " GHC target platform : $bootstrap_target"
- echo " Desired build platform : $BuildPlatform"
- exit 1
+ if test "$BuildPlatform" != "$bootstrap_target"
+ then
+ echo "This GHC (${WithGhc}) does not generate code for the build platform"
+ echo " GHC target platform : $bootstrap_target"
+ echo " Desired build platform : $BuildPlatform"
+ exit 1
+ fi
fi
echo "GHC build : $BuildPlatform"
FP_DOCBOOK_XSL
FP_PROG_DBLATEX
-FP_PROG_HSTAGS
-
dnl ** check for ghc-pkg command
FP_PROG_GHC_PKG
a short form…). You can get all of these at once
(<emphasis>lots</emphasis> of output) by using
<option>-v5</option>, or most of them with
- <option>-v4</option>. Some of the most useful ones
- are:</para>
+ <option>-v4</option>. You can prevent them from clogging up
+ your standard output by passing <option>-ddump-to-file</option>.
+ Some of the most useful ones are:</para>
<variablelist>
<varlistentry>
style.</para>
</listitem>
</varlistentry>
+ </variablelist>
+ </sect2>
+
+ <sect2 id="formatting dumps">
+ <title>Formatting dumps</title>
+
+ <indexterm><primary>formatting dumps</primary></indexterm>
+
+ <variablelist>
+ <varlistentry>
+ <term>
+ <option>-dppr-user-length</option>
+ <indexterm><primary><option>-dppr-user-length</option></primary></indexterm>
+ </term>
+ <listitem>
+ <para>In error messages, expressions are printed to a
+ certain “depth”, with subexpressions beyond the
+ depth replaced by ellipses. This flag sets the
+ depth. Its default value is 5.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
+ <option>-dppr-colsNNN</option>
+ <indexterm><primary><option>-dppr-colsNNN</option></primary></indexterm>
+ </term>
+ <listitem>
+ <para>Set the width of debugging output. Use this if your code is wrapping too much.
+ For example: <option>-dppr-cols200</option>.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
+ <option>-dppr-case-as-let</option>
+ <indexterm><primary><option>-dppr-case-as-let</option></primary></indexterm>
+ </term>
+ <listitem>
+ <para>Print single alternative case expressions as though they were strict
+ let expressions. This is helpful when your code does a lot of unboxing.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
+ <option>-dno-debug-output</option>
+ <indexterm><primary><option>-dno-debug-output</option></primary></indexterm>
+ </term>
+ <listitem>
+ <para>Suppress any unsolicited debugging output. When GHC
+ has been built with the <literal>DEBUG</literal> option it
+ occasionally emits debug output of interest to developers.
+ The extra output can confuse the testing framework and
+ cause bogus test failures, so this flag is provided to
+ turn it off.</para>
+ </listitem>
+ </varlistentry>
+ </variablelist>
+
+ </sect2>
+
+ <sect2 id="supression">
+ <title>Suppressing unwanted information</title>
+
+ <indexterm><primary>suppression</primary></indexterm>
+
+ Core dumps contain a large amount of information. Depending on what you are doing, not all of it will be useful.
+ Use these flags to suppress the parts that you are not interested in.
+
+ <variablelist>
+ <varlistentry>
+ <term>
+ <option>-dsuppress-all</option>
+ <indexterm><primary><option>-dsuppress-all</option></primary></indexterm>
+ </term>
+ <listitem>
+ <para>Suppress everything that can be suppressed, except for unique ids as this often
+ makes the printout ambiguous. If you just want to see the overall structure of
+ the code, then start here.</para>
+ </listitem>
+ </varlistentry>
<varlistentry>
<term>
<indexterm><primary><option>-dsuppress-uniques</option></primary></indexterm>
</term>
<listitem>
- <para>Suppress the printing of uniques in debugging output. This may make
+ <para>Suppress the printing of uniques. This may make
the printout ambiguous (e.g. unclear where an occurrence of 'x' is bound), but
it makes the output of two compiler runs have many fewer gratuitous differences,
so you can realistically apply <command>diff</command>. Once <command>diff</command>
<varlistentry>
<term>
- <option>-dsuppress-coercions</option>
- <indexterm><primary><option>-dsuppress-coercions</option></primary></indexterm>
+ <option>-dsuppress-idinfo</option>
+ <indexterm><primary><option>-dsuppress-idinfo</option></primary></indexterm>
</term>
<listitem>
- <para>Suppress the printing of coercions in Core dumps to make them
-shorter.</para>
+ <para>Suppress extended information about identifiers where they are bound. This includes
+ strictness information and inliner templates. Using this flag can cut the size
+ of the core dump in half, due to the lack of inliner templates</para>
</listitem>
</varlistentry>
<indexterm><primary><option>-dsuppress-module-prefixes</option></primary></indexterm>
</term>
<listitem>
- <para>Suppress the printing of module qualification prefixes in Core dumps to make them easier to read.</para>
+ <para>Suppress the printing of module qualification prefixes.
+ This is the <constant>Data.List</constant> in <constant>Data.List.length</constant>.</para>
</listitem>
</varlistentry>
<varlistentry>
<term>
- <option>-dppr-user-length</option>
- <indexterm><primary><option>-dppr-user-length</option></primary></indexterm>
+ <option>-dsuppress-type-signatures</option>
+ <indexterm><primary><option>-dsuppress-type-signatures</option></primary></indexterm>
</term>
<listitem>
- <para>In error messages, expressions are printed to a
- certain “depth”, with subexpressions beyond the
- depth replaced by ellipses. This flag sets the
- depth. Its default value is 5.</para>
+ <para>Suppress the printing of type signatures.</para>
</listitem>
</varlistentry>
<varlistentry>
- <term>
- <option>-dno-debug-output</option>
- <indexterm><primary><option>-dno-debug-output</option></primary></indexterm>
+ <term>
+ <option>-dsuppress-type-applications</option>
+ <indexterm><primary><option>-dsuppress-type-applications</option></primary></indexterm>
</term>
- <listitem>
- <para>Suppress any unsolicited debugging output. When GHC
- has been built with the <literal>DEBUG</literal> option it
- occasionally emits debug output of interest to developers.
- The extra output can confuse the testing framework and
- cause bogus test failures, so this flag is provided to
- turn it off.</para>
- </listitem>
+ <listitem>
+ <para>Suppress the printing of type applications.</para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
+ <option>-dsuppress-coercions</option>
+ <indexterm><primary><option>-dsuppress-coercions</option></primary></indexterm>
+ </term>
+ <listitem>
+ <para>Suppress the printing of type coercions.</para>
+ </listitem>
</varlistentry>
</variablelist>
</sect2>
<entry>mode</entry>
<entry>-</entry>
</row>
- <row>
- <entry><option>-n</option></entry>
- <entry>do a dry run</entry>
- <entry>dynamic</entry>
- <entry>-</entry>
- </row>
- <row>
+ <row>
<entry><option>-v</option></entry>
<entry>verbose mode (equivalent to <option>-v3</option>)</entry>
<entry>dynamic</entry>
</row>
<row>
<entry><option>-XGenerics</option></entry>
- <entry>Enable <link linkend="generic-classes">generic classes</link></entry>
+ <entry>Deprecated, does nothing. No longer enables <link linkend="generic-classes">generic classes</link>.
+ See also GHC's support for
+ <link linkend="generic-programming">generic programming</link>.</entry>
<entry>dynamic</entry>
<entry><option>-XNoGenerics</option></entry>
</row>
<entry>dynamic</entry>
<entry><option>-XNoTransformListComp</option></entry>
</row>
+ <row>
+ <entry><option>-XMonadComprehensions</option></entry>
+ <entry>Enable <link linkend="monad-comprehensions">monad comprehensions</link>.</entry>
+ <entry>dynamic</entry>
+ <entry><option>-XNoMonadComprehensions</option></entry>
+ </row>
<row>
<entry><option>-XUnliftedFFITypes</option></entry>
<entry>Enable unlifted FFI types.</entry>
<entry><option>-XNoDeriveDataTypeable</option></entry>
</row>
<row>
+ <entry><option>-XDeriveGeneric</option></entry>
+ <entry>Enable <link linkend="deriving-typeable">deriving for the Generic class</link>.</entry>
+ <entry>dynamic</entry>
+ <entry><option>-XNoDeriveGeneric</option></entry>
+ </row>
+ <row>
<entry><option>-XGeneralizedNewtypeDeriving</option></entry>
<entry>Enable <link linkend="newtype-deriving">newtype deriving</link>.</entry>
<entry>dynamic</entry>
<entry><option>-XNoConstrainedClassMethods</option></entry>
</row>
<row>
+ <entry><option>-XDefaultSignatures</option></entry>
+ <entry>Enable <link linkend="class-default-signatures">default signatures</link>.</entry>
+ <entry>dynamic</entry>
+ <entry><option>-XNoDefaultSignatures</option></entry>
+ </row>
+ <row>
<entry><option>-XMultiParamTypeClasses</option></entry>
<entry>Enable <link linkend="multi-param-type-classes">multi parameter type classes</link>.</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
+ <entry><option>-ddump-to-file</option></entry>
+ <entry>Dump to files instead of stdout</entry>
+ <entry>dynamic</entry>
+ <entry>-</entry>
+ </row>
+ <row>
<entry><option>-ddump-asm</option></entry>
<entry>Dump assembly</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
+ <entry><option>-dppr-noprags</option></entry>
+ <entry>Don't output pragma info in dumps</entry>
+ <entry>static</entry>
+ <entry>-</entry>
+ </row>
+ <row>
+ <entry><option>-dppr-user-length</option></entry>
+ <entry>Set the depth for printing expressions in error msgs</entry>
+ <entry>static</entry>
+ <entry>-</entry>
+ </row>
+ <row>
+ <entry><option>-dppr-colsNNN</option></entry>
+ <entry>Set the width of debugging output. For example <option>-dppr-cols200</option></entry>
+ <entry>static</entry>
+ <entry>-</entry>
+ </row>
+ <row>
+ <entry><option>-dppr-case-as-let</option></entry>
+ <entry>Print single alternative case expressions as strict lets.</entry>
+ <entry>static</entry>
+ <entry>-</entry>
+ </row>
+ <row>
+ <entry><option>-dsuppress-all</option></entry>
+ <entry>In core dumps, suppress everything that is suppressable.</entry>
+ <entry>static</entry>
+ <entry>-</entry>
+ </row>
+ <row>
<entry><option>-dsuppress-uniques</option></entry>
- <entry>Suppress the printing of uniques in debug output (easier to use <command>diff</command>.</entry>
+ <entry>Suppress the printing of uniques in debug output (easier to use <command>diff</command>)</entry>
<entry>static</entry>
<entry>-</entry>
</row>
<row>
- <entry><option>-dsuppress-coercions</option></entry>
- <entry>Suppress the printing of coercions in Core dumps to make them shorter.</entry>
+ <entry><option>-dsuppress-idinfo</option></entry>
+ <entry>Suppress extended information about identifiers where they are bound</entry>
<entry>static</entry>
<entry>-</entry>
</row>
<row>
<entry><option>-dsuppress-module-prefixes</option></entry>
- <entry>Suppress the printing of module qualification prefixes in Core dumps to make them easier to read.</entry>
+ <entry>Suppress the printing of module qualification prefixes</entry>
<entry>static</entry>
<entry>-</entry>
</row>
<row>
- <entry><option>-dppr-noprags</option></entry>
- <entry>Don't output pragma info in dumps</entry>
+ <entry><option>-dsuppress-type-signatures</option></entry>
+ <entry>Suppress type signatures</entry>
<entry>static</entry>
<entry>-</entry>
</row>
<row>
- <entry><option>-dppr-user-length</option></entry>
- <entry>Set the depth for printing expressions in error msgs</entry>
+ <entry><option>-dsuppress-type-applications</option></entry>
+ <entry>Suppress type applications</entry>
+ <entry>static</entry>
+ <entry>-</entry>
+ </row>
+ <row>
+ <entry><option>-dsuppress-coercions</option></entry>
+ <entry>Suppress the printing of coercions in Core dumps to make them shorter</entry>
<entry>static</entry>
<entry>-</entry>
</row>
</para>
</sect2>
+ <!-- ===================== MONAD COMPREHENSIONS ===================== -->
+
+<sect2 id="monad-comprehensions">
+ <title>Monad comprehensions</title>
+ <indexterm><primary>monad comprehensions</primary></indexterm>
+
+ <para>
+ Monad comprehesions generalise the list comprehension notation,
+ including parallel comprehensions
+ (<xref linkend="parallel-list-comprehensions"/>) and
+ transform comprenensions (<xref linkend="generalised-list-comprehensions"/>)
+ to work for any monad.
+ </para>
+
+ <para>Monad comprehensions support:</para>
+
+ <itemizedlist>
+ <listitem>
+ <para>
+ Bindings:
+ </para>
+
+<programlisting>
+[ x + y | x <- Just 1, y <- Just 2 ]
+</programlisting>
+
+ <para>
+ Bindings are translated with the <literal>(>>=)</literal> and
+ <literal>return</literal> functions to the usual do-notation:
+ </para>
+
+<programlisting>
+do x <- Just 1
+ y <- Just 2
+ return (x+y)
+</programlisting>
+
+ </listitem>
+ <listitem>
+ <para>
+ Guards:
+ </para>
+
+<programlisting>
+[ x | x <- [1..10], x <= 5 ]
+</programlisting>
+
+ <para>
+ Guards are translated with the <literal>guard</literal> function,
+ which requires a <literal>MonadPlus</literal> instance:
+ </para>
+
+<programlisting>
+do x <- [1..10]
+ guard (x <= 5)
+ return x
+</programlisting>
+
+ </listitem>
+ <listitem>
+ <para>
+ Transform statements (as with <literal>-XTransformListComp</literal>):
+ </para>
+
+<programlisting>
+[ x+y | x <- [1..10], y <- [1..x], then take 2 ]
+</programlisting>
+
+ <para>
+ This translates to:
+ </para>
+
+<programlisting>
+do (x,y) <- take 2 (do x <- [1..10]
+ y <- [1..x]
+ return (x,y))
+ return (x+y)
+</programlisting>
+
+ </listitem>
+ <listitem>
+ <para>
+ Group statements (as with <literal>-XTransformListComp</literal>):
+ </para>
+
+<programlisting>
+[ x | x <- [1,1,2,2,3], then group by x ]
+[ x | x <- [1,1,2,2,3], then group by x using GHC.Exts.groupWith ]
+[ x | x <- [1,1,2,2,3], then group using myGroup ]
+</programlisting>
+
+ <para>
+ The basic <literal>then group by e</literal> statement is
+ translated using the <literal>mgroupWith</literal> function, which
+ requires a <literal>MonadGroup</literal> instance, defined in
+ <ulink url="&libraryBaseLocation;/Control-Monad-Group.html"><literal>Control.Monad.Group</literal></ulink>:
+ </para>
+
+<programlisting>
+do x <- mgroupWith (do x <- [1,1,2,2,3]
+ return x)
+ return x
+</programlisting>
+
+ <para>
+ Note that the type of <literal>x</literal> is changed by the
+ grouping statement.
+ </para>
+
+ <para>
+ The grouping function can also be defined with the
+ <literal>using</literal> keyword.
+ </para>
+
+ </listitem>
+ <listitem>
+ <para>
+ Parallel statements (as with <literal>-XParallelListComp</literal>):
+ </para>
+
+<programlisting>
+[ (x+y) | x <- [1..10]
+ | y <- [11..20]
+ ]
+</programlisting>
+
+ <para>
+ Parallel statements are translated using the
+ <literal>mzip</literal> function, which requires a
+ <literal>MonadZip</literal> instance defined in
+ <ulink url="&libraryBaseLocation;/Control-Monad-Zip.html"><literal>Control.Monad.Zip</literal></ulink>:
+ </para>
+
+<programlisting>
+do (x,y) <- mzip (do x <- [1..10]
+ return x)
+ (do y <- [11..20]
+ return y)
+ return (x+y)
+</programlisting>
+
+ </listitem>
+ </itemizedlist>
+
+ <para>
+ All these features are enabled by default if the
+ <literal>MonadComprehensions</literal> extension is enabled. The types
+ and more detailed examples on how to use comprehensions are explained
+ in the previous chapters <xref
+ linkend="generalised-list-comprehensions"/> and <xref
+ linkend="parallel-list-comprehensions"/>. In general you just have
+ to replace the type <literal>[a]</literal> with the type
+ <literal>Monad m => m a</literal> for monad comprehensions.
+ </para>
+
+ <para>
+ Note: Even though most of these examples are using the list monad,
+ monad comprehensions work for any monad.
+ The <literal>base</literal> package offers all necessary instances for
+ lists, which make <literal>MonadComprehensions</literal> backward
+ compatible to built-in, transform and parallel list comprehensions.
+ </para>
+<para> More formally, the desugaring is as follows. We write <literal>D[ e | Q]</literal>
+to mean the desugaring of the monad comprehension <literal>[ e | Q]</literal>:
+<programlisting>
+Expressions: e
+Declarations: d
+Lists of qualifiers: Q,R,S
+
+-- Basic forms
+D[ e | ] = return e
+D[ e | p <- e, Q ] = e >>= \p -> D[ e | Q ]
+D[ e | e, Q ] = guard e >> \p -> D[ e | Q ]
+D[ e | let d, Q ] = let d in D[ e | Q ]
+
+-- Parallel comprehensions (iterate for multiple parallel branches)
+D[ e | (Q | R), S ] = mzip D[ Qv | Q ] D[ Rv | R ] >>= \(Qv,Rv) -> D[ e | S ]
+
+-- Transform comprehensions
+D[ e | Q then f, R ] = f D[ Qv | Q ] >>= \Qv -> D[ e | R ]
+
+D[ e | Q then f by b, R ] = f b D[ Qv | Q ] >>= \Qv -> D[ e | R ]
+
+D[ e | Q then group using f, R ] = f D[ Qv | Q ] >>= \ys ->
+ case (fmap selQv1 ys, ..., fmap selQvn ys) of
+ Qv -> D[ e | R ]
+
+D[ e | Q then group by b using f, R ] = f b D[ Qv | Q ] >>= \ys ->
+ case (fmap selQv1 ys, ..., fmap selQvn ys) of
+ Qv -> D[ e | R ]
+
+where Qv is the tuple of variables bound by Q (and used subsequently)
+ selQvi is a selector mapping Qv to the ith component of Qv
+
+Operator Standard binding Expected type
+--------------------------------------------------------------------
+return GHC.Base t1 -> m t2
+(>>=) GHC.Base m1 t1 -> (t2 -> m2 t3) -> m3 t3
+(>>) GHC.Base m1 t1 -> m2 t2 -> m3 t3
+guard Control.Monad t1 -> m t2
+fmap GHC.Base forall a b. (a->b) -> n a -> n b
+mgroupWith Control.Monad.Group forall a. (a -> t) -> m1 a -> m2 (n a)
+mzip Control.Monad.Zip forall a b. m a -> m b -> m (a,b)
+</programlisting>
+The comprehension should typecheck when its desugaring would typecheck.
+</para>
+<para>
+Monad comprehensions support rebindable syntax (<xref linkend="rebindable-syntax"/>).
+Without rebindable
+syntax, the operators from the "standard binding" module are used; with
+rebindable syntax, the operators are looked up in the current lexical scope.
+For example, parallel comprehensions will be typechecked and desugared
+using whatever "<literal>mzip</literal>" is in scope.
+</para>
+<para>
+The rebindable operators must have the "Expected type" given in the
+table above. These types are surprisingly general. For example, you can
+use a bind operator with the type
+<programlisting>
+(>>=) :: T x y a -> (a -> T y z b) -> T x z b
+</programlisting>
+In the case of transform comprehensions, notice that the groups are
+parameterised over some arbitrary type <literal>n</literal> (provided it
+has an <literal>fmap</literal>, as well as
+the comprehension being over an arbitrary monad.
+</para>
+</sect2>
+
<!-- ===================== REBINDABLE SYNTAX =================== -->
<sect2 id="rebindable-syntax">
</para>
</listitem>
+<listitem><para> With <option>-XDeriveGeneric</option>, you can derive
+instances of the class <literal>Generic</literal>, defined in
+<literal>GHC.Generics</literal>. You can use these to define generic functions,
+as described in <xref linkend="generic-programming"/>.
+</para></listitem>
+
<listitem><para> With <option>-XDeriveFunctor</option>, you can derive instances of
the class <literal>Functor</literal>,
defined in <literal>GHC.Base</literal>.
</sect3>
+
+
+<sect3 id="class-default-signatures">
+<title>Default signatures</title>
+
+<para>
+Haskell 98 allows you to define a default implementation when declaring a class:
+<programlisting>
+ class Enum a where
+ enum :: [a]
+ enum = []
+</programlisting>
+The type of the <literal>enum</literal> method is <literal>[a]</literal>, and
+this is also the type of the default method. You can lift this restriction
+and give another type to the default method using the flag
+<option>-XDefaultSignatures</option>. For instance, if you have written a
+generic implementation of enumeration in a class <literal>GEnum</literal>
+with method <literal>genum</literal> in terms of <literal>GHC.Generics</literal>,
+you can specify a default method that uses that generic implementation:
+<programlisting>
+ class Enum a where
+ enum :: [a]
+ default enum :: (Generic a, GEnum (Rep a)) => [a]
+ enum = map to genum
+</programlisting>
+We reuse the keyword <literal>default</literal> to signal that a signature
+applies to the default method only; when defining instances of the
+<literal>Enum</literal> class, the original type <literal>[a]</literal> of
+<literal>enum</literal> still applies. When giving an empty instance, however,
+the default implementation <literal>map to0 genum</literal> is filled-in,
+and type-checked with the type
+<literal>(Generic a, GEnum (Rep a)) => [a]</literal>.
+</para>
+
+<para>
+We use default signatures to simplify generic programming in GHC
+(<xref linkend="generic-programming"/>).
+</para>
+
+
+</sect3>
</sect2>
<sect2 id="functional-dependencies">
restrains the strictness analyser.
</para></listitem>
<listitem><para>
-<ulink url="&libraryGhcPrimLocation;/GHC-Prim.html#v%3AunsafeCoerce%23"><literal>lazy</literal></ulink>
+<ulink url="&libraryGhcPrimLocation;/GHC-Prim.html#v%3AunsafeCoerce%23"><literal>unsafeCoerce#</literal></ulink>
allows you to fool the type checker.
</para></listitem>
</itemizedlist>
<title>Generic classes</title>
<para>
-The ideas behind this extension are described in detail in "Derivable type classes",
-Ralf Hinze and Simon Peyton Jones, Haskell Workshop, Montreal Sept 2000, pp94-105.
-An example will give the idea:
+GHC used to have an implementation of generic classes as defined in the paper
+"Derivable type classes", Ralf Hinze and Simon Peyton Jones, Haskell Workshop,
+Montreal Sept 2000, pp94-105. These have been removed and replaced by the more
+general <link linkend="generic-programming">support for generic programming</link>.
</para>
-<programlisting>
- import Data.Generics
-
- class Bin a where
- toBin :: a -> [Int]
- fromBin :: [Int] -> (a, [Int])
-
- toBin {| Unit |} Unit = []
- toBin {| a :+: b |} (Inl x) = 0 : toBin x
- toBin {| a :+: b |} (Inr y) = 1 : toBin y
- toBin {| a :*: b |} (x :*: y) = toBin x ++ toBin y
-
- fromBin {| Unit |} bs = (Unit, bs)
- fromBin {| a :+: b |} (0:bs) = (Inl x, bs') where (x,bs') = fromBin bs
- fromBin {| a :+: b |} (1:bs) = (Inr y, bs') where (y,bs') = fromBin bs
- fromBin {| a :*: b |} bs = (x :*: y, bs'') where (x,bs' ) = fromBin bs
- (y,bs'') = fromBin bs'
-</programlisting>
-<para>
-This class declaration explains how <literal>toBin</literal> and <literal>fromBin</literal>
-work for arbitrary data types. They do so by giving cases for unit, product, and sum,
-which are defined thus in the library module <literal>Data.Generics</literal>:
-</para>
-<programlisting>
- data Unit = Unit
- data a :+: b = Inl a | Inr b
- data a :*: b = a :*: b
-</programlisting>
-<para>
-Now you can make a data type into an instance of Bin like this:
-<programlisting>
- instance (Bin a, Bin b) => Bin (a,b)
- instance Bin a => Bin [a]
-</programlisting>
-That is, just leave off the "where" clause. Of course, you can put in the
-where clause and over-ride whichever methods you please.
-</para>
+</sect1>
- <sect2>
- <title> Using generics </title>
- <para>To use generics you need to</para>
- <itemizedlist>
- <listitem>
- <para>
- Use the flags <option>-XGenerics</option> (to enable the
- extra syntax and generate extra per-data-type code),
- and <option>-package syb</option> (to make the
- <literal>Data.Generics</literal> module available.
- </para>
- </listitem>
- <listitem>
- <para>Import the module <literal>Data.Generics</literal> from the
- <literal>syb</literal> package. This import brings into
- scope the data types <literal>Unit</literal>,
- <literal>:*:</literal>, and <literal>:+:</literal>. (You
- don't need this import if you don't mention these types
- explicitly; for example, if you are simply giving instance
- declarations.)</para>
- </listitem>
- </itemizedlist>
- </sect2>
-<sect2> <title> Changes wrt the paper </title>
-<para>
-Note that the type constructors <literal>:+:</literal> and <literal>:*:</literal>
-can be written infix (indeed, you can now use
-any operator starting in a colon as an infix type constructor). Also note that
-the type constructors are not exactly as in the paper (Unit instead of 1, etc).
-Finally, note that the syntax of the type patterns in the class declaration
-uses "<literal>{|</literal>" and "<literal>|}</literal>" brackets; curly braces
-alone would ambiguous when they appear on right hand sides (an extension we
-anticipate wanting).
-</para>
-</sect2>
+<sect1 id="generic-programming">
+<title>Generic programming</title>
-<sect2> <title>Terminology and restrictions</title>
<para>
-Terminology. A "generic default method" in a class declaration
-is one that is defined using type patterns as above.
-A "polymorphic default method" is a default method defined as in Haskell 98.
-A "generic class declaration" is a class declaration with at least one
-generic default method.
+Using a combination of <option>-XDeriveGeneric</option>
+(<xref linkend="deriving-typeable"/>) and
+<option>-XDefaultSignatures</option> (<xref linkend="class-default-signatures"/>),
+you can easily do datatype-generic
+programming using the <literal>GHC.Generics</literal> framework. This section
+gives a very brief overview of how to do it. For more detail please refer to the
+<ulink url="http://www.haskell.org/haskellwiki/Generics">HaskellWiki page</ulink>
+or the original paper:
</para>
-<para>
-Restrictions:
<itemizedlist>
<listitem>
<para>
-Alas, we do not yet implement the stuff about constructor names and
-field labels.
+José Pedro Magalhães, Atze Dijkstra, Johan Jeuring, and Andres Löh.
+<ulink url="http://dreixel.net/research/pdf/gdmh.pdf">
+ A generic deriving mechanism for Haskell</ulink>.
+<citetitle>Proceedings of the third ACM Haskell symposium on Haskell</citetitle>
+(Haskell'2010), pp. 37-48, ACM, 2010.
</para>
</listitem>
+</itemizedlist>
-<listitem>
-<para>
-A generic class can have only one parameter; you can't have a generic
-multi-parameter class.
-</para>
-</listitem>
+<emphasis>Note</emphasis>: the current support for generic programming in GHC
+is preliminary. In particular, we only allow deriving instances for the
+<literal>Generic</literal> class. Support for deriving
+<literal>Generic1</literal> (and thus enabling generic functions of kind
+<literal>* -> *</literal> such as <literal>fmap</literal>) will come at a
+later stage.
-<listitem>
-<para>
-A default method must be defined entirely using type patterns, or entirely
-without. So this is illegal:
-<programlisting>
- class Foo a where
- op :: a -> (a, Bool)
- op {| Unit |} Unit = (Unit, True)
- op x = (x, False)
-</programlisting>
-However it is perfectly OK for some methods of a generic class to have
-generic default methods and others to have polymorphic default methods.
-</para>
-</listitem>
-<listitem>
-<para>
-The type variable(s) in the type pattern for a generic method declaration
-scope over the right hand side. So this is legal (note the use of the type variable ``p'' in a type signature on the right hand side:
-<programlisting>
- class Foo a where
- op :: a -> Bool
- op {| p :*: q |} (x :*: y) = op (x :: p)
- ...
-</programlisting>
-</para>
-</listitem>
+<sect2>
+<title>Deriving representations</title>
-<listitem>
<para>
-The type patterns in a generic default method must take one of the forms:
-<programlisting>
- a :+: b
- a :*: b
- Unit
-</programlisting>
-where "a" and "b" are type variables. Furthermore, all the type patterns for
-a single type constructor (<literal>:*:</literal>, say) must be identical; they
-must use the same type variables. So this is illegal:
+The first thing we need is generic representations. The
+<literal>GHC.Generics</literal> module defines a couple of primitive types
+that can be used to represent most Haskell datatypes:
+
<programlisting>
- class Foo a where
- op :: a -> Bool
- op {| a :+: b |} (Inl x) = True
- op {| p :+: q |} (Inr y) = False
+-- | Unit: used for constructors without arguments
+data U1 p = U1
+
+-- | Constants, additional parameters and recursion of kind *
+newtype K1 i c p = K1 { unK1 :: c }
+
+-- | Meta-information (constructor names, etc.)
+newtype M1 i c f p = M1 { unM1 :: f p }
+
+-- | Sums: encode choice between constructors
+infixr 5 :+:
+data (:+:) f g p = L1 (f p) | R1 (g p)
+
+-- | Products: encode multiple arguments to constructors
+infixr 6 :*:
+data (:*:) f g p = f p :*: g p
+</programlisting>
+
+For example, a user-defined datatype of trees <literal>data UserTree a = Node a
+(UserTree a) (UserTree a) | Leaf</literal> gets the following representation:
+
+<programlisting>
+instance Generic (UserTree a) where
+ -- Representation type
+ type Rep (UserTree a) =
+ M1 D D1UserTree (
+ M1 C C1_0UserTree (
+ M1 S NoSelector (K1 P a)
+ :*: M1 S NoSelector (K1 R (UserTree a))
+ :*: M1 S NoSelector (K1 R (UserTree a)))
+ :+: M1 C C1_1UserTree U1)
+
+ -- Conversion functions
+ from (Node x l r) = M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r))))
+ from Leaf = M1 (R1 (M1 U1))
+ to (M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r))))) = Node x l r
+ to (M1 (R1 (M1 U1))) = Leaf
+
+-- Meta-information
+data D1UserTree
+data C1_0UserTree
+data C1_1UserTree
+
+instance Datatype D1UserTree where
+ datatypeName _ = "UserTree"
+ moduleName _ = "Main"
+
+instance Constructor C1_0UserTree where
+ conName _ = "Node"
+
+instance Constructor C1_1UserTree where
+ conName _ = "Leaf"
</programlisting>
-The type patterns must be identical, even in equations for different methods of the class.
-So this too is illegal:
-<programlisting>
- class Foo a where
- op1 :: a -> Bool
- op1 {| a :*: b |} (x :*: y) = True
- op2 :: a -> Bool
- op2 {| p :*: q |} (x :*: y) = False
-</programlisting>
-(The reason for this restriction is that we gather all the equations for a particular type constructor
-into a single generic instance declaration.)
+This representation is generated automatically if a
+<literal>deriving Generic</literal> clause is attached to the datatype.
+<link linkend="stand-alone-deriving">Standalone deriving</link> can also be
+used.
</para>
-</listitem>
+</sect2>
-<listitem>
-<para>
-A generic method declaration must give a case for each of the three type constructors.
-</para>
-</listitem>
+<sect2>
+<title>Writing generic functions</title>
-<listitem>
<para>
-The type for a generic method can be built only from:
- <itemizedlist>
- <listitem> <para> Function arrows </para> </listitem>
- <listitem> <para> Type variables </para> </listitem>
- <listitem> <para> Tuples </para> </listitem>
- <listitem> <para> Arbitrary types not involving type variables </para> </listitem>
- </itemizedlist>
-Here are some example type signatures for generic methods:
+A generic function is defined by creating a class and giving instances for
+each of the representation types of <literal>GHC.Generics</literal>. As an
+example we show generic serialization:
<programlisting>
- op1 :: a -> Bool
- op2 :: Bool -> (a,Bool)
- op3 :: [Int] -> a -> a
- op4 :: [a] -> Bool
-</programlisting>
-Here, op1, op2, op3 are OK, but op4 is rejected, because it has a type variable
-inside a list.
-</para>
-<para>
-This restriction is an implementation restriction: we just haven't got around to
-implementing the necessary bidirectional maps over arbitrary type constructors.
-It would be relatively easy to add specific type constructors, such as Maybe and list,
-to the ones that are allowed.</para>
-</listitem>
+data Bin = O | I
-<listitem>
-<para>
-In an instance declaration for a generic class, the idea is that the compiler
-will fill in the methods for you, based on the generic templates. However it can only
-do so if
- <itemizedlist>
- <listitem>
- <para>
- The instance type is simple (a type constructor applied to type variables, as in Haskell 98).
- </para>
- </listitem>
- <listitem>
- <para>
- No constructor of the instance type has unboxed fields.
- </para>
- </listitem>
- </itemizedlist>
-(Of course, these things can only arise if you are already using GHC extensions.)
-However, you can still give an instance declarations for types which break these rules,
-provided you give explicit code to override any generic default methods.
-</para>
-</listitem>
+class GSerialize f where
+ gput :: f a -> [Bin]
-</itemizedlist>
-</para>
+instance GSerialize U1 where
+ gput U1 = []
-<para>
-The option <option>-ddump-deriv</option> dumps incomprehensible stuff giving details of
-what the compiler does with generic declarations.
-</para>
+instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where
+ gput (a :*: b) = gput a ++ gput b
+
+instance (GSerialize a, GSerialize b) => GSerialize (a :+: b) where
+ gput (L1 x) = O : gput x
+ gput (R1 x) = I : gput x
+
+instance (GSerialize a) => GSerialize (M1 i c a) where
+ gput (M1 x) = gput x
+instance (Serialize a) => GSerialize (K1 i c a) where
+ gput (K1 x) = put x
+</programlisting>
+
+Typically this class will not be exported, as it only makes sense to have
+instances for the representation types.
+</para>
</sect2>
-<sect2> <title> Another example </title>
+<sect2>
+<title>Generic defaults</title>
+
<para>
-Just to finish with, here's another example I rather like:
+The only thing left to do now is to define a "front-end" class, which is
+exposed to the user:
<programlisting>
- class Tag a where
- nCons :: a -> Int
- nCons {| Unit |} _ = 1
- nCons {| a :*: b |} _ = 1
- nCons {| a :+: b |} _ = nCons (bot::a) + nCons (bot::b)
+class Serialize a where
+ put :: a -> [Bin]
- tag :: a -> Int
- tag {| Unit |} _ = 1
- tag {| a :*: b |} _ = 1
- tag {| a :+: b |} (Inl x) = tag x
- tag {| a :+: b |} (Inr y) = nCons (bot::a) + tag y
+ default put :: (Generic a, GSerialize (Rep a)) => a -> [Bit]
+ put = gput . from
</programlisting>
+Here we use a <link linkend="class-default-signatures">default signature</link>
+to specify that the user does not have to provide an implementation for
+<literal>put</literal>, as long as there is a <literal>Generic</literal>
+instance for the type to instantiate. For the <literal>UserTree</literal> type,
+for instance, the user can just write:
+
+<programlisting>
+instance (Serialize a) => Serialize (UserTree a)
+</programlisting>
+
+The default method for <literal>put</literal> is then used, corresponding to the
+generic implementation of serialization.
</para>
</sect2>
+
</sect1>
+
<sect1 id="monomorphism">
<title>Control over monomorphism</title>
</para>
<para>
- In GHC version 6.12 building shared libraries is supported for Linux on
- x86 and x86-64 architectures and there is partial support on Windows (see
- <xref linkend="win32-dlls"/>). The crucial difference in support on
- Windows is that it is not currently possible to build each Haskell
- package as a separate DLL, it is only possible to link an entire Haskell
- program as one massive DLL.
+ In GHC version 6.12 building shared libraries is supported for Linux (on
+ x86 and x86-64 architectures). GHC version 7.0 adds support on Windows
+ (see <xref linkend="win32-dlls"/>), FreeBSD and OpenBSD (x86 and x86-64),
+ Solaris (x86) and Mac OS X (x86 and PowerPC).
</para>
<para>
that it can be linked against shared library versions of Haskell
packages (such as base). The second is when linking, to link against
the shared versions of the packages' libraries rather than the static
- versions. Obviously this requires that the packages were build with
+ versions. Obviously this requires that the packages were built with
shared libraries. On supported platforms GHC comes with shared
libraries for all the core packages, but if you install extra packages
(e.g. with Cabal) then they would also have to be built with shared
In particular Haskell shared libraries <emphasis>must</emphasis> be
made into packages. You cannot freely assign which modules go in which
shared libraries. The Haskell shared libraries must match the package
- boundaries. Most of the conventions GHC expects when using packages are
- described in <xref linkend="building-packages"/>.
- </para>
- <para>
+ boundaries. The reason for this is that
GHC handles references to symbols <emphasis>within</emphasis> the same
shared library (or main executable binary) differently from references
to symbols <emphasis>between</emphasis> different shared libraries. GHC
<literal>-dynamic</literal> in the link step. That means to
statically link the rts all the base libraries into your new shared
library. This would make a very big, but standalone shared library.
- Indeed this is exactly what we must currently do on Windows where
- -dynamic is not yet supported (see <xref linkend="win32-dlls"/>).
On most platforms however that would require all the static libraries
to have been built with <literal>-fPIC</literal> so that the code is
suitable to include into a shared library and we do not do that at the
The details of how this works varies between platforms, in particular
the three major systems: Unix ELF platforms, Windows and Mac OS X.
</para>
+ <sect3 id="finding-shared-libs-unix">
+ <title>Unix</title>
<para>
On Unix there are two mechanisms. Shared libraries can be installed
into standard locations that the dynamic linker knows about. For
<para>
GHC has a <literal>-dynload</literal> linking flag to select the method
that is used to find shared libraries at runtime. There are currently
- three modes:
+ two modes:
<variablelist>
<varlistentry>
<term>sysdep</term>
<listitem>
<para>
A system-dependent mode. This is also the default mode. On Unix
- ELF systems this embeds rpaths into the shared library or
- executable. In particular it uses absolute paths to where the
- shared libraries for the rts and each package can be found.
- This means the program can immediately be run and it will be
- able to find the libraries it needs. However it may not be
- suitable for deployment if the libraries are installed in a
- different location on another machine.
+ ELF systems this embeds
+ <literal>RPATH</literal>/<literal>RUNPATH</literal> entries into the
+ shared library or executable. In particular it uses absolute paths to
+ where the shared libraries for the rts and each package can be found.
+ This means the program can immediately be run and it will be able to
+ find the libraries it needs. However it may not be suitable for
+ deployment if the libraries are installed in a different location on
+ another machine.
</para>
</listitem>
</varlistentry>
</varlistentry>
</variablelist>
To use relative paths for dependent libraries on Linux and Solaris you
- can use the <literal>deploy</literal> mode and pass suitable a -rpath
- flag to the linker:
+ can pass a suitable <literal>-rpath</literal> flag to the linker:
<programlisting>
ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN'
</programlisting>
executable e.g. <literal>-optl-Wl,-rpath,'$ORIGIN/lib'</literal>.
</para>
<para>
- The standard assumption on Darwin/MacOS X is that dynamic libraries will
+ This relative path technique can be used with either of the two
+ <literal>-dynload</literal> modes, though it makes most sense with the
+ <literal>deploy</literal> mode. The difference is that with the
+ <literal>deploy</literal> mode, the above example will end up with an ELF
+ <literal>RUNPATH</literal> of just <literal>$ORIGIN</literal> while with
+ the <literal>sysdep</literal> mode the <literal>RUNPATH</literal> will be
+ <literal>$ORIGIN</literal> followed by all the library directories of all
+ the packages that the program depends on (e.g. <literal>base</literal>
+ and <literal>rts</literal> packages etc.) which are typically absolute
+ paths. The unix tool <literal>readelf --dynamic</literal> is handy for
+ inspecting the <literal>RPATH</literal>/<literal>RUNPATH</literal>
+ entries in ELF shared libraries and executables.
+ </para>
+ </sect3>
+ <sect3 id="finding-shared-libs-mac">
+ <title>Mac OS X</title>
+ <para>
+ The standard assumption on Darwin/Mac OS X is that dynamic libraries will
be stamped at build time with an "install name", which is the full
ultimate install path of the library file. Any libraries or executables
that subsequently link against it (even if it hasn't been installed yet)
for you. It automatically sets the install name for dynamic libraries to
the absolute path of the ultimate install location.
</para>
+ </sect3>
</sect2>
</sect1>
<variablelist>
<varlistentry>
<term>
- <option>-n</option>
- <indexterm><primary><option>-n</option></primary></indexterm>
- </term>
- <listitem>
- <para>Does a dry-run, i.e. GHC goes through all the motions
- of compiling as normal, but does not actually run any
- external commands.</para>
- </listitem>
- </varlistentry>
-
- <varlistentry>
- <term>
<option>-v</option>
<indexterm><primary><option>-v</option></primary></indexterm>
</term>
</title>
<para>
-<emphasis>Making Haskell libraries into DLLs doesn't work on Windows at the
-moment; we hope to re-instate this facility in the future
-(see <xref linkend="using-shared-libs"/>). Note that
-building an entire Haskell application as a single DLL is still supported: it's
- just multi-DLL Haskell programs that don't work. The Windows
- distribution of GHC contains static libraries only.</emphasis></para>
-
-<!--
-<para>
<indexterm><primary>Dynamic link libraries, Win32</primary></indexterm>
<indexterm><primary>DLLs, Win32</primary></indexterm>
On Win32 platforms, the compiler is capable of both producing and using
</para>
<para>
+There are two distinct ways in which DLLs can be used:
+<itemizedlist>
+ <listitem>
+ <para>
+ You can turn each Haskell package into a DLL, so that multiple
+ Haskell executables using the same packages can share the DLL files.
+ (As opposed to linking the libraries statically, which in effect
+ creates a new copy of the RTS and all libraries for each executable
+ produced.)
+ </para>
+ <para>
+ That is the same as the dynamic linking on other platforms, and it
+ is described in <xref linkend="using-shared-libs"/>.
+ </para>
+ </listitem>
+ <listitem>
+ <para>
+ You can package up a complete Haskell program as a DLL, to be called
+ by some external (usually non-Haskell) program. This is usually used
+ to implement plugins and the like, and is described below.
+ </para>
+ </listitem>
+</itemizedlist>
+</para>
+
+<!--
+<para>
Until recently, <command>strip</command> didn't work reliably on DLLs, so you
should test your version with care, or make sure you have the latest
binutils. Unfortunately, we don't know exactly which version of binutils
%{_prefix}/bin/ghci
%{_prefix}/bin/ghci-%{version}
%{_prefix}/bin/ghcprof
-%{_prefix}/bin/hasktags
%{_prefix}/bin/hp2ps
%{_prefix}/bin/hpc
%{_prefix}/bin/hsc2hs-ghc
]
where
- tyThing2TagKind (AnId _) = 'v'
+ tyThing2TagKind (AnId _) = 'v'
tyThing2TagKind (ADataCon _) = 'd'
- tyThing2TagKind (ATyCon _) = 't'
- tyThing2TagKind (AClass _) = 'c'
+ tyThing2TagKind (ATyCon _) = 't'
+ tyThing2TagKind (AClass _) = 'c'
+ tyThing2TagKind (ACoAxiom _) = 'x'
data TagInfo = TagInfo
import HsImpExp
import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
import RdrName (RdrName)
-import Outputable hiding (printForUser, printForUserPartWay)
+import Outputable hiding (printForUser, printForUserPartWay, bold)
import Module -- for ModuleEnv
import Name
import SrcLoc
-exec "$executablename" -B"$topdir" -pgmc "$pgmgcc" -pgma "$pgmgcc" -pgml "$pgmgcc" -pgmP "$pgmgcc -E -undef -traditional" ${1+"$@"}
+exec "$executablename" -B"$topdir" ${1+"$@"}
#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraFwd_bitmap(i)
#endif
-#define mutArrPtrsCardWords(n) \
- ROUNDUP_BYTES_TO_WDS(((n) + (1 << MUT_ARR_PTRS_CARD_BITS) - 1) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1)
+#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrCardUp(i) (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n))
#if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG))
#define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr")
DLL_IMPORT_RTS extern int prog_argc;
DLL_IMPORT_RTS extern char *prog_name;
+#ifdef mingw32_HOST_OS
+// We need these two from Haskell too
+void getWin32ProgArgv(int *argc, wchar_t **argv[]);
+void setWin32ProgArgv(int argc, wchar_t *argv[]);
+#endif
+
void stackOverflow(void);
void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__);
Miscellaneous garbage
-------------------------------------------------------------------------- */
-/* declarations for runtime flags/values */
-#define MAX_RTS_ARGS 32
-
#ifdef DEBUG
#define TICK_VAR(arity) \
extern StgInt SLOW_CALLS_##arity; \
#define EVENT_GC_END 10 /* () */
#define EVENT_REQUEST_SEQ_GC 11 /* () */
#define EVENT_REQUEST_PAR_GC 12 /* () */
+/* 13, 14 deprecated */
#define EVENT_CREATE_SPARK_THREAD 15 /* (spark_thread) */
#define EVENT_LOG_MSG 16 /* (message ...) */
#define EVENT_STARTUP 17 /* (num_capabilities) */
#define EVENT_GC_IDLE 20 /* () */
#define EVENT_GC_WORK 21 /* () */
#define EVENT_GC_DONE 22 /* () */
+/* 23, 24 used by eden */
+#define EVENT_CAPSET_CREATE 25 /* (capset, capset_type) */
+#define EVENT_CAPSET_DELETE 26 /* (capset) */
+#define EVENT_CAPSET_ASSIGN_CAP 27 /* (capset, cap) */
+#define EVENT_CAPSET_REMOVE_CAP 28 /* (capset, cap) */
+/* the RTS identifier is in the form of "GHC-version rts_way" */
+#define EVENT_RTS_IDENTIFIER 29 /* (capset, name_version_string) */
+/* the vectors in these events are null separated strings */
+#define EVENT_PROGRAM_ARGS 30 /* (capset, commandline_vector) */
+#define EVENT_PROGRAM_ENV 31 /* (capset, environment_vector) */
+#define EVENT_OSPROCESS_PID 32 /* (capset, pid) */
+#define EVENT_OSPROCESS_PPID 33 /* (capset, parent_pid) */
-#define NUM_EVENT_TAGS 23
+
+/* Range 34 - 59 is available for new events */
+
+/* Range 60 - 80 is used by eden for parallel tracing
+ * see http://www.mathematik.uni-marburg.de/~eden/
+ */
+
+/*
+ * The highest event code +1 that ghc itself emits. Note that some event
+ * ranges higher than this are reserved but not currently emitted by ghc.
+ * This must match the size of the EventDesc[] array in EventLog.c
+ */
+#define NUM_EVENT_TAGS 34
#if 0 /* DEPRECATED EVENTS: */
+/* ghc changed how it handles sparks so these are no longer applicable */
#define EVENT_CREATE_SPARK 13 /* (cap, thread) */
#define EVENT_SPARK_TO_THREAD 14 /* (cap, thread, spark_thread) */
+/* these are used by eden but are replaced by new alternatives for ghc */
+#define EVENT_VERSION 23 /* (version_string) */
+#define EVENT_PROGRAM_INVOCATION 24 /* (commandline_string) */
#endif
/*
*/
#define THREAD_SUSPENDED_FOREIGN_CALL 6
+/*
+ * Capset type values for EVENT_CAPSET_CREATE
+ */
+#define CAPSET_TYPE_CUSTOM 1 /* reserved for end-user applications */
+#define CAPSET_TYPE_OSPROCESS 2 /* caps belong to the same OS process */
+#define CAPSET_TYPE_CLOCKDOMAIN 3 /* caps share a local clock/time */
+
#ifndef EVENTLOG_CONSTANTS_ONLY
typedef StgWord16 EventTypeNum;
typedef StgWord16 EventCapNo;
typedef StgWord16 EventPayloadSize; /* variable-size events */
typedef StgWord16 EventThreadStatus; /* status for EVENT_STOP_THREAD */
+typedef StgWord32 EventCapsetID;
+typedef StgWord16 EventCapsetType; /* types for EVENT_CAPSET_CREATE */
#endif
extern int prog_argc;
extern char **prog_argv;
*/
-extern int rts_argc; /* ditto */
-extern char *rts_argv[];
+extern int rts_argc; /* ditto */
+extern char **rts_argv;
#endif /* RTS_FLAGS_H */
*
* ------------------------------------------------------------------------- */
+// A count of blocks needs to store anything up to the size of memory
+// divided by the block size. The safest thing is therefore to use a
+// type that can store the full range of memory addresses,
+// ie. StgWord. Note that we have had some tricky int overflows in a
+// couple of cases caused by using ints rather than longs (e.g. #5086)
+
+typedef StgWord memcount;
+
typedef struct nursery_ {
bdescr * blocks;
- unsigned int n_blocks;
+ memcount n_blocks;
} nursery;
typedef struct generation_ {
unsigned int no; // generation number
bdescr * blocks; // blocks in this gen
- unsigned int n_blocks; // number of blocks
- unsigned int n_words; // number of used words
+ memcount n_blocks; // number of blocks
+ memcount n_words; // number of used words
bdescr * large_objects; // large objects (doubly linked)
- unsigned int n_large_blocks; // no. of blocks used by large objs
- unsigned long n_new_large_words; // words of new large objects
+ memcount n_large_blocks; // no. of blocks used by large objs
+ memcount n_new_large_words; // words of new large objects
// (for allocation stats)
- unsigned int max_blocks; // max blocks
+ memcount max_blocks; // max blocks
StgTSO * threads; // threads in this gen
// linked via global_link
// are copied into the following two fields. After GC, these blocks
// are freed.
bdescr * old_blocks; // bdescr of first from-space block
- unsigned int n_old_blocks; // number of blocks in from-space
- unsigned int live_estimate; // for sweeping: estimate of live data
+ memcount n_old_blocks; // number of blocks in from-space
+ memcount live_estimate; // for sweeping: estimate of live data
bdescr * scavenged_large_objects; // live large objs after GC (d-link)
- unsigned int n_scavenged_large_blocks; // size (not count) of above
+ memcount n_scavenged_large_blocks; // size (not count) of above
bdescr * bitmap; // bitmap for compacting collection
Caller-saves regs have to be saved around C-calls made from STG
land, so this file defines CALLER_SAVES_<reg> for each <reg> that
is designated caller-saves in that machine's C calling convention.
+
+ As it stands, the only registers that are ever marked caller saves
+ are the RX, FX, DX and USER registers; as a result, if you
+ decide to caller save a system register (e.g. SP, HP, etc), note that
+ this code path is completely untested! -- EZY
-------------------------------------------------------------------------- */
/* -----------------------------------------------------------------------------
#define store_load_barrier() /* nothing */
#define load_load_barrier() /* nothing */
+#if !IN_STG_CODE || IN_STGCRUN
INLINE_HEADER StgWord
xchg(StgPtr p, StgWord w)
{
{
return --(*p);
}
+#endif
#define VOLATILE_LOAD(p) ((StgWord)*((StgWord*)(p)))
GhcStage1HcOpts = -O -fasm
GhcStage2HcOpts = -O2 -fasm
GhcHcOpts = -Rghc-timing
-GhcLibHcOpts = -O2 -XGenerics
+GhcLibHcOpts = -O2
GhcLibWays += p
ifeq "$(PlatformSupportsSharedLibs)" "YES"
# -----------------------------------------------------------------------------
# Other settings that might be useful
-# profiled RTS
-#GhcRtsCcOpts = -pg -g
-
-# Optimised/profiled RTS
-#GhcRtsCcOpts = -O2 -pg
-
-#GhcRtsWithFrontPanel = YES
-#SRC_HC_OPTS += `gtk-config --libs`
-
# NoFib settings
NoFibWays =
STRIP_CMD = :
#
# -O(2) is pretty desirable, otherwise no inlining of prelude
# things (incl "+") happens when compiling with this compiler
-#
-# -XGenerics switches on generation of support code for
-# derivable type classes. This is now off by default,
-# but we switch it on for the libraries so that we generate
-# the code in case someone importing wants it
-GhcLibHcOpts=-O2 -XGenerics
+GhcLibHcOpts=-O2
# Strip local symbols from libraries? This can make the libraries smaller,
# but makes debugging somewhat more difficult. Doesn't work with all ld's.
CC_STAGE1 = $(CC)
CC_STAGE2 = $(CC)
CC_STAGE3 = $(CC)
+AS = $(WhatGccIsCalled)
+AS_STAGE0 = @CC_STAGE0@
+AS_STAGE1 = $(AS)
+AS_STAGE2 = $(AS)
+AS_STAGE3 = $(AS)
# C compiler and linker flags from configure (e.g. -m<blah> to select
# correct C compiler backend). The stage number is the stage of GHC
AR_OPTS = @ArArgs@
ArSupportsAtFile = @ArSupportsAtFile@
-AR_STAGE0 = $(AR)
+AR_STAGE0 = @AR_STAGE0@
AR_STAGE1 = $(AR)
AR_STAGE2 = $(AR)
AR_STAGE3 = $(AR)
-AR_OPTS_STAGE0 = $(AR_OPTS)
+AR_OPTS_STAGE0 = @AR_OPTS_STAGE0@
AR_OPTS_STAGE1 = $(AR_OPTS)
AR_OPTS_STAGE2 = $(AR_OPTS)
AR_OPTS_STAGE3 = $(AR_OPTS)
EXTRA_AR_ARGS_STAGE1 = $(EXTRA_AR_ARGS)
EXTRA_AR_ARGS_STAGE2 = $(EXTRA_AR_ARGS)
EXTRA_AR_ARGS_STAGE3 = $(EXTRA_AR_ARGS)
-ArSupportsAtFile_STAGE0 = $(ArSupportsAtFile)
+ArSupportsAtFile_STAGE0 = @ArSupportsAtFile_STAGE0@
ArSupportsAtFile_STAGE1 = $(ArSupportsAtFile)
ArSupportsAtFile_STAGE2 = $(ArSupportsAtFile)
ArSupportsAtFile_STAGE3 = $(ArSupportsAtFile)
#
SRC_ALEX_OPTS = -g
-HSTAGS = @HstagsCmd@
-
# Should we build haddock docs?
HADDOCK_DOCS = YES
# And HsColour the sources?
GhcStage2HcOpts += -fhpc -hpcdir $(TOP)/testsuite/hpc_output/
endif
ifeq "$(ValidateSlow)" "YES"
-GhcStage2HcOpts += -XGenerics -DDEBUG
-GhcLibHcOpts += -XGenerics
+GhcStage2HcOpts += -DDEBUG
endif
######################################################################
cap->transaction_tokens = 0;
cap->context_switch = 0;
cap->pinned_object_block = NULL;
+
+ traceCapsetAssignCap(CAPSET_OSPROCESS_DEFAULT, i);
}
/* ---------------------------------------------------------------------------
void
initCapabilities( void )
{
+ /* Declare a single capability set representing the process.
+ Each capability will get added to this capset. */
+ traceCapsetCreate(CAPSET_OSPROCESS_DEFAULT, CapsetTypeOsProcess);
+
#if defined(THREADED_RTS)
nat i;
}
/* ----------------------------------------------------------------------------
+ * tryGrabCapability
+ *
+ * Attempt to gain control of a Capability if it is free.
+ *
+ * ------------------------------------------------------------------------- */
+
+rtsBool
+tryGrabCapability (Capability *cap, Task *task)
+{
+ if (cap->running_task != NULL) return rtsFalse;
+ ACQUIRE_LOCK(&cap->lock);
+ if (cap->running_task != NULL) {
+ RELEASE_LOCK(&cap->lock);
+ return rtsFalse;
+ }
+ task->cap = cap;
+ cap->running_task = task;
+ RELEASE_LOCK(&cap->lock);
+ return rtsTrue;
+}
+
+
+#endif /* THREADED_RTS */
+
+/* ----------------------------------------------------------------------------
* shutdownCapability
*
* At shutdown time, we want to let everything exit as cleanly as
* ------------------------------------------------------------------------- */
void
-shutdownCapability (Capability *cap, Task *task, rtsBool safe)
+shutdownCapability (Capability *cap,
+ Task *task USED_IF_THREADS,
+ rtsBool safe USED_IF_THREADS)
{
+#if defined(THREADED_RTS)
nat i;
task->cap = cap;
// threads performing foreign calls that will eventually try to
// return via resumeThread() and attempt to grab cap->lock.
// closeMutex(&cap->lock);
-}
+
+#endif /* THREADED_RTS */
-/* ----------------------------------------------------------------------------
- * tryGrabCapability
- *
- * Attempt to gain control of a Capability if it is free.
- *
- * ------------------------------------------------------------------------- */
+ traceCapsetRemoveCap(CAPSET_OSPROCESS_DEFAULT, cap->no);
+}
-rtsBool
-tryGrabCapability (Capability *cap, Task *task)
+void
+shutdownCapabilities(Task *task, rtsBool safe)
{
- if (cap->running_task != NULL) return rtsFalse;
- ACQUIRE_LOCK(&cap->lock);
- if (cap->running_task != NULL) {
- RELEASE_LOCK(&cap->lock);
- return rtsFalse;
+ nat i;
+ for (i=0; i < n_capabilities; i++) {
+ ASSERT(task->incall->tso == NULL);
+ shutdownCapability(&capabilities[i], task, safe);
}
- task->cap = cap;
- cap->running_task = task;
- RELEASE_LOCK(&cap->lock);
- return rtsTrue;
+ traceCapsetDelete(CAPSET_OSPROCESS_DEFAULT);
}
-
-#endif /* THREADED_RTS */
-
static void
freeCapability (Capability *cap)
{
//
void prodAllCapabilities (void);
-// Waits for a capability to drain of runnable threads and workers,
-// and then acquires it. Used at shutdown time.
-//
-void shutdownCapability (Capability *cap, Task *task, rtsBool wait_foreign);
-
// Attempt to gain control of a Capability if it is free.
//
rtsBool tryGrabCapability (Capability *cap, Task *task);
#endif /* !THREADED_RTS */
+// Waits for a capability to drain of runnable threads and workers,
+// and then acquires it. Used at shutdown time.
+//
+void shutdownCapability (Capability *cap, Task *task, rtsBool wait_foreign);
+
+// Shut down all capabilities.
+//
+void shutdownCapabilities(Task *task, rtsBool wait_foreign);
+
// cause all capabilities to context switch as soon as possible.
void setContextSwitches(void);
INLINE_HEADER void contextSwitchCapability(Capability *cap);
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2011
+ *
+ * OS-independent interface to the process environment variables
+ *
+ * ---------------------------------------------------------------------------*/
+
+#ifndef GETENV_H
+#define GETENV_H
+
+#include "BeginPrivate.h"
+
+/* Get the process environment vector (same style interface as argc/argv)
+ */
+void getProgEnvv (int *out_envc, char **out_envv[]);
+void freeProgEnvv (int envc, char *envv[]);
+
+/* calls to getProgEnvv must have a corresponding freeProgEnvv */
+
+#include "EndPrivate.h"
+
+#endif /* GETENV_H */
SymI_HasProto(stg_asyncReadzh) \
SymI_HasProto(stg_asyncWritezh) \
SymI_HasProto(stg_asyncDoProczh) \
+ SymI_HasProto(getWin32ProgArgv) \
+ SymI_HasProto(setWin32ProgArgv) \
SymI_HasProto(memset) \
SymI_HasProto(inet_ntoa) \
SymI_HasProto(inet_addr) \
// stgFree(oc->image);
// #endif
stgFree(oc->fileName);
+ stgFree(oc->archiveMemberName);
stgFree(oc->symbols);
stgFree(oc->sections);
stgFree(oc);
* Generic ELF functions
*/
-static char *
-findElfSection ( void* objImage, Elf_Word sh_type )
-{
- char* ehdrC = (char*)objImage;
- Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
- Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff);
- char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
- char* ptr = NULL;
- int i;
-
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == sh_type
- /* Ignore the section header's string table. */
- && i != ehdr->e_shstrndx
- /* Ignore string tables named .stabstr, as they contain
- debugging info. */
- && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
- ) {
- ptr = ehdrC + shdr[i].sh_offset;
- break;
- }
- }
- return ptr;
-}
-
static int
ocVerifyImage_ELF ( ObjectCode* oc )
{
Elf_Sym* stab;
int i, j, nent, nstrtab, nsymtabs;
char* sh_strtab;
- char* strtab;
char* ehdrC = (char*)(oc->image);
Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
ehdrC + shdr[i].sh_offset,
ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1));
- if (shdr[i].sh_type == SHT_REL) {
- IF_DEBUG(linker,debugBelch("Rel " ));
- } else if (shdr[i].sh_type == SHT_RELA) {
- IF_DEBUG(linker,debugBelch("RelA " ));
- } else {
- IF_DEBUG(linker,debugBelch(" "));
+#define SECTION_INDEX_VALID(ndx) (ndx > SHN_UNDEF && ndx < ehdr->e_shnum)
+
+ switch (shdr[i].sh_type) {
+
+ case SHT_REL:
+ case SHT_RELA:
+ IF_DEBUG(linker,debugBelch( shdr[i].sh_type == SHT_REL ? "Rel " : "RelA "));
+
+ if (!SECTION_INDEX_VALID(shdr[i].sh_link)) {
+ if (shdr[i].sh_link == SHN_UNDEF)
+ errorBelch("\n%s: relocation section #%d has no symbol table\n"
+ "This object file has probably been fully striped. "
+ "Such files cannot be linked.\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i);
+ else
+ errorBelch("\n%s: relocation section #%d has an invalid link field (%d)\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName,
+ i, shdr[i].sh_link);
+ return 0;
+ }
+ if (shdr[shdr[i].sh_link].sh_type != SHT_SYMTAB) {
+ errorBelch("\n%s: relocation section #%d does not link to a symbol table\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i);
+ return 0;
+ }
+ if (!SECTION_INDEX_VALID(shdr[i].sh_info)) {
+ errorBelch("\n%s: relocation section #%d has an invalid info field (%d)\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName,
+ i, shdr[i].sh_info);
+ return 0;
+ }
+
+ break;
+ case SHT_SYMTAB:
+ IF_DEBUG(linker,debugBelch("Sym "));
+
+ if (!SECTION_INDEX_VALID(shdr[i].sh_link)) {
+ errorBelch("\n%s: symbol table section #%d has an invalid link field (%d)\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName,
+ i, shdr[i].sh_link);
+ return 0;
+ }
+ if (shdr[shdr[i].sh_link].sh_type != SHT_STRTAB) {
+ errorBelch("\n%s: symbol table section #%d does not link to a string table\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i);
+
+ return 0;
+ }
+ break;
+ case SHT_STRTAB: IF_DEBUG(linker,debugBelch("Str ")); break;
+ default: IF_DEBUG(linker,debugBelch(" ")); break;
}
if (sh_strtab) {
IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name ));
}
}
- IF_DEBUG(linker,debugBelch( "\nString tables" ));
- strtab = NULL;
+ IF_DEBUG(linker,debugBelch( "\nString tables\n" ));
nstrtab = 0;
for (i = 0; i < ehdr->e_shnum; i++) {
if (shdr[i].sh_type == SHT_STRTAB
debugging info. */
&& 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8)
) {
- IF_DEBUG(linker,debugBelch(" section %d is a normal string table", i ));
- strtab = ehdrC + shdr[i].sh_offset;
+ IF_DEBUG(linker,debugBelch(" section %d is a normal string table\n", i ));
nstrtab++;
}
}
- if (nstrtab != 1) {
- errorBelch("%s: no string tables, or too many", oc->fileName);
- return 0;
+ if (nstrtab == 0) {
+ IF_DEBUG(linker,debugBelch(" no normal string tables (potentially, but not necessarily a problem)\n"));
}
nsymtabs = 0;
- IF_DEBUG(linker,debugBelch( "\nSymbol tables" ));
+ IF_DEBUG(linker,debugBelch( "Symbol tables\n" ));
for (i = 0; i < ehdr->e_shnum; i++) {
if (shdr[i].sh_type != SHT_SYMTAB) continue;
IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i ));
}
IF_DEBUG(linker,debugBelch(" " ));
- IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name ));
+ IF_DEBUG(linker,debugBelch("name=%s\n",
+ ehdrC + shdr[shdr[i].sh_link].sh_offset
+ + stab[j].st_name ));
}
}
if (nsymtabs == 0) {
- errorBelch("%s: didn't find any symbol tables", oc->fileName);
- return 0;
+ // Not having a symbol table is not in principle a problem.
+ // When an object file has no symbols then the 'strip' program
+ // typically will remove the symbol table entirely.
+ IF_DEBUG(linker,debugBelch(" no symbol tables (potentially, but not necessarily a problem)\n"));
}
return 1;
char* ehdrC = (char*)(oc->image);
Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC;
- char* strtab = findElfSection ( ehdrC, SHT_STRTAB );
+ char* strtab;
Elf_Shdr* shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
ASSERT(symhash != NULL);
- if (!strtab) {
- errorBelch("%s: no strtab", oc->fileName);
- return 0;
- }
-
k = 0;
for (i = 0; i < ehdr->e_shnum; i++) {
/* Figure out what kind of section it is. Logic derived from
/* copy stuff into this module's object symbol table */
stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset);
+ strtab = ehdrC + shdr[shdr[i].sh_link].sh_offset;
nent = shdr[i].sh_size / sizeof(Elf_Sym);
oc->n_symbols = nent;
oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*),
"ocGetNames_ELF(oc->symbols)");
+ //TODO: we ignore local symbols anyway right? So we can use the
+ // shdr[i].sh_info to get the index of the first non-local symbol
+ // ie we should use j = shdr[i].sh_info
for (j = 0; j < nent; j++) {
char isLocal = FALSE; /* avoids uninit-var warning */
relocations appear to be of this form. */
static int
do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC,
- Elf_Shdr* shdr, int shnum,
- Elf_Sym* stab, char* strtab )
+ Elf_Shdr* shdr, int shnum )
{
int j;
char *symbol;
Elf_Word* targ;
Elf_Rel* rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset);
+ Elf_Sym* stab;
+ char* strtab;
int nent = shdr[shnum].sh_size / sizeof(Elf_Rel);
int target_shndx = shdr[shnum].sh_info;
int symtab_shndx = shdr[shnum].sh_link;
+ int strtab_shndx = shdr[symtab_shndx].sh_link;
stab = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
+ strtab= (char*) (ehdrC + shdr[ strtab_shndx ].sh_offset);
targ = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
- IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
- target_shndx, symtab_shndx ));
+ IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d and strtab %d\n",
+ target_shndx, symtab_shndx, strtab_shndx ));
/* Skip sections that we're not interested in. */
{
sparc-solaris relocations appear to be of this form. */
static int
do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC,
- Elf_Shdr* shdr, int shnum,
- Elf_Sym* stab, char* strtab )
+ Elf_Shdr* shdr, int shnum )
{
int j;
char *symbol = NULL;
Elf_Addr targ;
Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset);
+ Elf_Sym* stab;
+ char* strtab;
int nent = shdr[shnum].sh_size / sizeof(Elf_Rela);
int target_shndx = shdr[shnum].sh_info;
int symtab_shndx = shdr[shnum].sh_link;
+ int strtab_shndx = shdr[symtab_shndx].sh_link;
stab = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
+ strtab= (char*) (ehdrC + shdr[ strtab_shndx ].sh_offset);
targ = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset);
IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n",
target_shndx, symtab_shndx ));
static int
ocResolve_ELF ( ObjectCode* oc )
{
- char *strtab;
int shnum, ok;
- Elf_Sym* stab = NULL;
char* ehdrC = (char*)(oc->image);
Elf_Ehdr* ehdr = (Elf_Ehdr*) ehdrC;
Elf_Shdr* shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff);
- /* first find "the" symbol table */
- stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
-
- /* also go find the string table */
- strtab = findElfSection ( ehdrC, SHT_STRTAB );
-
- if (stab == NULL || strtab == NULL) {
- errorBelch("%s: can't find string or symbol table", oc->fileName);
- return 0;
- }
-
/* Process the relocation sections. */
for (shnum = 0; shnum < ehdr->e_shnum; shnum++) {
if (shdr[shnum].sh_type == SHT_REL) {
- ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr,
- shnum, stab, strtab );
+ ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr, shnum );
if (!ok) return ok;
}
else
if (shdr[shnum].sh_type == SHT_RELA) {
- ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr,
- shnum, stab, strtab );
+ ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr, shnum );
if (!ok) return ok;
}
}
if( i == ehdr->e_shnum )
{
- errorBelch( "This ELF file contains no symtab" );
- return 0;
+ // Not having a symbol table is not in principle a problem.
+ // When an object file has no symbols then the 'strip' program
+ // typically will remove the symbol table entirely.
+ IF_DEBUG(linker, debugBelch( "The ELF file %s contains no symtab\n",
+ oc->archiveMemberName ? oc->archiveMemberName : oc->fileName ));
+ return 1;
}
if( shdr[i].sh_entsize != sizeof( Elf_Sym ) )
}
}
+
/* -----------------------------------------------------------------------------
MutVar primitives
-------------------------------------------------------------------------- */
#include "LdvProfile.h"
#include "Arena.h"
#include "Printer.h"
+#include "sm/GCThread.h"
#include <string.h>
rs->id = -(rs->id);
// report in the unit of bytes: * sizeof(StgWord)
- printRetainerSetShort(hp_file, rs);
+ printRetainerSetShort(hp_file, rs, RtsFlags.ProfFlags.ccsLength);
break;
}
default:
void
heapCensus( void )
{
- nat g;
+ nat g, n;
Census *census;
+ gen_workspace *ws;
census = &censuses[era];
census->time = mut_user_time();
// Are we interested in large objects? might be
// confusing to include the stack in a heap profile.
heapCensusChain( census, generations[g].large_objects );
+
+ for (n = 0; n < n_capabilities; n++) {
+ ws = &gc_threads[n]->gens[g];
+ heapCensusChain(census, ws->todo_bd);
+ heapCensusChain(census, ws->part_list);
+ heapCensusChain(census, ws->scavd_list);
+ }
}
// dump out the census info
#if defined(RETAINER_SCHEME_INFO)
// Retainer scheme 1: retainer = info table
void
-printRetainerSetShort(FILE *f, RetainerSet *rs)
+printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length)
{
-#define MAX_RETAINER_SET_SPACE 24
- char tmp[MAX_RETAINER_SET_SPACE + 1];
+ char tmp[max_length + 1];
int size;
nat j;
ASSERT(rs->id < 0);
- tmp[MAX_RETAINER_SET_SPACE] = '\0';
+ tmp[max_length] = '\0';
// No blank characters are allowed.
sprintf(tmp + 0, "(%d)", -(rs->id));
size = strlen(tmp);
- ASSERT(size < MAX_RETAINER_SET_SPACE);
+ ASSERT(size < max_length);
for (j = 0; j < rs->num; j++) {
if (j < rs->num - 1) {
- strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size);
size = strlen(tmp);
- if (size == MAX_RETAINER_SET_SPACE)
+ if (size == max_length)
break;
- strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, ",", max_length - size);
size = strlen(tmp);
- if (size == MAX_RETAINER_SET_SPACE)
+ if (size == max_length)
break;
}
else {
- strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size);
// size = strlen(tmp);
}
}
#elif defined(RETAINER_SCHEME_CC)
// Retainer scheme 3: retainer = cost centre
void
-printRetainerSetShort(FILE *f, RetainerSet *rs)
+printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length)
{
-#define MAX_RETAINER_SET_SPACE 24
- char tmp[MAX_RETAINER_SET_SPACE + 1];
+ char tmp[max_length + 1];
int size;
nat j;
#elif defined(RETAINER_SCHEME_CCS)
// Retainer scheme 2: retainer = cost centre stack
void
-printRetainerSetShort(FILE *f, RetainerSet *rs)
+printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length)
{
-#define MAX_RETAINER_SET_SPACE 24
- char tmp[MAX_RETAINER_SET_SPACE + 1];
- int size;
+ char tmp[max_length + 1];
+ nat size;
nat j;
ASSERT(rs->id < 0);
- tmp[MAX_RETAINER_SET_SPACE] = '\0';
+ tmp[max_length] = '\0';
// No blank characters are allowed.
sprintf(tmp + 0, "(%d)", -(rs->id));
size = strlen(tmp);
- ASSERT(size < MAX_RETAINER_SET_SPACE);
+ ASSERT(size < max_length);
for (j = 0; j < rs->num; j++) {
if (j < rs->num - 1) {
- strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, rs->element[j]->cc->label, max_length - size);
size = strlen(tmp);
- if (size == MAX_RETAINER_SET_SPACE)
+ if (size == max_length)
break;
- strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, ",", max_length - size);
size = strlen(tmp);
- if (size == MAX_RETAINER_SET_SPACE)
+ if (size == max_length)
break;
}
else {
- strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, rs->element[j]->cc->label, max_length - size);
// size = strlen(tmp);
}
}
#elif defined(RETAINER_SCHEME_CC)
// Retainer scheme 3: retainer = cost centre
static void
-printRetainerSetShort(FILE *f, retainerSet *rs)
+printRetainerSetShort(FILE *f, retainerSet *rs, nat max_length)
{
-#define MAX_RETAINER_SET_SPACE 24
- char tmp[MAX_RETAINER_SET_SPACE + 1];
+ char tmp[max_length + 1];
int size;
nat j;
ASSERT(rs->id < 0);
- tmp[MAX_RETAINER_SET_SPACE] = '\0';
+ tmp[max_length] = '\0';
// No blank characters are allowed.
sprintf(tmp + 0, "(%d)", -(rs->id));
size = strlen(tmp);
- ASSERT(size < MAX_RETAINER_SET_SPACE);
+ ASSERT(size < max_length);
for (j = 0; j < rs->num; j++) {
if (j < rs->num - 1) {
strncpy(tmp + size, rs->element[j]->label,
- MAX_RETAINER_SET_SPACE - size);
+ max_length - size);
size = strlen(tmp);
- if (size == MAX_RETAINER_SET_SPACE)
+ if (size == max_length)
break;
- strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size);
+ strncpy(tmp + size, ",", max_length - size);
size = strlen(tmp);
- if (size == MAX_RETAINER_SET_SPACE)
+ if (size == max_length)
break;
}
else {
strncpy(tmp + size, rs->element[j]->label,
- MAX_RETAINER_SET_SPACE - size);
+ max_length - size);
// size = strlen(tmp);
}
}
fprintf(f, tmp);
/*
- #define MAX_RETAINER_SET_SPACE 24
#define DOT_NUMBER 3
- // 1. 32 > MAX_RETAINER_SET_SPACE + 1 (1 for '\0')
- // 2. (MAX_RETAINER_SET_SPACE - DOT_NUMBER ) characters should be enough for
+ // 1. 32 > max_length + 1 (1 for '\0')
+ // 2. (max_length - DOT_NUMBER ) characters should be enough for
// printing one natural number (plus '(' and ')').
char tmp[32];
int size, ts;
// No blank characters are allowed.
sprintf(tmp + 0, "(%d)", -(rs->id));
size = strlen(tmp);
- ASSERT(size < MAX_RETAINER_SET_SPACE - DOT_NUMBER);
+ ASSERT(size < max_length - DOT_NUMBER);
for (j = 0; j < rs->num; j++) {
ts = strlen(rs->element[j]->label);
if (j < rs->num - 1) {
- if (size + ts + 1 > MAX_RETAINER_SET_SPACE - DOT_NUMBER) {
+ if (size + ts + 1 > max_length - DOT_NUMBER) {
sprintf(tmp + size, "...");
break;
}
size += ts + 1;
}
else {
- if (size + ts > MAX_RETAINER_SET_SPACE - DOT_NUMBER) {
+ if (size + ts > max_length - DOT_NUMBER) {
sprintf(tmp + size, "...");
break;
}
#ifdef SECOND_APPROACH
// Prints a single retainer set.
-void printRetainerSetShort(FILE *, RetainerSet *);
+void printRetainerSetShort(FILE *, RetainerSet *, nat);
#endif
// Print the statistics on all the retainer sets.
char **full_prog_argv = NULL;
char *prog_name = NULL; /* 'basename' of prog_argv[0] */
int rts_argc = 0; /* ditto */
-char *rts_argv[MAX_RTS_ARGS];
+char **rts_argv = NULL;
+#if defined(mingw32_HOST_OS)
+// On Windows, we want to use GetCommandLineW rather than argc/argv,
+// but we need to mutate the command line arguments for withProgName and
+// friends. The System.Environment module achieves that using this bit of
+// shared state:
+int win32_prog_argc = 0;
+wchar_t **win32_prog_argv = NULL;
+#endif
/*
* constants, used later
static void errorUsage (void) GNU_ATTRIBUTE(__noreturn__);
+static char * copyArg (char *arg);
+static char ** copyArgv (int argc, char *argv[]);
+static void freeArgv (int argc, char *argv[]);
+
/* -----------------------------------------------------------------------------
* Command-line option parsing routines.
* ---------------------------------------------------------------------------*/
if (c1 == c2) { break; }
- if (rts_argc < MAX_RTS_ARGS-1) {
- s = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()");
- strncpy(s, c1, c2-c1);
- s[c2-c1] = '\0';
- rts_argv[rts_argc++] = s;
- } else {
- barf("too many RTS arguments (max %d)", MAX_RTS_ARGS-1);
- }
-
+ s = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()");
+ strncpy(s, c1, c2-c1);
+ s[c2-c1] = '\0';
+ rts_argv[rts_argc++] = s;
+
c1 = c2;
} while (*c1 != '\0');
}
- argv[] is *modified*, any RTS options have been stripped out
- *argc contains the new count of arguments in argv[]
- - rts_argv[] (global) contains the collected RTS args
+ - rts_argv[] (global) contains a copy of the collected RTS args
- rts_argc (global) contains the count of args in rts_argv
- - prog_argv[] (global) contains the non-RTS args (== argv)
+ - prog_argv[] (global) contains a copy of the non-RTS args (== argv)
- prog_argc (global) contains the count of args in prog_argv
- - prog_name (global) contains the basename of argv[0]
+ - prog_name (global) contains the basename of prog_argv[0]
-------------------------------------------------------------------------- */
*argc = 1;
rts_argc = 0;
+ rts_argv = stgCallocBytes(total_arg + 1, sizeof (char *), "setupRtsFlags");
+
rts_argc0 = rts_argc;
// process arguments from the ghc_rts_opts global variable first.
else if (strequal("-RTS", argv[arg])) {
mode = PGM;
}
- else if (mode == RTS && rts_argc < MAX_RTS_ARGS-1) {
- rts_argv[rts_argc++] = argv[arg];
+ else if (mode == RTS) {
+ rts_argv[rts_argc++] = copyArg(argv[arg]);
}
- else if (mode == PGM) {
- argv[(*argc)++] = argv[arg];
- }
- else {
- barf("too many RTS arguments (max %d)", MAX_RTS_ARGS-1);
+ else {
+ argv[(*argc)++] = argv[arg];
}
}
// process remaining program arguments
stg_exit(EXIT_FAILURE);
}
+/* ----------------------------------------------------------------------------
+ Copying and freeing argc/argv
+ ------------------------------------------------------------------------- */
+
+static char * copyArg(char *arg)
+{
+ char *new_arg = stgMallocBytes(strlen(arg) + 1, "copyArg");
+ strcpy(new_arg, arg);
+ return new_arg;
+}
+
+static char ** copyArgv(int argc, char *argv[])
+{
+ int i;
+ char **new_argv;
+
+ new_argv = stgCallocBytes(argc + 1, sizeof (char *), "copyArgv 1");
+ for (i = 0; i < argc; i++) {
+ new_argv[i] = copyArg(argv[i]);
+ }
+ new_argv[argc] = NULL;
+ return new_argv;
+}
+
+static void freeArgv(int argc, char *argv[])
+{
+ int i;
+ if (argv != NULL) {
+ for (i = 0; i < argc; i++) {
+ stgFree(argv[i]);
+ }
+ stgFree(argv);
+ }
+}
+
/* -----------------------------------------------------------------------------
Getting/Setting the program's arguments.
setProgArgv(int argc, char *argv[])
{
prog_argc = argc;
- prog_argv = argv;
+ prog_argv = copyArgv(argc,argv);
setProgName(prog_argv);
}
+static void
+freeProgArgv(void)
+{
+ freeArgv(prog_argc,prog_argv);
+ prog_argc = 0;
+ prog_argv = NULL;
+}
+
+/* ----------------------------------------------------------------------------
+ The full argv - a copy of the original program's argc/argv
+ ------------------------------------------------------------------------- */
+
+void
+setFullProgArgv(int argc, char *argv[])
+{
+ full_prog_argc = argc;
+ full_prog_argv = copyArgv(argc,argv);
+}
+
/* These functions record and recall the full arguments, including the
+RTS ... -RTS options. The reason for adding them was so that the
ghc-inplace program can pass /all/ the arguments on to the real ghc. */
}
void
-setFullProgArgv(int argc, char *argv[])
+freeFullProgArgv (void)
{
- int i;
- full_prog_argc = argc;
- full_prog_argv = stgCallocBytes(argc + 1, sizeof (char *),
- "setFullProgArgv 1");
- for (i = 0; i < argc; i++) {
- full_prog_argv[i] = stgMallocBytes(strlen(argv[i]) + 1,
- "setFullProgArgv 2");
- strcpy(full_prog_argv[i], argv[i]);
- }
- full_prog_argv[argc] = NULL;
+ freeArgv(full_prog_argc, full_prog_argv);
+ full_prog_argc = 0;
+ full_prog_argv = NULL;
}
+/* ----------------------------------------------------------------------------
+ The Win32 argv
+ ------------------------------------------------------------------------- */
+
+#if defined(mingw32_HOST_OS)
+void freeWin32ProgArgv (void);
+
void
-freeFullProgArgv (void)
+freeWin32ProgArgv (void)
{
+ freeArgv(win32_prog_argc, win32_prog_argv);
+
int i;
- if (full_prog_argv != NULL) {
- for (i = 0; i < full_prog_argc; i++) {
- stgFree(full_prog_argv[i]);
+ if (win32_prog_argv != NULL) {
+ for (i = 0; i < win32_prog_argc; i++) {
+ stgFree(win32_prog_argv[i]);
}
- stgFree(full_prog_argv);
+ stgFree(win32_prog_argv);
}
- full_prog_argc = 0;
- full_prog_argv = NULL;
+ win32_prog_argc = 0;
+ win32_prog_argv = NULL;
+}
+
+void
+getWin32ProgArgv(int *argc, wchar_t **argv[])
+{
+ *argc = win32_prog_argc;
+ *argv = win32_prog_argv;
+}
+
+void
+setWin32ProgArgv(int argc, wchar_t *argv[])
+{
+ int i;
+
+ freeWin32ProgArgv();
+
+ win32_prog_argc = argc;
+ if (argv == NULL) {
+ win32_prog_argv = NULL;
+ return;
+ }
+
+ win32_prog_argv = stgCallocBytes(argc + 1, sizeof (wchar_t *),
+ "setWin32ProgArgv 1");
+ for (i = 0; i < argc; i++) {
+ win32_prog_argv[i] = stgMallocBytes((wcslen(argv[i]) + 1) * sizeof(wchar_t),
+ "setWin32ProgArgv 2");
+ wcscpy(win32_prog_argv[i], argv[i]);
+ }
+ win32_prog_argv[argc] = NULL;
+}
+#endif
+
+/* ----------------------------------------------------------------------------
+ The RTS argv
+ ------------------------------------------------------------------------- */
+
+static void
+freeRtsArgv(void)
+{
+ freeArgv(rts_argc,rts_argv);
+ rts_argc = 0;
+ rts_argv = NULL;
+}
+
+/* ----------------------------------------------------------------------------
+ All argvs
+ ------------------------------------------------------------------------- */
+
+void freeRtsArgs(void)
+{
+#if defined(mingw32_HOST_OS)
+ freeWin32ProgArgv();
+#endif
+ freeFullProgArgv();
+ freeProgArgv();
+ freeRtsArgv();
}
void initRtsFlagsDefaults (void);
void setupRtsFlags (int *argc, char *argv[]);
void setProgName (char *argv[]);
+void freeRtsArgs (void);
#include "EndPrivate.h"
* typedef uint16_t EventCapNo;
* typedef uint16_t EventPayloadSize; // variable-size events
* typedef uint16_t EventThreadStatus;
+ * typedef uint32_t EventCapsetID;
+ * typedef uint16_t EventCapsetType; // types for EVENT_CAPSET_CREATE
*/
/* -----------------------------------------------------------------------------
probe gc__idle (EventCapNo);
probe gc__work (EventCapNo);
probe gc__done (EventCapNo);
+ probe capset__create(EventCapsetID, EventCapsetType);
+ probe capset__delete(EventCapsetID);
+ probe capset__assign__cap(EventCapsetID, EventCapNo);
+ probe capset__remove__cap(EventCapsetID, EventCapNo);
};
#ifdef TRACING
initTracing();
#endif
- /* Dtrace events are always enabled
+ /* Trace the startup event
*/
- dtraceEventStartup();
+ traceEventStartup();
/* initialise scheduler data structures (needs to be done before
* initStorage()).
*/
initScheduler();
+ /* Trace some basic information about the process */
+ traceOSProcessInfo();
+
/* initialize the storage manager */
initStorage();
checkFPUStack();
#endif
- // Free the full argv storage
- freeFullProgArgv();
-
#if defined(THREADED_RTS)
ioManagerDie();
#endif
// heap memory (e.g. by being passed a ByteArray#).
freeStorage(wait_foreign);
+ // Free the various argvs
+ freeRtsArgs();
}
// The real hs_exit():
recent_activity = ACTIVITY_YES;
}
+ if (heap_census) {
+ debugTrace(DEBUG_sched, "performing heap census");
+ heapCensus();
+ performHeapProfile = rtsFalse;
+ }
+
#if defined(THREADED_RTS)
if (gc_type == PENDING_GC_PAR)
{
}
#endif
- if (heap_census) {
- debugTrace(DEBUG_sched, "performing heap census");
- heapCensus();
- performHeapProfile = rtsFalse;
- }
-
if (heap_overflow && sched_state < SCHED_INTERRUPTING) {
// GC set the heap_overflow flag, so we should proceed with
// an orderly shutdown now. Ultimately we want the main
}
sched_state = SCHED_SHUTTING_DOWN;
-#if defined(THREADED_RTS)
- {
- nat i;
-
- for (i = 0; i < n_capabilities; i++) {
- ASSERT(task->incall->tso == NULL);
- shutdownCapability(&capabilities[i], task, wait_foreign);
- }
- }
-#endif
+ shutdownCapabilities(task, wait_foreign);
boundTaskExiting(task);
}
gc_elapsed += GC_coll_elapsed[i];
}
+ init_cpu = end_init_cpu - start_init_cpu;
+ init_elapsed = end_init_elapsed - start_init_elapsed;
+
+ exit_cpu = end_exit_cpu - start_exit_cpu;
+ exit_elapsed = end_exit_elapsed - start_exit_elapsed;
+
+ mut_elapsed = start_exit_elapsed - end_init_elapsed - gc_elapsed;
+
+ mut_cpu = start_exit_cpu - end_init_cpu - gc_cpu
+ - PROF_VAL(RP_tot_time + HC_tot_time);
+ if (mut_cpu < 0) { mut_cpu = 0; }
+
if (RtsFlags.GcFlags.giveStats >= SUMMARY_GC_STATS) {
showStgWord64(GC_tot_alloc*sizeof(W_),
temp, rtsTrue/*commas*/);
}
#endif
- init_cpu = end_init_cpu - start_init_cpu;
- init_elapsed = end_init_elapsed - start_init_elapsed;
-
- exit_cpu = end_exit_cpu - start_exit_cpu;
- exit_elapsed = end_exit_elapsed - start_exit_elapsed;
-
statsPrintf(" INIT time %6.2fs (%6.2fs elapsed)\n",
TICK_TO_DBL(init_cpu), TICK_TO_DBL(init_elapsed));
- mut_elapsed = start_exit_elapsed - end_init_elapsed - gc_elapsed;
-
- mut_cpu = start_exit_cpu - end_init_cpu - gc_cpu
- - PROF_VAL(RP_tot_time + HC_tot_time);
- if (mut_cpu < 0) { mut_cpu = 0; }
-
statsPrintf(" MUT time %6.2fs (%6.2fs elapsed)\n",
TICK_TO_DBL(mut_cpu), TICK_TO_DBL(mut_elapsed));
statsPrintf(" GC time %6.2fs (%6.2fs elapsed)\n",
gen_blocks += gcThreadLiveBlocks(i,g);
}
- debugBelch("%5d %7d %9d", g, gen->max_blocks, mut);
+ debugBelch("%5d %7ld %9d", g, (lnat)gen->max_blocks, mut);
gen_slop = gen_blocks * BLOCK_SIZE_W - gen_live;
#ifdef TRACING
#include "GetTime.h"
+#include "GetEnv.h"
#include "Stats.h"
#include "eventlog/EventLog.h"
#include "Threads.h"
#include "Printer.h"
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
#ifdef DEBUG
// debugging flags, set with +RTS -D<something>
int DEBUG_sched;
}
}
+void traceCapsetModify_ (EventTypeNum tag,
+ CapsetID capset,
+ StgWord32 other)
+{
+#ifdef DEBUG
+ if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
+ ACQUIRE_LOCK(&trace_utx);
+
+ tracePreface();
+ switch (tag) {
+ case EVENT_CAPSET_CREATE: // (capset, capset_type)
+ debugBelch("created capset %d of type %d\n", capset, other);
+ break;
+ case EVENT_CAPSET_DELETE: // (capset)
+ debugBelch("deleted capset %d\n", capset);
+ break;
+ case EVENT_CAPSET_ASSIGN_CAP: // (capset, capno)
+ debugBelch("assigned cap %d to capset %d\n", other, capset);
+ break;
+ case EVENT_CAPSET_REMOVE_CAP: // (capset, capno)
+ debugBelch("removed cap %d from capset %d\n", other, capset);
+ break;
+ }
+ RELEASE_LOCK(&trace_utx);
+ } else
+#endif
+ {
+ if (eventlog_enabled) {
+ postCapsetModifyEvent(tag, capset, other);
+ }
+ }
+}
+
+void traceOSProcessInfo_(void) {
+ if (eventlog_enabled) {
+ postCapsetModifyEvent(EVENT_OSPROCESS_PID,
+ CAPSET_OSPROCESS_DEFAULT,
+ getpid());
+
+#if !defined(cygwin32_HOST_OS) && !defined (mingw32_HOST_OS)
+/* Windows has no strong concept of process heirarchy, so no getppid().
+ * In any case, this trace event is mainly useful for tracing programs
+ * that use 'forkProcess' which Windows doesn't support anyway.
+ */
+ postCapsetModifyEvent(EVENT_OSPROCESS_PPID,
+ CAPSET_OSPROCESS_DEFAULT,
+ getppid());
+#endif
+ {
+ char buf[256];
+ snprintf(buf, sizeof(buf), "GHC-%s %s", ProjectVersion, RtsWay);
+ postCapsetStrEvent(EVENT_RTS_IDENTIFIER,
+ CAPSET_OSPROCESS_DEFAULT,
+ buf);
+ }
+ {
+ int argc = 0; char **argv;
+ getFullProgArgv(&argc, &argv);
+ if (argc != 0) {
+ postCapsetVecEvent(EVENT_PROGRAM_ARGS,
+ CAPSET_OSPROCESS_DEFAULT,
+ argc, argv);
+ }
+ }
+ {
+ int envc = 0; char **envv;
+ getProgEnvv(&envc, &envv);
+ if (envc != 0) {
+ postCapsetVecEvent(EVENT_PROGRAM_ENV,
+ CAPSET_OSPROCESS_DEFAULT,
+ envc, envv);
+ }
+ freeProgEnvv(envc, envv);
+ }
+ }
+}
+
void traceEvent_ (Capability *cap, EventTypeNum tag)
{
#ifdef DEBUG
}
}
+void traceEventStartup_(int nocaps)
+{
+ if (eventlog_enabled) {
+ postEventStartup(nocaps);
+ }
+}
#ifdef DEBUG
void traceBegin (const char *str, ...)
#endif /* TRACING */
+typedef StgWord32 CapsetID;
+typedef StgWord16 CapsetType;
+enum CapsetType { CapsetTypeCustom = CAPSET_TYPE_CUSTOM,
+ CapsetTypeOsProcess = CAPSET_TYPE_OSPROCESS,
+ CapsetTypeClockdomain = CAPSET_TYPE_CLOCKDOMAIN };
+#define CAPSET_OSPROCESS_DEFAULT 0
+
// -----------------------------------------------------------------------------
// Message classes
// -----------------------------------------------------------------------------
void traceThreadStatus_ (StgTSO *tso);
+void traceEventStartup_ (int n_caps);
+
+/*
+ * Events for describing capability sets in the eventlog
+ *
+ * Note: unlike other events, these are not conditional on TRACE_sched or
+ * similar because they are not "real" events themselves but provide
+ * information and context for other "real" events. Other events depend on
+ * the capset info events so for simplicity, rather than working out if
+ * they're necessary we always emit them. They should be very low volume.
+ */
+void traceCapsetModify_ (EventTypeNum tag,
+ CapsetID capset,
+ StgWord32 other);
+
+void traceOSProcessInfo_ (void);
+
#else /* !TRACING */
#define traceSchedEvent(cap, tag, tso, other) /* nothing */
#define debugTrace(class, str, ...) /* nothing */
#define debugTraceCap(class, cap, str, ...) /* nothing */
#define traceThreadStatus(class, tso) /* nothing */
+#define traceEventStartup_(n_caps) /* nothing */
+#define traceCapsetModify_(tag, capset, other) /* nothing */
+#define traceOSProcessInfo_() /* nothing */
#endif /* TRACING */
HASKELLEVENT_GC_WORK(cap)
#define dtraceGcDone(cap) \
HASKELLEVENT_GC_DONE(cap)
+#define dtraceCapsetCreate(capset, capset_type) \
+ HASKELLEVENT_CAPSET_CREATE(capset, capset_type)
+#define dtraceCapsetDelete(capset) \
+ HASKELLEVENT_CAPSET_DELETE(capset)
+#define dtraceCapsetAssignCap(capset, capno) \
+ HASKELLEVENT_CAPSET_ASSIGN_CAP(capset, capno)
+#define dtraceCapsetRemoveCap(capset, capno) \
+ HASKELLEVENT_CAPSET_REMOVE_CAP(capset, capno)
#else /* !defined(DTRACE) */
#define dtraceGcIdle(cap) /* nothing */
#define dtraceGcWork(cap) /* nothing */
#define dtraceGcDone(cap) /* nothing */
+#define dtraceCapsetCreate(capset, capset_type) /* nothing */
+#define dtraceCapsetDelete(capset) /* nothing */
+#define dtraceCapsetAssignCap(capset, capno) /* nothing */
+#define dtraceCapsetRemoveCap(capset, capno) /* nothing */
#endif
dtraceCreateSparkThread((EventCapNo)cap->no, (EventThreadID)spark_tid);
}
-// This applies only to dtrace as EVENT_STARTUP in the logging framework is
-// handled specially in 'EventLog.c'.
-//
-INLINE_HEADER void dtraceEventStartup(void)
+INLINE_HEADER void traceEventStartup(void)
{
+ int n_caps;
#ifdef THREADED_RTS
// XXX n_capabilities hasn't been initislised yet
- dtraceStartup(RtsFlags.ParFlags.nNodes);
+ n_caps = RtsFlags.ParFlags.nNodes;
#else
- dtraceStartup(1);
+ n_caps = 1;
#endif
+
+ traceEventStartup_(n_caps);
+ dtraceStartup(n_caps);
}
INLINE_HEADER void traceEventGcIdle(Capability *cap STG_UNUSED)
dtraceGcDone((EventCapNo)cap->no);
}
+INLINE_HEADER void traceCapsetCreate(CapsetID capset STG_UNUSED,
+ CapsetType capset_type STG_UNUSED)
+{
+ traceCapsetModify_(EVENT_CAPSET_CREATE, capset, capset_type);
+ dtraceCapsetCreate(capset, capset_type);
+}
+
+INLINE_HEADER void traceCapsetDelete(CapsetID capset STG_UNUSED)
+{
+ traceCapsetModify_(EVENT_CAPSET_DELETE, capset, 0);
+ dtraceCapsetDelete(capset);
+}
+
+INLINE_HEADER void traceCapsetAssignCap(CapsetID capset STG_UNUSED,
+ nat capno STG_UNUSED)
+{
+ traceCapsetModify_(EVENT_CAPSET_ASSIGN_CAP, capset, capno);
+ dtraceCapsetAssignCap(capset, capno);
+}
+
+INLINE_HEADER void traceCapsetRemoveCap(CapsetID capset STG_UNUSED,
+ nat capno STG_UNUSED)
+{
+ traceCapsetModify_(EVENT_CAPSET_REMOVE_CAP, capset, capno);
+ dtraceCapsetRemoveCap(capset, capno);
+}
+
+INLINE_HEADER void traceOSProcessInfo(void)
+{
+ traceOSProcessInfo_();
+ /* Note: no DTrace equivalent because all this OS process info
+ * is available to DTrace directly */
+}
+
#include "EndPrivate.h"
#endif /* TRACE_H */
[EVENT_GC_IDLE] = "GC idle",
[EVENT_GC_WORK] = "GC working",
[EVENT_GC_DONE] = "GC done",
- [EVENT_BLOCK_MARKER] = "Block marker"
+ [EVENT_BLOCK_MARKER] = "Block marker",
+ [EVENT_CAPSET_CREATE] = "Create capability set",
+ [EVENT_CAPSET_DELETE] = "Delete capability set",
+ [EVENT_CAPSET_ASSIGN_CAP] = "Add capability to capability set",
+ [EVENT_CAPSET_REMOVE_CAP] = "Remove capability from capability set",
+ [EVENT_RTS_IDENTIFIER] = "RTS name and version",
+ [EVENT_PROGRAM_ARGS] = "Program arguments",
+ [EVENT_PROGRAM_ENV] = "Program environment variables",
+ [EVENT_OSPROCESS_PID] = "Process ID",
+ [EVENT_OSPROCESS_PPID] = "Parent process ID"
};
// Event type.
static inline void postCapNo(EventsBuf *eb, EventCapNo no)
{ postWord16(eb,no); }
+static inline void postCapsetID(EventsBuf *eb, EventCapsetID id)
+{ postWord32(eb,id); }
+
+static inline void postCapsetType(EventsBuf *eb, EventCapsetType type)
+{ postWord16(eb,type); }
+
static inline void postPayloadSize(EventsBuf *eb, EventPayloadSize size)
{ postWord16(eb,size); }
eventTypes[t].size = sizeof(EventCapNo);
break;
+ case EVENT_CAPSET_CREATE: // (capset, capset_type)
+ eventTypes[t].size =
+ sizeof(EventCapsetID) + sizeof(EventCapsetType);
+ break;
+
+ case EVENT_CAPSET_DELETE: // (capset)
+ eventTypes[t].size = sizeof(EventCapsetID);
+ break;
+
+ case EVENT_CAPSET_ASSIGN_CAP: // (capset, cap)
+ case EVENT_CAPSET_REMOVE_CAP:
+ eventTypes[t].size =
+ sizeof(EventCapsetID) + sizeof(EventCapNo);
+ break;
+
+ case EVENT_OSPROCESS_PID: // (cap, pid)
+ case EVENT_OSPROCESS_PPID:
+ eventTypes[t].size =
+ sizeof(EventCapsetID) + sizeof(StgWord32);
+ break;
+
case EVENT_SHUTDOWN: // (cap)
case EVENT_REQUEST_SEQ_GC: // (cap)
case EVENT_REQUEST_PAR_GC: // (cap)
case EVENT_LOG_MSG: // (msg)
case EVENT_USER_MSG: // (msg)
+ case EVENT_RTS_IDENTIFIER: // (capset, str)
+ case EVENT_PROGRAM_ARGS: // (capset, strvec)
+ case EVENT_PROGRAM_ENV: // (capset, strvec)
eventTypes[t].size = 0xffff;
break;
// Prepare event buffer for events (data).
postInt32(&eventBuf, EVENT_DATA_BEGIN);
-
- // Post a STARTUP event with the number of capabilities
- postEventHeader(&eventBuf, EVENT_STARTUP);
- postCapNo(&eventBuf, n_caps);
// Flush capEventBuf with header.
/*
}
}
+void postCapsetModifyEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ StgWord32 other)
+{
+ ACQUIRE_LOCK(&eventBufMutex);
+
+ if (!hasRoomForEvent(&eventBuf, tag)) {
+ // Flush event buffer to make room for new event.
+ printAndClearEventBuf(&eventBuf);
+ }
+
+ postEventHeader(&eventBuf, tag);
+ postCapsetID(&eventBuf, capset);
+
+ switch (tag) {
+ case EVENT_CAPSET_CREATE: // (capset, capset_type)
+ {
+ postCapsetType(&eventBuf, other /* capset_type */);
+ break;
+ }
+
+ case EVENT_CAPSET_DELETE: // (capset)
+ {
+ break;
+ }
+
+ case EVENT_CAPSET_ASSIGN_CAP: // (capset, capno)
+ case EVENT_CAPSET_REMOVE_CAP: // (capset, capno)
+ {
+ postCapNo(&eventBuf, other /* capno */);
+ break;
+ }
+ case EVENT_OSPROCESS_PID: // (capset, pid)
+ case EVENT_OSPROCESS_PPID: // (capset, parent_pid)
+ {
+ postWord32(&eventBuf, other);
+ break;
+ }
+ default:
+ barf("postCapsetModifyEvent: unknown event tag %d", tag);
+ }
+
+ RELEASE_LOCK(&eventBufMutex);
+}
+
+void postCapsetStrEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ char *msg)
+{
+ int strsize = strlen(msg);
+ int size = strsize + sizeof(EventCapsetID);
+
+ ACQUIRE_LOCK(&eventBufMutex);
+
+ if (!hasRoomForVariableEvent(&eventBuf, size)){
+ printAndClearEventBuf(&eventBuf);
+
+ if (!hasRoomForVariableEvent(&eventBuf, size)){
+ // Event size exceeds buffer size, bail out:
+ RELEASE_LOCK(&eventBufMutex);
+ return;
+ }
+ }
+
+ postEventHeader(&eventBuf, tag);
+ postPayloadSize(&eventBuf, size);
+ postCapsetID(&eventBuf, capset);
+
+ postBuf(&eventBuf, (StgWord8*) msg, strsize);
+
+ RELEASE_LOCK(&eventBufMutex);
+}
+
+void postCapsetVecEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ int argc,
+ char *argv[])
+{
+ int i, size = sizeof(EventCapsetID);
+
+ for (i = 0; i < argc; i++) {
+ // 1 + strlen to account for the trailing \0, used as separator
+ size += 1 + strlen(argv[i]);
+ }
+
+ ACQUIRE_LOCK(&eventBufMutex);
+
+ if (!hasRoomForVariableEvent(&eventBuf, size)){
+ printAndClearEventBuf(&eventBuf);
+
+ if(!hasRoomForVariableEvent(&eventBuf, size)){
+ // Event size exceeds buffer size, bail out:
+ RELEASE_LOCK(&eventBufMutex);
+ return;
+ }
+ }
+
+ postEventHeader(&eventBuf, tag);
+ postPayloadSize(&eventBuf, size);
+ postCapsetID(&eventBuf, capset);
+
+ for( i = 0; i < argc; i++ ) {
+ // again, 1 + to account for \0
+ postBuf(&eventBuf, (StgWord8*) argv[i], 1 + strlen(argv[i]));
+ }
+
+ RELEASE_LOCK(&eventBufMutex);
+}
+
void
postEvent (Capability *cap, EventTypeNum tag)
{
postLogMsg(&capEventBuf[cap->no], EVENT_USER_MSG, msg, ap);
}
+void postEventStartup(EventCapNo n_caps)
+{
+ ACQUIRE_LOCK(&eventBufMutex);
+
+ if (!hasRoomForEvent(&eventBuf, EVENT_STARTUP)) {
+ // Flush event buffer to make room for new event.
+ printAndClearEventBuf(&eventBuf);
+ }
+
+ // Post a STARTUP event with the number of capabilities
+ postEventHeader(&eventBuf, EVENT_STARTUP);
+ postCapNo(&eventBuf, n_caps);
+
+ RELEASE_LOCK(&eventBufMutex);
+}
+
void closeBlockMarker (EventsBuf *ebuf)
{
StgInt8* save_pos;
void postCapMsg(Capability *cap, char *msg, va_list ap);
+void postEventStartup(EventCapNo n_caps);
+
+/*
+ * Post a capability set modification event
+ */
+void postCapsetModifyEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ StgWord32 other);
+
+/*
+ * Post a capability set event with a string payload
+ */
+void postCapsetStrEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ char *msg);
+
+/*
+ * Post a capability set event with several strings payload
+ */
+void postCapsetVecEvent (EventTypeNum tag,
+ EventCapsetID capset,
+ int argc,
+ char *msg[]);
+
#else /* !TRACING */
INLINE_HEADER void postSchedEvent (Capability *cap STG_UNUSED,
rts/RtsMessages_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
rts/RtsUtils_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
+rts/Trace_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
#
rts/RtsUtils_CC_OPTS += -DHostPlatform=\"$(HOSTPLATFORM)\"
rts/RtsUtils_CC_OPTS += -DHostArch=\"$(HostArch_CPP)\"
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2011
+ *
+ * Access to the process environment variables
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "GetEnv.h"
+
+#if defined(darwin_HOST_OS)
+
+/* While the "extern char** environ" var does exist on OSX, it is not
+ * available to shared libs. See ghc ticket #2458 and
+ * http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html
+ */
+#include <crt_externs.h>
+
+static char** get_environ(void) { return *(_NSGetEnviron()); }
+
+#else
+
+/* On proper unix systems the environ is just a global var.
+ */
+extern char** environ;
+static char** get_environ(void) { return environ; }
+
+#endif
+
+
+void getProgEnvv(int *out_envc, char **out_envv[]) {
+ int envc;
+ char **environ = get_environ();
+
+ for (envc = 0; environ[envc] != NULL; envc++) {};
+
+ *out_envc = envc;
+ *out_envv = environ;
+}
+
+void freeProgEnvv(int envc STG_UNUSED, char *envv[] STG_UNUSED) {
+ /* nothing */
+}
// NO MORE EVACUATION AFTER THIS POINT!
- // Two-space collector: free the old to-space.
- // g0->old_blocks is the old nursery
- // g0->blocks is to-space from the previous GC
- if (RtsFlags.GcFlags.generations == 1) {
- if (g0->blocks != NULL) {
- freeChain(g0->blocks);
- g0->blocks = NULL;
- }
- }
-
// Finally: compact or sweep the oldest generation.
if (major_gc && oldest_gen->mark) {
if (oldest_gen->compact)
// for a compacted generation, we need to allocate the bitmap
if (gen->mark) {
- nat bitmap_size; // in bytes
+ lnat bitmap_size; // in bytes
bdescr *bitmap_bdescr;
StgWord *bitmap;
--- /dev/null
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 2011
+ *
+ * Access to the process environment variables
+ *
+ * ---------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "GetEnv.h"
+
+#include <windows.h>
+
+/* Windows does it differently, though arguably the most sanely.
+ * GetEnvironmentStrings() returns a pointer to a block of
+ * environment vars with a double null terminator:
+ * Var1=Value1\0
+ * Var2=Value2\0
+ * ...
+ * VarN=ValueN\0\0
+ * But because everyone else (ie POSIX) uses a vector of strings, we convert
+ * to that format. Fortunately this is just a matter of making an array of
+ * offsets into the environment block.
+ *
+ * Note that we have to call FreeEnvironmentStrings() at the end.
+ *
+ */
+void getProgEnvv(int *out_envc, char **out_envv[]) {
+ int envc, i;
+ char *env;
+ char *envp;
+ char **envv;
+
+ /* For now, use the 'A'nsi not 'W'ide variant.
+ Note: corresponding Free below must use the same 'A'/'W' variant. */
+ env = GetEnvironmentStringsA();
+
+ envc = 0;
+ for (envp = env; *envp != 0; envp += strlen(envp) + 1) {
+ envc++;
+ }
+
+ envv = stgMallocBytes(sizeof(char*) * (envc+1));
+
+ i = 0;
+ for (envp = env; *envp != NULL; envp += strlen(envp) + 1) {
+ envv[i] = envp;
+ i++;
+ }
+ /* stash whole env in last+1 entry */
+ envv[envc] = env;
+
+ *out_envc = envc;
+ *out_envv = envv;
+}
+
+void freeProgEnvv(int envc, char *envv[]) {
+ /* we stashed the win32 env block in the last+1 entry */
+ FreeEnvironmentStringsA(envv[envc]);
+ stgFree(envv);
+}
$1_$2_CONFIGURE_OPTS += $$(BOOT_PKG_CONSTRAINTS)
endif
+$1_$2_CONFIGURE_OPTS += --with-gcc="$$(CC_STAGE$3)"
+$1_$2_CONFIGURE_OPTS += --configure-option=--with-cc="$$(CC_STAGE$3)"
+$1_$2_CONFIGURE_OPTS += --with-ar="$$(AR_STAGE$3)"
+$1_$2_CONFIGURE_OPTS += --with-ranlib="$$(RANLIB)"
+
ifneq "$$(BINDIST)" "YES"
ifneq "$$(NO_GENERATED_MAKEFILE_RULES)" "YES"
$1/$2/inplace-pkg-config : $1/$2/package-data.mk
# for our build system, and registers the package for use in-place in
# the build tree.
$1/$2/package-data.mk : $$(GHC_CABAL_INPLACE) $$($1_$2_GHC_PKG_DEP) $1/$$($1_PACKAGE).cabal $$(wildcard $1/configure) $$($1_$2_HC_CONFIG_DEP)
- "$$(GHC_CABAL_INPLACE)" configure --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" --with-gcc="$$(WhatGccIsCalled)" --configure-option=--with-cc="$$(WhatGccIsCalled)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) -- $2 $1
+ "$$(GHC_CABAL_INPLACE)" configure --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) -- $2 $1
ifeq "$$($1_$2_PROG)" ""
ifneq "$$($1_$2_REGISTER_PACKAGE)" "NO"
"$$($1_$2_GHC_PKG)" update --force $$($1_$2_GHC_PKG_OPTS) $1/$2/inplace-pkg-config
# On windows we have to supply the extra libs this one links to when building it.
ifeq "$$(HOSTPLATFORM)" "i386-unknown-mingw32"
$$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS)
- "$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \
+ "$$($1_$2_HC)" $$($1_$2_$3_ALL_HC_OPTS) $$($1_$2_$3_ALL_OBJS) \
-shared -dynamic -dynload deploy \
$$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) \
- -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \
+ -no-auto-link-packages \
-o $$@
else
$$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS)
- "$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \
+ "$$($1_$2_HC)" $$($1_$2_$3_ALL_HC_OPTS) $$($1_$2_$3_ALL_OBJS) \
-shared -dynamic -dynload deploy \
-dylib-install-name $(ghclibdir)/`basename "$$@" | sed 's/^libHS//;s/[-]ghc.*//'`/`basename "$$@"` \
- -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \
+ -no-auto-link-packages \
-o $$@
endif
else
"$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@
$1/$2/build/%.$$($3_osuf) : $1/$2/build/%.$$($3_way_)s
- "$$(AS)" $$($1_$2_$3_ALL_AS_OPTS) -o $$@ $$<
+ "$$($1_$2_AS)" $$($1_$2_$3_ALL_AS_OPTS) -o $$@ $$<
$1/$2/build/%.$$($3_osuf) : $1/%.S | $$$$(dir $$$$@)/.
"$$($1_$2_CC)" $$($1_$2_$3_ALL_CC_OPTS) -c $$< -o $$@
# Options for a Haskell compilation:
# - CONF_HC_OPTS source-tree-wide options, selected at
-# configure-time
+# configure-time
# - SRC_HC_OPTS source-tree-wide options from build.mk
-# (optimisation, heap settings)
+# (optimisation, heap settings)
# - libraries/base_HC_OPTS options from Cabal for libraries/base
# for all ways
# - libraries/base_MORE_HC_OPTS options from elsewhere in the build
# - libraries/base_v_HC_OPTS options from libraries/base for way v
# - WAY_v_HC_OPTS options for this way
# - EXTRA_HC_OPTS options from the command-line
-# - -Idir1 -Idir2 ... include-dirs from this package
+# - -Idir1 -Idir2 ... include-dirs from this package
# - -odir/-hidir/-stubdir put the output files under $3/build
# - -osuf/-hisuf/-hcsuf suffixes for the output files in this way
--cflag=-D__GLASGOW_HASKELL__=$$(ProjectVersionInt) \
$$($1_$2_$3_HSC2HS_CC_OPTS) \
$$($1_$2_$3_HSC2HS_LD_OPTS) \
+ --cflag=-I$1/$2/build/autogen \
+ $$(if $$($1_PACKAGE),--cflag=-include --cflag=$1/$2/build/autogen/cabal_macros.h) \
$$($$(basename $$<)_HSC2HS_OPTS) \
$$(EXTRA_HSC2HS_OPTS)
$1_$2_HC = $$(GHC_STAGE$3)
$1_$2_CC = $$(CC_STAGE$3)
+$1_$2_AS = $$(AS_STAGE$3)
$1_$2_AR = $$(AR_STAGE$3)
$1_$2_AR_OPTS = $$(AR_OPTS_STAGE$3)
$1_$2_EXTRA_AR_ARGS = $$(EXTRA_AR_ARGS_STAGE$3)
echo 'datadir="$$(datadir)"' >> "$$(WRAPPER)"
echo 'bindir="$$(bindir)"' >> "$$(WRAPPER)"
echo 'topdir="$$(topdir)"' >> "$$(WRAPPER)"
- echo 'pgmgcc="$$(WhatGccIsCalled)"' >> "$$(WRAPPER)"
$$($1_$2_SHELL_WRAPPER_EXTRA)
$$($1_$2_INSTALL_SHELL_WRAPPER_EXTRA)
cat $$($1_$2_SHELL_WRAPPER_NAME) >> "$$(WRAPPER)"
[("GCC extra via C opts", "@GccExtraViaCOpts@"),
("C compiler command", "@WhatGccIsCalled@"),
+ ("C compiler flags", "@CONF_CC_OPTS_STAGE2@"),
+ ("ar command", "@ArCmd@"),
+ ("ar flags", "@ArArgs@"),
+ ("ar supports at file", "@ArSupportsAtFile@"),
("perl command", "@PerlCmd@")]
if (-d "$localpath/.git") {
die "Found both _darcs and .git in $localpath";
}
- else {
- $scm = "darcs";
- }
- }
- else {
- if (-d "$localpath/.git") {
- $scm = "git";
- }
- elsif ($tag eq "") {
- die "Required repo $localpath is missing";
- }
- else {
- message "== $localpath repo not present; skipping";
- }
+ $scm = "darcs";
+ } elsif (-d "$localpath/.git") {
+ $scm = "git";
+ } elsif ($tag eq "") {
+ die "Required repo $localpath is missing";
+ } else {
+ message "== $localpath repo not present; skipping";
+ next;
}
# Work out the arguments we should give to the SCM
my @scm_args = ("log", "$branch_name..");
scm ($localpath, $scm, @scm_args, @args);
}
+ elsif ($command =~ /^log$/) {
+ scm ($localpath, $scm, "log", @args);
+ }
elsif ($command =~ /^remote$/) {
my @scm_args;
if ($subcommand eq 'add') {
}
scm ($localpath, $scm, @scm_args, @args);
}
+ elsif ($command =~ /^checkout$/) {
+ # Not all repos are necessarily branched, so ignore failure
+ $ignore_failure = 1;
+ scm ($localpath, $scm, "checkout", @args)
+ unless $scm eq "darcs";
+ }
elsif ($command =~ /^grep$/) {
# Hack around 'git grep' failing if there are no matches
$ignore_failure = 1;
* remote add <branch-name>
* remote rm <branch-name>
* remote set-url [--push] <branch-name>
+ * checkout
* grep
* clean
* reset
* config
+ * log
Available package-tags are:
END
WITH_BOOTSTRAPPING_COMPILER = installPackage ghc-pkg hsc2hs hpc
-WITH_STAGE2 = installPackage ghc-pkg hasktags runghc hpc pwd haddock
+WITH_STAGE2 = installPackage ghc-pkg runghc hpc pwd haddock
ifneq "$(NO_INSTALL_HSC2HS)" "YES"
WITH_STAGE2 += hsc2hs
endif
--- /dev/null
+#! /usr/bin/env python
+# Script to create and restore a git fingerprint of the ghc repositories.
+
+from datetime import datetime
+from optparse import OptionParser
+import os
+import os.path
+import re
+import subprocess
+from subprocess import PIPE, Popen
+import sys
+
+def main():
+ opts, args = parseopts(sys.argv[1:])
+ opts.action(opts)
+
+def create_action(opts):
+ """Action called for the create commmand"""
+ if opts.fpfile:
+ fp = FingerPrint.read(opts.source)
+ else:
+ fp = fingerprint(opts.source)
+ if len(fp) == 0:
+ error("Got empty fingerprint from source: "+str(opts.source))
+ if opts.output_file:
+ print "Writing fingerprint to: ", opts.output_file
+ fp.write(opts.output)
+
+def restore_action(opts):
+ """Action called for the restore commmand"""
+ def branch_name(filename):
+ return "fingerprint_" + os.path.basename(filename).replace(".", "_")
+ if opts.fpfile:
+ try:
+ fp = FingerPrint.read(opts.source)
+ bn = branch_name(opts.fpfile)
+ except MalformedFingerPrintError:
+ error("Error parsing fingerprint file: "+opts.fpfile)
+ if len(fp) == 0:
+ error("No fingerprint found in fingerprint file: "+opts.fpfile)
+ elif opts.logfile:
+ fp = fingerprint(opts.source)
+ bn = branch_name(opts.logfile)
+ if len(fp) == 0:
+ error("No fingerprint found in build log file: "+opts.logfile)
+ else:
+ error("Must restore from fingerprint or log file")
+ restore(fp, branch_name=bn if opts.branch else None)
+
+def fingerprint(source=None):
+ """Create a new fingerprint of current repositories.
+
+ The source argument is parsed to look for the expected output
+ from a `sync-all` command. If the source is `None` then the
+ `sync-all` command will be run to get the current fingerprint.
+ """
+ if source is None:
+ sync_all = ["./sync-all", "log", "HEAD^..", "--pretty=oneline"]
+ source = Popen(sync_all, stdout=PIPE).stdout
+
+ lib = ""
+ commits = {}
+ for line in source.readlines():
+ if line.startswith("=="):
+ lib = line.split()[1].rstrip(":")
+ lib = "." if lib == "running" else lib # hack for top ghc repo
+ elif re.match("[abcdef0-9]{40}", line):
+ commit = line[:40]
+ commits[lib] = commit
+ return FingerPrint(commits)
+
+def restore(fp, branch_name=None):
+ """Restore the ghc repos to the commits in the fingerprint
+
+ This function performs a checkout of each commit specifed in
+ the fingerprint. If `branch_name` is not None then a new branch
+ will be created for the top ghc repository. We also add an entry
+ to the git config that sets the remote for the new branch as `origin`
+ so that the `sync-all` command can be used from the branch.
+ """
+ checkout = ["git", "checkout"]
+
+ # run checkout in all subdirs
+ for (subdir, commit) in fp:
+ if subdir != ".":
+ cmd = checkout + [commit]
+ print "==", subdir, " ".join(cmd)
+ if os.path.exists(subdir):
+ rc = subprocess.call(cmd, cwd=subdir)
+ if rc != 0:
+ error("Too many errors, aborting")
+ else:
+ sys.stderr.write("WARNING: "+
+ subdir+" is in fingerprint but missing in working directory\n")
+
+ # special handling for top ghc repo
+ # if we are creating a new branch then also add an entry to the
+ # git config so the sync-all command is happy
+ branch_args = ["-b", branch_name] if branch_name else []
+ rc = subprocess.call(checkout + branch_args + [fp["."]])
+ if (rc == 0) and branch_name:
+ branch_config = "branch."+branch_name+".remote"
+ subprocess.call(["git", "config", "--add", branch_config, "origin"])
+
+actions = {"create" : create_action, "restore" : restore_action}
+def parseopts(argv):
+ """Parse and check the validity of the command line arguments"""
+ usage = "fingerprint ("+"|".join(sorted(actions.keys()))+") [options]"
+ parser = OptionParser(usage=usage)
+
+ parser.add_option("-d", "--dir", dest="dir",
+ help="write output to directory DIR", metavar="DIR")
+
+ parser.add_option("-o", "--output", dest="output",
+ help="write output to file FILE", metavar="FILE")
+
+ parser.add_option("-l", "--from-log", dest="logfile",
+ help="reconstruct fingerprint from build log", metavar="FILE")
+
+ parser.add_option("-f", "--from-fp", dest="fpfile",
+ help="reconstruct fingerprint from fingerprint file", metavar="FILE")
+
+ parser.add_option("-n", "--no-branch",
+ action="store_false", dest="branch", default=True,
+ help="do not create a new branch when restoring fingerprint")
+
+ parser.add_option("-g", "--ghc-dir", dest="ghcdir",
+ help="perform actions in GHC dir", metavar="DIR")
+
+ opts,args = parser.parse_args(argv)
+ return (validate(opts, args, parser), args)
+
+def validate(opts, args, parser):
+ """ Validate and prepare the command line options.
+
+ It performs the following actions:
+ * Check that we have a valid action to perform
+ * Check that we have a valid output destination
+ * Opens the output file if needed
+ * Opens the input file if needed
+ """
+ # Determine the action
+ try:
+ opts.action = actions[args[0]]
+ except (IndexError, KeyError):
+ error("Must specify a valid action", parser)
+
+ # Inputs
+ if opts.logfile and opts.fpfile:
+ error("Must specify only one of -l and -f")
+
+ opts.source = None
+ if opts.logfile:
+ opts.source = file(opts.logfile, "r")
+ elif opts.fpfile:
+ opts.source = file(opts.fpfile, "r")
+
+ # Outputs
+ if opts.dir:
+ fname = opts.output
+ if fname is None:
+ fname = datetime.today().strftime("%Y-%m%-%d_%H-%M-%S") + ".fp"
+ path = os.path.join(opts.dir, fname)
+ opts.output_file = path
+ opts.output = file(path, "w")
+ elif opts.output:
+ opts.output_file = opts.output
+ opts.output = file(opts.output_file, "w")
+ else:
+ opts.output_file = None
+ opts.output = sys.stdout
+
+ # GHC Directory
+ # As a last step change the directory to the GHC directory specified
+ if opts.ghcdir:
+ os.chdir(opts.ghcdir)
+
+ return opts
+
+def error(msg="fatal error", parser=None, exit=1):
+ """Function that prints error message and exits"""
+ print "ERROR:", msg
+ if parser:
+ parser.print_help()
+ sys.exit(exit)
+
+class MalformedFingerPrintError(Exception):
+ """Exception raised when parsing a bad fingerprint file"""
+ pass
+
+class FingerPrint:
+ """Class representing a fingerprint of all ghc git repos.
+
+ A finger print is represented by a dictionary that maps a
+ directory to a commit. The directory "." is used for the top
+ level ghc repository.
+ """
+ def __init__(self, subcommits = {}):
+ self.commits = subcommits
+
+ def __eq__(self, other):
+ if other.__class__ != self.__class__:
+ raise TypeError
+ return self.commits == other.commits
+
+ def __neq__(self, other):
+ not(self == other)
+
+ def __hash__(self):
+ return hash(str(self))
+
+ def __len__(self):
+ return len(self.commits)
+
+ def __repr__(self):
+ return "FingerPrint(" + repr(self.commits) + ")"
+
+ def __str__(self):
+ s = ""
+ for lib in sorted(self.commits.keys()):
+ commit = self.commits[lib]
+ s += "{0}|{1}\n".format(lib, commit)
+ return s
+
+ def __getitem__(self, item):
+ return self.commits[item]
+
+ def __iter__(self):
+ return self.commits.iteritems()
+
+ def write(self, outh):
+ outh.write(str(self))
+ outh.flush()
+
+ @staticmethod
+ def read(inh):
+ """Read a fingerprint from a fingerprint file"""
+ commits = {}
+ for line in inh.readlines():
+ splits = line.strip().split("|", 1)
+ if len(splits) != 2:
+ raise MalformedFingerPrintError(line)
+ lib, commit = splits
+ commits[lib] = commit
+ return FingerPrint(commits)
+
+if __name__ == "__main__":
+ main()
<0> "thats_all_folks" { mkT TThatsAllFolks }
<0> [a-z][a-zA-Z0-9\#_]* { mkTv TLowerName }
<0> [A-Z][a-zA-Z0-9\#_]* { mkTv TUpperName }
+ <0> [0-9][0-9]* { mkTv (TInteger . read) }
<0> \" [^\"]* \" { mkTv (TString . tail . init) }
<in_braces> [^\{\}]+ { mkTv TNoBraces }
<in_braces> \n { mkTv TNoBraces }
"commutable"
"commutableOp" p_o_specs)
- "--needs-wrapper"
+ "--code-size"
-> putStr (gen_switch_from_attribs
- "needs_wrapper"
- "primOpNeedsWrapper" p_o_specs)
+ "code_size"
+ "primOpCodeSize" p_o_specs)
- "--can-fail"
- -> putStr (gen_switch_from_attribs
+ "--can-fail"
+ -> putStr (gen_switch_from_attribs
"can_fail"
"primOpCanFail" p_o_specs)
"--has-side-effects",
"--out-of-line",
"--commutable",
- "--needs-wrapper",
+ "--code-size",
"--can-fail",
"--strictness",
"--primop-primop-info",
where opt (OptionFalse n) = n ++ " = False"
opt (OptionTrue n) = n ++ " = True"
opt (OptionString n v) = n ++ " = { " ++ v ++ "}"
+ opt (OptionInteger n v) = n ++ " = " ++ show v
hdr s@(Section {}) = sec s
hdr (PrimOpSpec { name = n }) = wrapOp n ++ ","
Just (OptionTrue _) -> if_true
Just (OptionFalse _) -> if_false
Just (OptionString _ _) -> error "String value for boolean option"
- Nothing -> ""
+ Just (OptionInteger _ _) -> error "Integer value for boolean option"
+ Nothing -> ""
mk_strictness o =
case lookup_attrib "strictness" o of
getAltRhs (OptionFalse _) = "False"
getAltRhs (OptionTrue _) = "True"
+ getAltRhs (OptionInteger _ i) = show i
getAltRhs (OptionString _ s) = s
mkAlt po
lowerName { TLowerName $$ }
upperName { TUpperName $$ }
string { TString $$ }
+ integer { TInteger $$ }
noBraces { TNoBraces $$ }
%%
pOption : lowerName '=' false { OptionFalse $1 }
| lowerName '=' true { OptionTrue $1 }
| lowerName '=' pStuffBetweenBraces { OptionString $1 $3 }
+ | lowerName '=' integer { OptionInteger $1 $3 }
pEntries :: { [Entry] }
pEntries : pEntry pEntries { $1 : $2 }
| TUpperName String
| TString String
| TNoBraces String
+ | TInteger Int
deriving Show
-- Actions
= OptionFalse String -- name = False
| OptionTrue String -- name = True
| OptionString String String -- name = { ... unparsed stuff ... }
+ | OptionInteger String Int -- name = <int>
deriving Show
-- categorises primops
get_attrib_name (OptionFalse nm) = nm
get_attrib_name (OptionTrue nm) = nm
get_attrib_name (OptionString nm _) = nm
+get_attrib_name (OptionInteger nm _) = nm
lookup_attrib :: String -> [Option] -> Maybe Option
lookup_attrib _ [] = Nothing
pd lib lbi clbi
final_ipi = installedPkgInfo {
Installed.installedPackageId = ipid,
- Installed.haddockHTMLs = ["../" ++ display (packageId pd)]
+ Installed.haddockHTMLs = []
}
content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
writeFileAtomic (distdir </> "inplace-pkg-config") (toUTF8 content)
import Distribution.Package hiding (depends)
import Distribution.Text
import Distribution.Version
-import System.FilePath
+import System.FilePath as FilePath
+import qualified System.FilePath.Posix as FilePath.Posix
import System.Cmd ( rawSystem )
import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
getModificationTime )
import Data.Char ( isSpace, toLower )
import Control.Monad
import System.Directory ( doesDirectoryExist, getDirectoryContents,
- doesFileExist, renameFile, removeFile )
+ doesFileExist, renameFile, removeFile,
+ getCurrentDirectory )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getProgName, getEnv )
import System.IO
| FlagForce
| FlagForceFiles
| FlagAutoGHCiLibs
+ | FlagExpandEnvVars
+ | FlagExpandPkgroot
+ | FlagNoExpandPkgroot
| FlagSimpleOutput
| FlagNamesOnly
| FlagIgnoreCase
"ignore missing directories and libraries only",
Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
"automatically build libs for GHCi (with register)",
+ Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
+ "expand environment variables (${name}-style) in input package descriptions",
+ Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
+ "expand ${pkgroot}-relative paths to absolute in output package descriptions",
+ Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
+ "preserve ${pkgroot}-relative paths in output package descriptions",
Option ['?'] ["help"] (NoArg FlagHelp)
"display this help and exit",
Option ['V'] ["version"] (NoArg FlagVersion)
| FlagForceFiles `elem` cli = ForceFiles
| otherwise = NoForce
auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
+ expand_env_vars= FlagExpandEnvVars `elem` cli
+ mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
+ where accumExpandPkgroot _ FlagExpandPkgroot = Just True
+ accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
+ accumExpandPkgroot x _ = x
+
splitFields fields = unfoldr splitComma (',':fields)
where splitComma "" = Nothing
splitComma fs = Just $ break (==',') (tail fs)
["init", filename] ->
initPackageDB filename verbosity cli
["register", filename] ->
- registerPackage filename verbosity cli auto_ghci_libs False force
+ registerPackage filename verbosity cli
+ auto_ghci_libs expand_env_vars False force
["update", filename] ->
- registerPackage filename verbosity cli auto_ghci_libs True force
+ registerPackage filename verbosity cli
+ auto_ghci_libs expand_env_vars True force
["unregister", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
unregisterPackage pkgid verbosity cli force
["latest", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
latestPackage verbosity cli pkgid
- ["describe", pkgid_str] ->
- case substringCheck pkgid_str of
- Nothing -> do pkgid <- readGlobPkgId pkgid_str
- describePackage verbosity cli (Id pkgid)
- Just m -> describePackage verbosity cli (Substring pkgid_str m)
- ["field", pkgid_str, fields] ->
- case substringCheck pkgid_str of
- Nothing -> do pkgid <- readGlobPkgId pkgid_str
- describeField verbosity cli (Id pkgid)
- (splitFields fields)
- Just m -> describeField verbosity cli (Substring pkgid_str m)
- (splitFields fields)
+ ["describe", pkgid_str] -> do
+ pkgarg <- case substringCheck pkgid_str of
+ Nothing -> liftM Id (readGlobPkgId pkgid_str)
+ Just m -> return (Substring pkgid_str m)
+ describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
+
+ ["field", pkgid_str, fields] -> do
+ pkgarg <- case substringCheck pkgid_str of
+ Nothing -> liftM Id (readGlobPkgId pkgid_str)
+ Just m -> return (Substring pkgid_str m)
+ describeField verbosity cli pkgarg
+ (splitFields fields) (fromMaybe True mexpand_pkgroot)
+
["check"] -> do
checkConsistency verbosity cli
["dump"] -> do
- dumpPackages verbosity cli
+ dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
["recache"] -> do
recache verbosity cli
-- list, describe, field
data PackageDB
- = PackageDB { location :: FilePath,
- packages :: [InstalledPackageInfo] }
+ = PackageDB {
+ location, locationAbsolute :: !FilePath,
+ -- We need both possibly-relative and definately-absolute package
+ -- db locations. This is because the relative location is used as
+ -- an identifier for the db, so it is important we do not modify it.
+ -- On the other hand we need the absolute path in a few places
+ -- particularly in relation to the ${pkgroot} stuff.
+
+ packages :: [InstalledPackageInfo]
+ }
type PackageDBStack = [PackageDB]
-- A stack of package databases. Convention: head is the topmost
getPkgDatabases :: Verbosity
-> Bool -- we are modifying, not reading
-> Bool -- read caches, if available
+ -> Bool -- expand vars, like ${pkgroot} and $topdir
-> [Flag]
-> IO (PackageDBStack,
-- the real package DB stack: [global,user] ++
-- is used as the list of package DBs for
-- commands that just read the DB, such as 'list'.
-getPkgDatabases verbosity modify use_cache my_flags = do
+getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
-- first we determine the location of the global package config. On Windows,
-- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
-- location is passed to the binary using the --global-config flag by the
Just path -> return path
fs -> return (last fs)
+ -- The value of the $topdir variable used in some package descriptions
+ -- Note that the way we calculate this is slightly different to how it
+ -- is done in ghc itself. We rely on the convention that the global
+ -- package db lives in ghc's libdir.
+ top_dir <- absolutePath (takeDirectory global_conf)
+
let no_user_db = FlagNoUserDb `elem` my_flags
-- get the location of the user package database, and create it if necessary
| null db_flags = Just virt_global_conf
| otherwise = Just (last db_flags)
- db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
+ db_stack <- sequence
+ [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path
+ if expand_vars then return (mungePackageDBPaths top_dir db)
+ else return db
+ | db_path <- final_stack ]
let flag_db_stack = [ db | db_name <- flag_db_names,
db <- db_stack, location db == db_name ]
readParseDatabase verbosity mb_user_conf use_cache path
-- the user database (only) is allowed to be non-existent
| Just (user_conf,False) <- mb_user_conf, path == user_conf
- = return PackageDB { location = path, packages = [] }
+ = mkPackageDB []
| otherwise
= do e <- tryIO $ getDirectoryContents path
case e of
Left _ -> do
pkgs <- parseMultiPackageConf verbosity path
- return PackageDB{ location = path, packages = pkgs }
+ mkPackageDB pkgs
Right fs
| not use_cache -> ignore_cache
| otherwise -> do
putStrLn ("using cache: " ++ cache)
pkgs <- myReadBinPackageDB cache
let pkgs' = map convertPackageInfoIn pkgs
- return PackageDB { location = path, packages = pkgs' }
+ mkPackageDB pkgs'
| otherwise -> do
when (verbosity >= Normal) $ do
warn ("WARNING: cache is out of date: " ++ cache)
let confs = filter (".conf" `isSuffixOf`) fs
pkgs <- mapM (parseSingletonPackageConf verbosity) $
map (path </>) confs
- return PackageDB { location = path, packages = pkgs }
+ mkPackageDB pkgs
+ where
+ mkPackageDB pkgs = do
+ path_abs <- absolutePath path
+ return PackageDB {
+ location = path,
+ locationAbsolute = path_abs,
+ packages = pkgs
+ }
-- read the package.cache file strictly, to work around a problem with
-- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed
parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
parseSingletonPackageConf verbosity file = do
when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
- readUTF8File file >>= parsePackageInfo
+ readUTF8File file >>= fmap fst . parsePackageInfo
cachefilename :: FilePath
cachefilename = "package.cache"
+mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
+mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
+ db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
+ where
+ pkgroot = takeDirectory (locationAbsolute db)
+ -- It so happens that for both styles of package db ("package.conf"
+ -- files and "package.conf.d" dirs) the pkgroot is the parent directory
+ -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
+
+mungePackagePaths :: FilePath -> FilePath
+ -> InstalledPackageInfo -> InstalledPackageInfo
+-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
+-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
+-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
+-- The "pkgroot" is the directory containing the package database.
+--
+-- Also perform a similar substitution for the older GHC-specific
+-- "$topdir" variable. The "topdir" is the location of the ghc
+-- installation (obtained from the -B option).
+mungePackagePaths top_dir pkgroot pkg =
+ pkg {
+ importDirs = munge_paths (importDirs pkg),
+ includeDirs = munge_paths (includeDirs pkg),
+ libraryDirs = munge_paths (libraryDirs pkg),
+ frameworkDirs = munge_paths (frameworkDirs pkg),
+ haddockInterfaces = munge_paths (haddockInterfaces pkg),
+ haddockHTMLs = munge_urls (haddockHTMLs pkg)
+ }
+ where
+ munge_paths = map munge_path
+ munge_urls = map munge_url
+
+ munge_path p
+ | Just p' <- stripVarPrefix "${pkgroot}" sp = pkgroot </> p'
+ | Just p' <- stripVarPrefix "$topdir" sp = top_dir </> p'
+ | otherwise = p
+ where
+ sp = splitPath p
+
+ munge_url p
+ | Just p' <- stripVarPrefix "${pkgrooturl}" sp = toUrlPath pkgroot p'
+ | Just p' <- stripVarPrefix "$httptopdir" sp = toUrlPath top_dir p'
+ | otherwise = p
+ where
+ sp = splitPath p
+
+ toUrlPath r p = "file:///"
+ -- URLs always use posix style '/' separators:
+ ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
+
+ stripVarPrefix var (root:path')
+ | Just [sep] <- stripPrefix var root
+ , isPathSeparator sep
+ = Just (joinPath path')
+
+ stripVarPrefix _ _ = Nothing
+
+
-- -----------------------------------------------------------------------------
-- Creating a new package DB
when b1 eexist
b2 <- doesDirectoryExist filename
when b2 eexist
- changeDB verbosity [] PackageDB{ location = filename, packages = [] }
+ filename_abs <- absolutePath filename
+ changeDB verbosity [] PackageDB {
+ location = filename, locationAbsolute = filename_abs,
+ packages = []
+ }
-- -----------------------------------------------------------------------------
-- Registering
-> Verbosity
-> [Flag]
-> Bool -- auto_ghci_libs
+ -> Bool -- expand_env_vars
-> Bool -- update
-> Force
-> IO ()
-registerPackage input verbosity my_flags auto_ghci_libs update force = do
+registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
(db_stack, Just to_modify, _flag_dbs) <-
- getPkgDatabases verbosity True True my_flags
+ getPkgDatabases verbosity True True False{-expand vars-} my_flags
let
db_to_operate_on = my_head "register" $
filter ((== to_modify).location) db_stack
--
+ when (auto_ghci_libs && verbosity >= Silent) $
+ warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4"
+ --
s <-
case input of
"-" -> do
putStr ("Reading package info from " ++ show f ++ " ... ")
readUTF8File f
- expanded <- expandEnvVars s force
+ expanded <- if expand_env_vars then expandEnvVars s force
+ else return s
- pkg <- parsePackageInfo expanded
+ (pkg, ws) <- parsePackageInfo expanded
when (verbosity >= Normal) $
putStrLn "done."
+ -- report any warnings from the parse phase
+ _ <- reportValidateErrors [] ws
+ (display (sourcePackageId pkg) ++ ": Warning: ") Nothing
+
+ -- validate the expanded pkg, but register the unexpanded
+ pkgroot <- absolutePath (takeDirectory to_modify)
+ let top_dir = takeDirectory (location (last db_stack))
+ pkg_expanded = mungePackagePaths top_dir pkgroot pkg
+
let truncated_stack = dropWhile ((/= to_modify).location) db_stack
-- truncate the stack for validation, because we don't allow
-- packages lower in the stack to refer to those higher up.
- validatePackageConfig pkg truncated_stack auto_ghci_libs update force
+ validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force
let
removes = [ RemovePackage p
| p <- packages db_to_operate_on,
parsePackageInfo
:: String
- -> IO InstalledPackageInfo
+ -> IO (InstalledPackageInfo, [ValidateWarning])
parsePackageInfo str =
case parseInstalledPackageInfo str of
- ParseOk _warns ok -> return ok
+ ParseOk warnings ok -> return (ok, ws)
+ where
+ ws = [ msg | PWarning msg <- warnings
+ , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ]
ParseFailed err -> case locatedErrorMsg err of
(Nothing, s) -> die s
(Just l, s) -> die (show l ++ ": " ++ s)
-> IO ()
modifyPackage fn pkgid verbosity my_flags force = do
(db_stack, Just _to_modify, _flag_dbs) <-
- getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags
+ getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
(db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
let
recache :: Verbosity -> [Flag] -> IO ()
recache verbosity my_flags = do
(db_stack, Just to_modify, _flag_dbs) <-
- getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags
+ getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags
let
db_to_operate_on = my_head "recache" $
filter ((== to_modify).location) db_stack
listPackages verbosity my_flags mPackageName mModuleName = do
let simple_output = FlagSimpleOutput `elem` my_flags
(db_stack, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
+ getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
let db_stack_filtered -- if a package is given, filter out all other packages
| Just this <- mPackageName =
showPackageDot :: Verbosity -> [Flag] -> IO ()
showPackageDot verbosity myflags = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} myflags
+ getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags
let all_pkgs = allPackagesInStack flag_db_stack
ipix = PackageIndex.fromList all_pkgs
latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO ()
latestPackage verbosity my_flags pkgid = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
+ getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags
ps <- findPackages flag_db_stack (Id pkgid)
show_pkg (sortBy compPkgIdVer (map sourcePackageId ps))
-- -----------------------------------------------------------------------------
-- Describe
-describePackage :: Verbosity -> [Flag] -> PackageArg -> IO ()
-describePackage verbosity my_flags pkgarg = do
+describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
+describePackage verbosity my_flags pkgarg expand_pkgroot = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
- ps <- findPackages flag_db_stack pkgarg
- doDump ps
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+ dbs <- findPackagesByDB flag_db_stack pkgarg
+ doDump expand_pkgroot [ (pkg, locationAbsolute db)
+ | (db, pkgs) <- dbs, pkg <- pkgs ]
-dumpPackages :: Verbosity -> [Flag] -> IO ()
-dumpPackages verbosity my_flags = do
+dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
+dumpPackages verbosity my_flags expand_pkgroot = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
- doDump (allPackagesInStack flag_db_stack)
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
+ doDump expand_pkgroot [ (pkg, locationAbsolute db)
+ | db <- flag_db_stack, pkg <- packages db ]
-doDump :: [InstalledPackageInfo] -> IO ()
-doDump pkgs = do
+doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO ()
+doDump expand_pkgroot pkgs = do
-- fix the encoding to UTF-8, since this is an interchange format
hSetEncoding stdout utf8
- mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs
+ putStrLn $
+ intercalate "---\n"
+ [ if expand_pkgroot
+ then showInstalledPackageInfo pkg
+ else showInstalledPackageInfo pkg ++ pkgrootField
+ | (pkg, pkgloc) <- pkgs
+ , let pkgroot = takeDirectory pkgloc
+ pkgrootField = "pkgroot: " ++ pkgroot ++ "\n" ]
-- PackageId is can have globVersion for the version
findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
-- -----------------------------------------------------------------------------
-- Field
-describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO ()
-describeField verbosity my_flags pkgarg fields = do
+describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
+describeField verbosity my_flags pkgarg fields expand_pkgroot = do
(_, _, flag_db_stack) <-
- getPkgDatabases verbosity False True{-use cache-} my_flags
+ getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags
fns <- toFields fields
ps <- findPackages flag_db_stack pkgarg
- let top_dir = takeDirectory (location (last flag_db_stack))
- mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
+ mapM_ (selectFields fns) ps
where toFields [] = return []
toFields (f:fs) = case toField f of
Nothing -> die ("unknown field: " ++ f)
return (fn:fns)
selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
-mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
--- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
--- with the current topdir (obtained from the -B option).
-mungePackagePaths top_dir ps = map munge_pkg ps
- where
- munge_pkg p = p{ importDirs = munge_paths (importDirs p),
- includeDirs = munge_paths (includeDirs p),
- libraryDirs = munge_paths (libraryDirs p),
- frameworkDirs = munge_paths (frameworkDirs p),
- haddockInterfaces = munge_paths (haddockInterfaces p),
- haddockHTMLs = munge_paths (haddockHTMLs p)
- }
-
- munge_paths = map munge_path
-
- munge_path p
- | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
- | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
- | otherwise = p
-
- toHttpPath p = "file:///" ++ p
-
-maybePrefixMatch :: String -> String -> Maybe String
-maybePrefixMatch [] rest = Just rest
-maybePrefixMatch (_:_) [] = Nothing
-maybePrefixMatch (p:pat) (r:rest)
- | p == r = maybePrefixMatch pat rest
- | otherwise = Nothing
-
toField :: String -> Maybe (InstalledPackageInfo -> String)
-- backwards compatibility:
toField "import_dirs" = Just $ strList . importDirs
checkConsistency :: Verbosity -> [Flag] -> IO ()
checkConsistency verbosity my_flags = do
- (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags
+ (db_stack, _, _) <-
+ getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags
-- check behaves like modify for the purposes of deciding which
-- databases to use, because ordering is important.
mapM_ (checkDir False "import-dirs") (importDirs pkg)
mapM_ (checkDir True "library-dirs") (libraryDirs pkg)
mapM_ (checkDir True "include-dirs") (includeDirs pkg)
+ mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg)
+ mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg)
+ mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg)
checkModules pkg
mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
-- ToDo: check these somehow?
"Package " ++ display pkgid ++
" overlaps with: " ++ unwords (map display dups)
+checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate ()
+checkDir = checkPath False True
+checkFile = checkPath False False
+checkDirURL = checkPath True True
+
+checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate ()
+checkPath url_ok is_dir warn_only thisfield d
+ | url_ok && ("http://" `isPrefixOf` d
+ || "https://" `isPrefixOf` d) = return ()
+
+ | url_ok
+ , Just d' <- stripPrefix "file://" d
+ = checkPath False is_dir warn_only thisfield d'
+
+ -- Note: we don't check for $topdir/${pkgroot} here. We rely on these
+ -- variables having been expanded already, see mungePackagePaths.
-checkDir :: Bool -> String -> String -> Validate ()
-checkDir warn_only thisfield d
- | "$topdir" `isPrefixOf` d = return ()
- | "$httptopdir" `isPrefixOf` d = return ()
- -- can't check these, because we don't know what $(http)topdir is
| isRelative d = verror ForceFiles $
- thisfield ++ ": " ++ d ++ " is a relative path"
+ thisfield ++ ": " ++ d ++ " is a relative path which "
+ ++ "makes no sense (as there is nothing for it to be "
+ ++ "relative to). You can make paths relative to the "
+ ++ "package database itself by using ${pkgroot}."
-- relative paths don't make any sense; #4134
| otherwise = do
- there <- liftIO $ doesDirectoryExist d
+ there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d
when (not there) $
- let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory"
+ let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a "
+ ++ if is_dir then "directory" else "file"
in
if warn_only
then vwarn msg
if b then return (Just p) else go ps
doesFileExistIn :: String -> String -> IO Bool
-doesFileExistIn lib d
- | "$topdir" `isPrefixOf` d = return True
- | "$httptopdir" `isPrefixOf` d = return True
- | otherwise = doesFileExist (d </> lib)
+doesFileExistIn lib d = doesFileExist (d </> lib)
checkModules :: InstalledPackageInfo -> Validate ()
checkModules pkg = do
= go str (c:acc)
lookupEnvVar :: String -> IO String
+ lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special,
+ lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them
lookupEnvVar nm =
catchIO (System.Environment.getEnv nm)
(\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
getExecPath :: IO (Maybe String)
-getExecPath =
- allocaArray len $ \buf -> do
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then return Nothing
- else liftM Just $ peekCString buf
- where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
-
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-
+getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+ where
+ try_size size = allocaArray (fromIntegral size) $ \buf -> do
+ ret <- c_GetModuleFileName nullPtr buf size
+ case ret of
+ 0 -> return Nothing
+ _ | ret < size -> fmap Just $ peekCWString buf
+ | otherwise -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getLibDir :: IO (Maybe String)
getLibDir = return Nothing
removeFileSafe fn =
removeFile fn `catchIO` \ e ->
when (not $ isDoesNotExistError e) $ ioError e
+
+absolutePath :: FilePath -> IO FilePath
+absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
LitPat _ -> tl
NPat _ _ _ -> tl -- form of literal pattern?
NPlusKPat id _ _ _ -> thing id : tl
- TypePat _ -> tl -- XXX need help here
SigPatIn p _ -> patThings p tl
SigPatOut p _ -> patThings p tl
_ -> error "boundThings"
getExecPath :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
-getExecPath =
- allocaArray len $ \buf -> do
- ret <- getModuleFileName nullPtr buf len
- if ret == 0 then return Nothing
- else liftM Just $ peekCString buf
- where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
-
-foreign import stdcall unsafe "GetModuleFileNameA"
- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
+getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+ where
+ try_size size = allocaArray (fromIntegral size) $ \buf -> do
+ ret <- c_GetModuleFileName nullPtr buf size
+ case ret of
+ 0 -> return Nothing
+ _ | ret < size -> fmap Just $ peekCWString buf
+ | otherwise -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
#else
getExecPath = return Nothing
#endif
$make binary-dist-prep
$make test_bindist TEST_PREP=YES
+#
+# Install the mtl package into the bindist, because it is used by some
+# tests. It isn't essential that we do this (the failing tests will
+# be treated as expected failures), but we get a bit more test
+# coverage, and also verify that we can install a package into the
+# bindist with Cabal.
+#
+bindistdir="bindisttest/install dir"
+cd libraries/mtl
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs configure --with-ghc="$thisdir/$bindistdir/bin/ghc" --global --builddir=dist-bindist --prefix="$thisdir/$bindistdir"
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs build --builddir=dist-bindist
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs install --builddir=dist-bindist
+"$thisdir/$bindistdir/bin/runhaskell" Setup.hs clean --builddir=dist-bindist
+cd $thisdir
+
fi # testsuite-only
if [ "$hpc" = YES ]
projects / ghc-hetmet.git / commitdiff