# OK, now make the \`real' Makefiles
-for i in @DoingGHC@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ ; do
+passed_in_setup="-S @MkWorldSetup@"
+
+for i in @DoingGHC@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ EndOfList ; do
+ if [ $i = nofib ] ; then
+ setup=$passed_in_setup
+ else
+ setup=''
+ fi
if [ -d $i ] ; then
( set -e; \
cd $i ; \
echo '' ; \
echo "*** configuring $i ..." ; \
- make -f Makefile.BOOT BOOT_DEFINES="-P $i -S @MkWorldSetup@ -C mkworld -DTopDirPwd=$hardtop"; \
+ make -f Makefile.BOOT BOOT_DEFINES="-P $i $setup -C mkworld -DTopDirPwd=$hardtop"; \
echo '' ; \
echo "*** making Makefiles in $i ..." ; \
make Makefile ; \
make Makefiles \
)
else
- echo warning: $i is not a directory -- doing nothing for it
+ if [ $i != EndOfList ] ; then
+ echo warning: $i is not a directory -- doing nothing for it
+ fi
fi
done
# Finally, the dependencies
-for i in @DoingGHC@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ ; do
+for i in @DoingGHC@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ EndOfList ; do
if [ -d $i ] ; then
( set -e; \
cd $i ; \
make depend \
)
else
- echo warning: $i is not a directory -- doing nothing for it
+ if [ $i != EndOfList ] ; then
+ echo warning: $i is not a directory -- doing nothing for it
+ fi
fi
done
echo '*******************************************************************'
echo "* Looking good! All you should need to do now is... *"
echo '* *'
-for i in @DoingGHC@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ ; do
- echo " cd $i"
- if [ $i = nofib ] ; then
- echo ' make all # or...'
- echo ' make runtests'
- else
- echo ' make all'
- echo ' make install # if you are so inclined...'
+for i in @DoingGHC@ @DoingHappy@ @DoingHaggis@ @DoingNoFib@ EndOfList ; do
+ if [ $i != EndOfList ] ; then
+ echo " cd $i"
+ if [ $i = nofib ] ; then
+ echo ' make all # or...'
+ echo ' make runtests'
+ else
+ echo ' make all'
+ echo ' make install # if you are so inclined...'
+ fi
fi
done
echo '* *'
HostVendor_CPP='sgi'
HostOS_CPP='irix'
;;
-rs6000-ibm-aix*)
- HostPlatform_CPP='rs6000_ibm_aix'
- HostArch_CPP='rs6000'
+powerpc-ibm-aix*)
+ HostPlatform=powerpc-ibm-aix
+ TargetPlatform=powerpc-ibm-aix #hack
+ BuildPlatform=powerpc-ibm-aix #hack
+ HostPlatform_CPP='powerpc_ibm_aix'
+ HostArch_CPP='powerpc'
HostVendor_CPP='ibm'
HostOS_CPP='aix'
;;
"
fi
else
- echo "I'm not sure if your version of perl will work,"
- echo "but it's worth a shot, eh?"
+ if egrep "version 5" conftest.out >/dev/null 2>&1; then
+ :
+ else
+ echo "I'm not sure if your version of perl will work,"
+ echo "but it's worth a shot, eh?"
+ fi
fi
rm -fr conftest*
fi
GhcBuild_m='NO'
GhcBuild_n='NO'
GhcBuild_o='NO'
+GhcBuild_A='NO'
+GhcBuild_B='NO'
+# More could be added here...
AC_ARG_ENABLE(normal-build,
[
dnl ;;
dnl esac])
dnl
+dnl AC_ARG_ENABLE(user-way-A,
+dnl [--enable-user-way-A build for \`user way A' (mostly for implementors)],
+dnl [case "$enableval" in
+dnl yes) GhcBuild_A='YES'
+dnl ;;
+dnl no) GhcBuild_A='NO'
+dnl ;;
+dnl *) echo "I don't understand this option: --enable-user-way-A=$enableval"
+dnl exit 1
+dnl ;;
+dnl esac])
+dnl
+dnl AC_ARG_ENABLE(user-way-B,
+dnl [--enable-user-way-B build for \`user way B' (mostly for implementors)],
+dnl [case "$enableval" in
+dnl yes) GhcBuild_B='YES'
+dnl ;;
+dnl no) GhcBuild_B='NO'
+dnl ;;
+dnl *) echo "I don't understand this option: --enable-user-way-B=$enableval"
+dnl exit 1
+dnl ;;
+dnl esac])
+dnl
AC_SUBST(GhcBuild_normal)
AC_SUBST(GhcBuild_p)
AC_SUBST(GhcBuild_t)
dnl AC_SUBST(GhcBuild_m)
dnl AC_SUBST(GhcBuild_n)
dnl AC_SUBST(GhcBuild_o)
+dnl AC_SUBST(GhcBuild_A)
+dnl AC_SUBST(GhcBuild_B)
#---------------------------------------------------------------
#
if test $GhcWithRegisterised = 'YES'; then
case $HostPlatform in
- alpha-* | hppa1.1-* | i386-* | m68k-* | mips-* | sparc-* )
+ alpha-* | hppa1.1-* | i386-* | m68k-* | mips-* | powerpc-* | sparc-* )
;;
*)
echo "Don't know non-portable C tricks for this platform: $HostPlatform"
esac])
if test $GhcWithNativeCodeGen = 'YES'; then
case $TargetPlatform in
- sparc-sun-sunos4 | sparc-sun-solaris2 | alpha-dec-osf1 )
+ i386-* | alpha-* | sparc-* )
;;
*)
echo "Don't have a native-code generator for this platform: $TargetPlatform"
#
# -------------------------------------------------------------------------
dnl
+dnl * `Literate' CONFIGURATION STUFF
+
+if test "xxx$DoingLiterate" = 'xxxliterate' ; then
+# a very big "if"!
+
+BuildInfoUtils='NO'
+AC_ARG_ENABLE(info-utils,
+ [
+*******************************************************************
+** Literate programming system OPTIONS:
+
+--enable-info-utils build GNU info/makeinfo utilities],
+ [case "$enableval" in
+ yes) BuildInfoUtils='YES'
+ ;;
+ no) BuildInfoUtils='NO'
+ ;;
+ *) echo "I don't understand this option: --enable-info-utils=$enableval"
+ exit 1
+ ;;
+ esac])
+AC_SUBST(BuildInfoUtils)
+
+# here ends a very big if DoingLiterate = 'literate' ...
+fi
+#
+# -------------------------------------------------------------------------
+dnl
dnl * `NoFib' CONFIGURATION STUFF
if test "xxx$DoingNoFib" = 'xxxnofib' ; then
dnl ** what mkworld \`setup' should be used?
AC_ARG_WITH(setup,
[
-What mkworld \`setup' should be used?
-Choices: ghc, hbc, nhc
+--with-setup=<setup> : What mkworld \`setup' should be used?
+ Choices: ghc, hbc, nhc
],
[case "$withval" in
ghc ) MkWorldSetup='ghc'
;;
nhc ) MkWorldSetup='nhc'
;;
- *) echo "I don't understand this option: --with-hc-for-nofib=$withval"
+ *) echo "I don't understand this option: --with-setup=$withval"
exit 1
;;
esac])
--- /dev/null
+I've collected all the Haskell modes for GNU Emacs that I could lay my
+hands on -- there are billions. A list is attached, grouped by
+"family".
+
+I don't like "mode junk" myself, so I don't use any of them. I will
+include advertising or testimonials from happy users if they send them
+along...
+
+Will Partain
+partain@dcs.glasgow.ac.uk
+95/12/05
+
+=======================================================================
+
+* "Chalmers Haskell mode family" -- "Major mode for editing Haskell",
+ by Lars Bo Nielsen and Lennart Augustsson.
+
+ chalmers/original -- the original -- version 0.1.
+
+ chalmers/thiemann -- Peter Thiemann added "indentation stuff"
+ and fontification -- version 0.2.
+
+ chalmers/sof -- Sigbjorn Finne's <sof@dcs.glasgow.ac.uk> hacked
+ version of Thiemann's.
+
+.......................................................................
+
+* "Glasgow Haskell mode family" -- originally written by Richard McPhee
+ et al., at Glasgow University, as a student project, for Kevin
+ Hammond.
+
+ glasgow/original : version 1.0, now maintained by
+ gem@minster.york.ac.uk
+
+.......................................................................
+
+* "Simon Marlow Haskell mode family" -- This is the one that comes
+ with GHC, versions 0.16 up to at least 0.26.
+
+ simonm/real : the real thing
+
+ simonm/ghc : the one distributed with GHC 0.16-0.26; no particular
+ reason to prefer this one...
+
+.......................................................................
+
+* "Yale Haskell mode family" -- Especially good for chatting to a
+ Yale-Haskell inferior process :-)
+
+ yale/original : the real thing
+
+ yale/chak : "extended by Manuel M.T. Chakravarty with rudimentary
+ editing features (including better syntax table) and support
+ for the font-lock-mode." Via Hans Wolfgang Loidl
+ <hwloidl@dcs.glasgow.ac.uk>
--- /dev/null
+;; haskell-mode.el. Major mode for editing Haskell.
+;; Copyright (C) 1989, Free Software Foundation, Inc., Lars Bo Nielsen
+;; and Lennart Augustsson
+
+;; This file is not officially part of GNU Emacs.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY. No author or distributor
+;; accepts responsibility to anyone for the consequences of using it
+;; or for whether it serves any particular purpose or works at all,
+;; unless he says so in writing. Refer to the GNU Emacs General Public
+;; License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute
+;; GNU Emacs, but only under the conditions described in the
+;; GNU Emacs General Public License. A copy of this license is
+;; supposed to have been given to you along with GNU Emacs so you
+;; can know your rights and responsibilities. It should be in a
+;; file named COPYING. Among other things, the copyright notice
+;; and this notice must be preserved on all copies.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Haskell Mode. A major mode for editing and running Haskell. (Version 0.0)
+;; =================================================================
+;;
+;; This is a mode for editing and running Haskell.
+;; It is very much based on the sml mode for GNU Emacs. It
+;; features:
+;;
+;; - Inferior shell running Haskell. No need to leave emacs, just
+;; keep right on editing while Haskell runs in another window.
+;;
+;; - Automatic "load file" in inferior shell. Send regions of code
+;; to the Haskell program.
+;;
+;;
+;; 1. HOW TO USE THE Haskell-MODE
+;; ==========================
+;;
+;; Here is a short introduction to the mode.
+;;
+;; 1.1 GETTING STARTED
+;; -------------------
+;;
+;; If you are an experienced user of Emacs, just skip this section.
+;;
+;; To use the haskell-mode, insert this in your "~/.emacs" file (Or ask your
+;; emacs-administrator to help you.):
+;;
+;; (setq auto-mode-alist (cons '("\\.hs$" . haskell-mode) (cons '("\\.lhs$" . haskell-mode)
+;; auto-mode-alist)))
+;; (autoload 'haskell-mode "haskell-mode" "Major mode for editing Haskell." t)
+;;
+;; Now every time a file with the extension `.hs' or `.lhs' is found, it is
+;; automatically started up in haskell-mode.
+;;
+;; You will also have to specify the path to this file, so you will have
+;; to add this as well:
+;;
+;; (setq load-path (cons "/usr/me/emacs" load-path))
+;;
+;; where "/usr/me/emacs" is the directory where this file is.
+;;
+;; You may also want to compile the this file (M-x byte-compile-file)
+;; for speed.
+;;
+;; You are now ready to start using haskell-mode. If you have tried other
+;; language modes (like lisp-mode or C-mode), you should have no
+;; problems. There are only a few extra functions in this mode.
+;;
+;; 1.2. EDITING COMMANDS.
+;; ----------------------
+;;
+;; The following editing and inferior-shell commands can ONLY be issued
+;; from within a buffer in haskell-mode.
+;;
+;; LFD (reindent-then-newline-and-indent).
+;; This is probably the function you will be using the most (press
+;; CTRL while you press Return, press C-j or press Newline). It
+;; will reindent the line, then make a new line and perform a new
+;; indentation.
+;;
+;; M-; (indent-for-comment).
+;; Like in other language modes, this command will give you a comment
+;; at the of the current line. The column where the comment starts is
+;; determined by the variable comment-column (default: 40).
+;;
+;; C-c C-v (haskell-mode-version).
+;; Get the version of the haskell-mode.
+;;
+;;
+;; 1.3. COMMANDS RELATED TO THE INFERIOR SHELL
+;; -------------------------------------------
+;;
+;; C-c C-s (haskell-pop-to-shell).
+;; This command starts up an inferior shell running haskell. If the shell
+;; is running, it will just pop up the shell window.
+;;
+;; C-c C-u (haskell-save-buffer-use-file).
+;; This command will save the current buffer and send a "load file",
+;; where file is the file visited by the current buffer, to the
+;; inferior shell running haskell.
+;;
+;; C-c C-f (haskell-run-on-file).
+;; Will send a "load file" to the inferior shell running haskell,
+;; prompting you for the file name.
+;;
+;; C-c C-r (haskell-send-region).
+;; Will send region, from point to mark, to the inferior shell
+;; running haskell.
+;;
+;; C-c C-b (haskell-send-buffer).
+;; Will send whole buffer to inferior shell running haskell.
+;;
+;; 2. INDENTATION
+;; ================
+;; Not yet.
+;;
+;; 3. INFERIOR SHELL.
+;; ==================
+;;
+;; The mode for Standard ML also contains a mode for an inferior shell
+;; running haskell. The mode is the same as the shell-mode, with just one
+;; extra command.
+;;
+;; 3.1. INFERIOR SHELL COMMANDS
+;; ----------------------------
+;;
+;; C-c C-f (haskell-run-on-file). Send a `load file' to the process running
+;; haskell.
+;;
+;; 3.2. CONSTANTS CONTROLLING THE INFERIOR SHELL MODE
+;; --------------------------------------------------
+;;
+;; Because haskell is called differently on various machines, and the
+;; haskell-systems have their own command for reading in a file, a set of
+;; constants controls the behavior of the inferior shell running haskell (to
+;; change these constants: See CUSTOMIZING YOUR Haskell-MODE below).
+;;
+;; haskell-prog-name (default "hbi").
+;; This constant is a string, containing the command to invoke
+;; Standard ML on your system.
+;;
+;; haskell-use-right-delim (default "\"")
+;; haskell-use-left-delim (default "\"")
+;; The left and right delimiter used by your version of haskell, for
+;; `use file-name'.
+;;
+;; haskell-process-name (default "Haskell").
+;; The name of the process running haskell. (This will be the name
+;; appearing on the mode line of the buffer)
+;;
+;; NOTE: The haskell-mode functions: haskell-send-buffer, haskell-send-function and
+;; haskell-send-region, creates temporary files (I could not figure out how
+;; to send large amounts of data to a process). These files will be
+;; removed when you leave emacs.
+;;
+;;
+;; 4. CUSTOMIZING YOUR Haskell-MODE
+;; ============================
+;;
+;; If you have to change some of the constants, you will have to add a
+;; `hook' to the haskell-mode. Insert this in your "~/.emacs" file.
+;;
+;; (setq haskell-mode-hook 'my-haskell-constants)
+;;
+;; Your function "my-haskell-constants" will then be executed every time
+;; "haskell-mode" is invoked. Now you only have to write the emacs-lisp
+;; function "my-haskell-constants", and put it in your "~/.emacs" file.
+;;
+;; Say you are running a version of haskell that uses the syntax `load
+;; ["file"]', is invoked by the command "OurHaskell" and you don't want the
+;; indentation algorithm to indent according to open parenthesis, your
+;; function should look like this:
+;;
+;; (defun my-haskell-constants ()
+;; (setq haskell-prog-name "OurHaskell")
+;; (setq haskell-use-left-delim "[\"")
+;; (setq haskell-use-right-delim "\"]")
+;; (setq haskell-paren-lookback nil))
+;;
+;; The haskell-shell also runs a `hook' (haskell-shell-hook) when it is invoked.
+;;
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;
+;; ORIGINAL AUTHOR
+;; Lars Bo Nielsen
+;; Aalborg University
+;; Computer Science Dept.
+;; 9000 Aalborg
+;; Denmark
+;;
+;; lbn@iesd.dk
+;; or: ...!mcvax!diku!iesd!lbn
+;; or: mcvax!diku!iesd!lbn@uunet.uu.net
+;;
+;; MODIFIED FOR Haskell BY
+;; Lennart Augustsson
+;;
+;;
+;; Please let me know if you come up with any ideas, bugs, or fixes.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst haskell-mode-version-string
+ "HASKELL-MODE, Version 0.1")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; CONSTANTS CONTROLLING THE MODE.
+;;;
+;;; These are the constants you might want to change
+;;;
+
+;; The command used to start up the haskell-program.
+(defconst haskell-prog-name "hbi" "*Name of program to run as haskell.")
+
+;; The left delimmitter for `load file'
+(defconst haskell-use-left-delim "\""
+ "*The left delimiter for the filename when using \"load\".")
+
+;; The right delimmitter for `load file'
+(defconst haskell-use-right-delim "\""
+ "*The right delimiter for the filename when using \"load\".")
+
+;; A regular expression matching the prompt pattern in the inferior
+;; shell
+(defconst haskell-shell-prompt-pattern "^> *"
+ "*The prompt pattern for the inferion shell running haskell.")
+
+;; The template used for temporary files, created when a region is
+;; send to the inferior process running haskell.
+(defconst haskell-tmp-template "/tmp/haskell.tmp."
+ "*Template for the temporary file, created by haskell-simulate-send-region.")
+
+;; The name of the process running haskell (This will also be the name of
+;; the buffer).
+(defconst haskell-process-name "Haskell" "*The name of the Haskell-process")
+
+;;;
+;;; END OF CONSTANTS CONTROLLING THE MODE.
+;;;
+;;; If you change anything below, you are on your own.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defvar haskell-mode-syntax-table nil "The syntax table used in haskell-mode.")
+
+(defvar haskell-mode-map nil "The mode map used in haskell-mode.")
+
+(defun haskell-mode ()
+ "Major mode for editing Haskell code.
+Tab indents for Haskell code.
+Comments are delimited with --
+Paragraphs are separated by blank lines only.
+Delete converts tabs to spaces as it moves back.
+
+Key bindings:
+=============
+
+\\[haskell-pop-to-shell]\t Pop to the haskell window.
+\\[haskell-save-buffer-use-file]\t Save the buffer, and send a \"load file\".
+\\[haskell-send-region]\t Send region (point and mark) to haskell.
+\\[haskell-run-on-file]\t Send a \"load file\" to haskell.
+\\[haskell-send-buffer]\t Send whole buffer to haskell.
+\\[haskell-mode-version]\t Get the version of haskell-mode.
+\\[haskell-evaluate-expression]\t Prompt for an expression and evalute it.
+
+
+Mode map
+========
+\\{haskell-mode-map}
+Runs haskell-mode-hook if non nil."
+ (interactive)
+ (kill-all-local-variables)
+ (if haskell-mode-map
+ ()
+ (setq haskell-mode-map (make-sparse-keymap))
+ (define-key haskell-mode-map "\C-c\C-v" 'haskell-mode-version)
+ (define-key haskell-mode-map "\C-c\C-u" 'haskell-save-buffer-use-file)
+ (define-key haskell-mode-map "\C-c\C-s" 'haskell-pop-to-shell)
+ (define-key haskell-mode-map "\C-c\C-r" 'haskell-send-region)
+ (define-key haskell-mode-map "\C-c\C-m" 'haskell-region)
+ (define-key haskell-mode-map "\C-c\C-f" 'haskell-run-on-file)
+ (define-key haskell-mode-map "\C-c\C-b" 'haskell-send-buffer)
+ (define-key haskell-mode-map "\C-ce" 'haskell-evaluate-expression)
+ (define-key haskell-mode-map "\C-j" 'reindent-then-newline-and-indent)
+ (define-key haskell-mode-map "\177" 'backward-delete-char-untabify))
+ (use-local-map haskell-mode-map)
+ (setq major-mode 'haskell-mode)
+ (setq mode-name "Haskell")
+ (define-abbrev-table 'haskell-mode-abbrev-table ())
+ (setq local-abbrev-table haskell-mode-abbrev-table)
+ (if haskell-mode-syntax-table
+ ()
+ (setq haskell-mode-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?\( "()1" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\) ")(4" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\\ "." haskell-mode-syntax-table)
+ (modify-syntax-entry ?* ". 23" haskell-mode-syntax-table)
+ ;; Special characters in haskell-mode to be treated as normal
+ ;; characters:
+ (modify-syntax-entry ?_ "w" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\' "w" haskell-mode-syntax-table)
+ )
+ (set-syntax-table haskell-mode-syntax-table)
+ (make-local-variable 'require-final-newline) ; Always put a new-line
+ (setq require-final-newline t) ; in the end of file
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'haskell-indent-line)
+ (make-local-variable 'comment-start)
+ (setq comment-start "-- ")
+ (make-local-variable 'comment-end)
+ (setq comment-end "")
+ (make-local-variable 'comment-column)
+ (setq comment-column 39) ; Start of comment in this column
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "(\\*+[ \t]?") ; This matches a start of comment
+ (make-local-variable 'comment-indent-hook)
+ (setq comment-indent-hook 'haskell-comment-indent)
+ ;;
+ ;; Adding these will fool the matching of parens. I really don't
+ ;; know why. It would be nice to have comments treated as
+ ;; white-space
+ ;;
+ ;; (make-local-variable 'parse-sexp-ignore-comments)
+ ;; (setq parse-sexp-ignore-comments t)
+ ;;
+ (run-hooks 'haskell-mode-hook)) ; Run the hook
+
+(defun haskell-mode-version ()
+ (interactive)
+ (message haskell-mode-version-string))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; INDENTATION
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun haskell-indent-line ()
+ "Indent current line of Haskell code."
+ (interactive)
+ (let ((indent (haskell-calculate-indentation)))
+ (if (/= (current-indentation) indent)
+ (let ((beg (progn (beginning-of-line) (point))))
+ (skip-chars-forward "\t ")
+ (delete-region beg (point))
+ (indent-to indent))
+ ;; If point is before indentation, move point to indentation
+ (if (< (current-column) (current-indentation))
+ (skip-chars-forward "\t ")))))
+
+(defun haskell-calculate-indentation ()
+ (save-excursion
+ (previous-line 1)
+ (beginning-of-line) ; Go to first non whitespace
+ (skip-chars-forward "\t ") ; on the line.
+ (current-column)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; INFERIOR SHELL
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar haskell-shell-map nil "The mode map for haskell-shell.")
+
+(defun haskell-shell ()
+ "Inferior shell invoking Haskell.
+It is not possible to have more than one shell running Haskell.
+Like the shell mode with the additional command:
+
+\\[haskell-run-on-file]\t Runs haskell on the file.
+\\{haskell-shell-map}
+Variables controlling the mode:
+
+haskell-prog-name (default \"hbi\")
+ The string used to invoke the haskell program.
+
+haskell-use-right-delim (default \"\\\"\")
+haskell-use-left-delim (default \"\\\"\")
+ The left and right delimiter used by your version of haskell, for
+ \"load file-name\".
+
+haskell-process-name (default \"Haskell\")
+ The name of the process running haskell.
+
+haskell-shell-prompt-pattern (default \"^> *\")
+ The prompt pattern.
+
+Runs haskell-shell-hook if not nil."
+ (interactive)
+ (if (not (process-status haskell-process-name))
+ (save-excursion ; Process is not running
+ (message "Starting Haskell...") ; start up a new process
+ (require 'shell)
+ (set-buffer (make-shell haskell-process-name haskell-prog-name))
+ (erase-buffer) ; Erase the buffer if a previous
+ (if haskell-shell-map ; process died in there
+ ()
+ (setq haskell-shell-map (copy-sequence shell-mode-map))
+ (define-key haskell-shell-map "\C-c\C-f" 'haskell-run-on-file))
+ (use-local-map haskell-shell-map)
+ (make-local-variable 'shell-prompt-pattern)
+ (setq shell-prompt-pattern haskell-shell-prompt-pattern)
+ (setq major-mode 'haskell-shell)
+ (setq mode-name "Haskell Shell")
+ (setq mode-line-format
+ "-----Emacs: %17b %M %[(%m: %s)%]----%3p--%-")
+ (set-process-filter (get-process haskell-process-name) 'haskell-process-filter)
+ (message "Starting Haskell...done.")
+ (run-hooks 'haskell-shell-hook))))
+
+(defun haskell-process-filter (proc str)
+ (let ((cur (current-buffer))
+ (pop-up-windows t))
+ (pop-to-buffer (concat "*" haskell-process-name "*"))
+ (goto-char (point-max))
+ (if (string= str "\b\b\b \b\b\b")
+ (backward-delete-char 4)
+ (insert str))
+ (set-marker (process-mark proc) (point-max))
+ (pop-to-buffer cur)))
+
+(defun haskell-pop-to-shell ()
+ (interactive)
+ (haskell-shell)
+ (pop-to-buffer (concat "*" haskell-process-name "*")))
+
+(defun haskell-run-on-file (fil)
+ (interactive "FRun Haskell on : ")
+ (haskell-shell)
+ (save-some-buffers)
+ (send-string haskell-process-name
+ (concat "load " haskell-use-left-delim (expand-file-name fil)
+ haskell-use-right-delim ";\n")))
+
+(defun haskell-save-buffer-use-file ()
+ "Save the buffer, and send a `use file' to the inferior shell
+running Haskell."
+ (interactive)
+ (let (file)
+ (if (setq file (buffer-file-name)) ; Is the buffer associated
+ (progn ; with file ?
+ (save-buffer)
+ (haskell-shell)
+ (send-string haskell-process-name
+ (concat "load " haskell-use-left-delim
+ (expand-file-name file)
+ haskell-use-right-delim ";\n")))
+ (error "Buffer not associated with file."))))
+
+(defvar haskell-tmp-files-list nil
+ "List of all temporary files created by haskell-simulate-send-region.
+Each element in the list is a list with the format:
+
+ (\"tmp-filename\" buffer start-line)")
+
+(defvar haskell-simulate-send-region-called-p nil
+ "Has haskell-simulate-send-region been called previously.")
+
+(defun haskell-make-temp-name (pre)
+ (concat (make-temp-name pre) ".m"))
+
+(defun haskell-simulate-send-region (point1 point2)
+ "Simulate send region. As send-region only can handle what ever the
+system sets as the default, we have to make a temporary file.
+Updates the list of temporary files (haskell-tmp-files-list)."
+ (let ((file (expand-file-name (haskell-make-temp-name haskell-tmp-template))))
+ ;; Remove temporary files when we leave emacs
+ (if (not haskell-simulate-send-region-called-p)
+ (progn
+ (setq haskell-old-kill-emacs-hook kill-emacs-hook)
+ (setq kill-emacs-hook 'haskell-remove-tmp-files)
+ (setq haskell-simulate-send-region-called-p t)))
+ (save-excursion
+ (goto-char point1)
+ (setq haskell-tmp-files-list
+ (cons (list file
+ (current-buffer)
+ (save-excursion ; Calculate line no.
+ (beginning-of-line)
+ (1+ (count-lines 1 (point)))))
+ haskell-tmp-files-list)))
+ (write-region point1 point2 file nil 'dummy)
+ (haskell-shell)
+ (message "Using temporary file: %s" file)
+ (send-string
+ haskell-process-name
+ ;; string to send: load file;
+ (concat "load " haskell-use-left-delim file haskell-use-right-delim ";\n"))))
+
+(defvar haskell-old-kill-emacs-hook nil
+ "Old value of kill-emacs-hook")
+
+(defun haskell-remove-tmp-files ()
+ "Remove the temporary files, created by haskell-simulate-send-region, if
+they still exist. Only files recorded in haskell-tmp-files-list are removed."
+ (message "Removing temporary files created by haskell-mode...")
+ (while haskell-tmp-files-list
+ (condition-case ()
+ (delete-file (car (car haskell-tmp-files-list)))
+ (error ()))
+ (setq haskell-tmp-files-list (cdr haskell-tmp-files-list)))
+ (message "Removing temporary files created by haskell-mode...done.")
+ (run-hooks 'haskell-old-kill-emacs-hook))
+
+(defun haskell-send-region ()
+ "Send region."
+ (interactive)
+ (let (start end)
+ (save-excursion
+ (setq end (point))
+ (exchange-point-and-mark)
+ (setq start (point)))
+ (haskell-simulate-send-region start end)))
+
+(defun haskell-send-buffer ()
+ "Send the buffer."
+ (interactive)
+ (haskell-simulate-send-region (point-min) (point-max)))
+
+(defun haskell-evaluate-expression (h-expr)
+ "Prompt for and evaluate an expression"
+ (interactive "sExpression: ")
+ (let ((str (concat h-expr ";\n"))
+ (buf (current-buffer)))
+ (haskell-pop-to-shell)
+ (insert str)
+ (send-string haskell-process-name str)
+ (pop-to-buffer buf)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; END OF Haskell-MODE
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- /dev/null
+;; haskell-mode.el. Major mode for editing Haskell.
+;; Copyright (C) 1989, Free Software Foundation, Inc., Lars Bo Nielsen
+;; and Lennart Augustsson
+;; modified by Peter Thiemann, March 1994
+
+;; This file is not officially part of GNU Emacs.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY. No author or distributor
+;; accepts responsibility to anyone for the consequences of using it
+;; or for whether it serves any particular purpose or works at all,
+;; unless he says so in writing. Refer to the GNU Emacs General Public
+;; License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute
+;; GNU Emacs, but only under the conditions described in the
+;; GNU Emacs General Public License. A copy of this license is
+;; supposed to have been given to you along with GNU Emacs so you
+;; can know your rights and responsibilities. It should be in a
+;; file named COPYING. Among other things, the copyright notice
+;; and this notice must be preserved on all copies.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Haskell Mode. A major mode for editing and running Haskell. (Version 0.0)
+;; =================================================================
+;;
+;; This is a mode for editing and running Haskell.
+;; It is very much based on the sml mode for GNU Emacs. It
+;; features:
+;;
+;; - Inferior shell running Haskell. No need to leave emacs, just
+;; keep right on editing while Haskell runs in another window.
+;;
+;; - Automatic "load file" in inferior shell. Send regions of code
+;; to the Haskell program.
+;;
+;;
+;; 1. HOW TO USE THE Haskell-MODE
+;; ==========================
+;;
+;; Here is a short introduction to the mode.
+;;
+;; 1.1 GETTING STARTED
+;; -------------------
+;;
+;; If you are an experienced user of Emacs, just skip this section.
+;;
+;; To use the haskell-mode, insert this in your "~/.emacs" file (Or ask your
+;; emacs-administrator to help you.):
+;;
+;; (setq auto-mode-alist (cons '("\\.hs$" . haskell-mode) (cons '("\\.lhs$" . haskell-mode)
+;; auto-mode-alist)))
+;; (autoload 'haskell-mode "haskell-mode" "Major mode for editing Haskell." t)
+;;
+;; Now every time a file with the extension `.hs' or `.lhs' is found, it is
+;; automatically started up in haskell-mode.
+;;
+;; You will also have to specify the path to this file, so you will have
+;; to add this as well:
+;;
+;; (setq load-path (cons "/usr/me/emacs" load-path))
+;;
+;; where "/usr/me/emacs" is the directory where this file is.
+;;
+;; You may also want to compile the this file (M-x byte-compile-file)
+;; for speed.
+;;
+;; You are now ready to start using haskell-mode. If you have tried other
+;; language modes (like lisp-mode or C-mode), you should have no
+;; problems. There are only a few extra functions in this mode.
+;;
+;; 1.2. EDITING COMMANDS.
+;; ----------------------
+;;
+;; The following editing and inferior-shell commands can ONLY be issued
+;; from within a buffer in haskell-mode.
+;;
+;; LFD (haskell-newline-and-indent).
+;; This is probably the function you will be using the most (press
+;; CTRL while you press Return, press C-j or press Newline). It
+;; makes a new line and performs indentation based on the last
+;; preceding non-comment line.
+;;
+;; M-; (indent-for-comment).
+;; Like in other language modes, this command will give you a comment
+;; at the of the current line. The column where the comment starts is
+;; determined by the variable comment-column (default: 40).
+;;
+;; C-c C-v (haskell-mode-version).
+;; Get the version of the haskell-mode.
+;;
+;;
+;; 1.3. COMMANDS RELATED TO THE INFERIOR SHELL
+;; -------------------------------------------
+;;
+;; C-c C-s (haskell-pop-to-shell).
+;; This command starts up an inferior shell running haskell. If the shell
+;; is running, it will just pop up the shell window.
+;;
+;; C-c C-u (haskell-save-buffer-use-file).
+;; This command will save the current buffer and send a "load file",
+;; where file is the file visited by the current buffer, to the
+;; inferior shell running haskell.
+;;
+;; C-c C-f (haskell-run-on-file).
+;; Will send a "load file" to the inferior shell running haskell,
+;; prompting you for the file name.
+;;
+;; C-c C-r (haskell-send-region).
+;; Will send region, from point to mark, to the inferior shell
+;; running haskell.
+;;
+;; C-c C-b (haskell-send-buffer).
+;; Will send whole buffer to inferior shell running haskell.
+;;
+;; 2. INDENTATION
+;; ================
+;;
+;; The first indentation command (using C-j or TAB) on a given line
+;; indents like the last preceding non-comment line. The next TAB
+;; indents to the indentation of the innermost enclosing scope. Further
+;; TABs get you to further enclosing scopes. After indentation has
+;; reached the first column, the process restarts using the indentation
+;; of the preceding non-comment line, again.
+;;
+;; 3. INFERIOR SHELL.
+;; ==================
+;;
+;; The mode for Standard ML also contains a mode for an inferior shell
+;; running haskell. The mode is the same as the shell-mode, with just one
+;; extra command.
+;;
+;; 3.1. INFERIOR SHELL COMMANDS
+;; ----------------------------
+;;
+;; C-c C-f (haskell-run-on-file). Send a `load file' to the process running
+;; haskell.
+;;
+;; 3.2. CONSTANTS CONTROLLING THE INFERIOR SHELL MODE
+;; --------------------------------------------------
+;;
+;; Because haskell is called differently on various machines, and the
+;; haskell-systems have their own command for reading in a file, a set of
+;; constants controls the behavior of the inferior shell running haskell (to
+;; change these constants: See CUSTOMIZING YOUR Haskell-MODE below).
+;;
+;; haskell-prog-name (default "hbi").
+;; This constant is a string, containing the command to invoke
+;; Standard ML on your system.
+;;
+;; haskell-use-right-delim (default "\"")
+;; haskell-use-left-delim (default "\"")
+;; The left and right delimiter used by your version of haskell, for
+;; `use file-name'.
+;;
+;; haskell-process-name (default "Haskell").
+;; The name of the process running haskell. (This will be the name
+;; appearing on the mode line of the buffer)
+;;
+;; NOTE: The haskell-mode functions: haskell-send-buffer, haskell-send-function and
+;; haskell-send-region, creates temporary files (I could not figure out how
+;; to send large amounts of data to a process). These files will be
+;; removed when you leave emacs.
+;;
+;; 4. FONTIFICATION
+;;
+;; There is support for Jamie Zawinski's font-lock-mode through the
+;; variable "haskell-font-lock-keywords".
+;;
+;; 5. CUSTOMIZING YOUR Haskell-MODE
+;; ============================
+;;
+;; If you have to change some of the constants, you will have to add a
+;; `hook' to the haskell-mode. Insert this in your "~/.emacs" file.
+;;
+;; (setq haskell-mode-hook 'my-haskell-constants)
+;;
+;; Your function "my-haskell-constants" will then be executed every time
+;; "haskell-mode" is invoked. Now you only have to write the emacs-lisp
+;; function "my-haskell-constants", and put it in your "~/.emacs" file.
+;;
+;; Say you are running a version of haskell that uses the syntax `load
+;; ["file"]', is invoked by the command "OurHaskell" and you don't want the
+;; indentation algorithm to indent according to open parenthesis, your
+;; function should look like this:
+;;
+;; (defun my-haskell-constants ()
+;; (setq haskell-prog-name "OurHaskell")
+;; (setq haskell-use-left-delim "[\"")
+;; (setq haskell-use-right-delim "\"]")
+;; (setq haskell-paren-lookback nil))
+;;
+;; The haskell-shell also runs a `hook' (haskell-shell-hook) when it is invoked.
+;;
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;
+;; ORIGINAL AUTHOR
+;; Lars Bo Nielsen
+;; Aalborg University
+;; Computer Science Dept.
+;; 9000 Aalborg
+;; Denmark
+;;
+;; lbn@iesd.dk
+;; or: ...!mcvax!diku!iesd!lbn
+;; or: mcvax!diku!iesd!lbn@uunet.uu.net
+;;
+;; MODIFIED FOR Haskell BY
+;; Lennart Augustsson
+;; indentation stuff by Peter Thiemann
+;;
+;;
+;; Please let me know if you come up with any ideas, bugs, or fixes.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst haskell-mode-version-string
+ "HASKELL-MODE, Version 0.2, PJT indentation")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; CONSTANTS CONTROLLING THE MODE.
+;;;
+;;; These are the constants you might want to change
+;;;
+
+;; The command used to start up the haskell-program.
+(defconst haskell-prog-name "hbi" "*Name of program to run as haskell.")
+
+;; The left delimmitter for `load file'
+(defconst haskell-use-left-delim "\""
+ "*The left delimiter for the filename when using \"load\".")
+
+;; The right delimmitter for `load file'
+(defconst haskell-use-right-delim "\""
+ "*The right delimiter for the filename when using \"load\".")
+
+;; A regular expression matching the prompt pattern in the inferior
+;; shell
+(defconst haskell-shell-prompt-pattern "^> *"
+ "*The prompt pattern for the inferion shell running haskell.")
+
+;; The template used for temporary files, created when a region is
+;; send to the inferior process running haskell.
+(defconst haskell-tmp-template "/tmp/haskell.tmp."
+ "*Template for the temporary file, created by haskell-simulate-send-region.")
+
+;; The name of the process running haskell (This will also be the name of
+;; the buffer).
+(defconst haskell-process-name "Haskell" "*The name of the Haskell-process")
+
+;;;
+;;; END OF CONSTANTS CONTROLLING THE MODE.
+;;;
+;;; If you change anything below, you are on your own.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defvar haskell-mode-syntax-table nil "The syntax table used in haskell-mode.")
+
+(defvar haskell-mode-map nil "The mode map used in haskell-mode.")
+
+(defvar haskell-mode-abbrev-table nil "The abbrev-table used in haskell-mode.")
+
+(defvar haskell-old-kill-emacs-hook nil "Old value of kill-emacs-hook")
+
+(defun haskell-mode ()
+ "Major mode for editing Haskell code.
+Tab indents for Haskell code.
+Comments are delimited with --
+Paragraphs are separated by blank lines only.
+Delete converts tabs to spaces as it moves back.
+
+Key bindings:
+=============
+
+\\[haskell-pop-to-shell]\t Pop to the haskell window.
+\\[haskell-save-buffer-use-file]\t Save the buffer, and send a \"load file\".
+\\[haskell-send-region]\t Send region (point and mark) to haskell.
+\\[haskell-run-on-file]\t Send a \"load file\" to haskell.
+\\[haskell-send-buffer]\t Send whole buffer to haskell.
+\\[haskell-mode-version]\t Get the version of haskell-mode.
+\\[haskell-evaluate-expression]\t Prompt for an expression and evalute it.
+
+
+Mode map
+========
+\\{haskell-mode-map}
+Runs haskell-mode-hook if non nil."
+ (interactive)
+ (kill-all-local-variables)
+ (if haskell-mode-map
+ ()
+ (setq haskell-mode-map (make-sparse-keymap))
+ (define-key haskell-mode-map "\C-c\C-v" 'haskell-mode-version)
+ (define-key haskell-mode-map "\C-c\C-u" 'haskell-save-buffer-use-file)
+ (define-key haskell-mode-map "\C-c\C-s" 'haskell-pop-to-shell)
+ (define-key haskell-mode-map "\C-c\C-r" 'haskell-send-region)
+ (define-key haskell-mode-map "\C-c\C-m" 'haskell-region)
+ (define-key haskell-mode-map "\C-c\C-f" 'haskell-run-on-file)
+ (define-key haskell-mode-map "\C-c\C-b" 'haskell-send-buffer)
+ (define-key haskell-mode-map "\C-c\C-l" 'comment-line)
+ (define-key haskell-mode-map "\C-ce" 'haskell-evaluate-expression)
+; (define-key haskell-mode-map "\C-j" 'haskell-newline-and-indent)
+ (define-key haskell-mode-map [S-tab] 'tab-to-tab-stop)
+ (define-key haskell-mode-map "\177" 'backward-delete-char-untabify))
+ (use-local-map haskell-mode-map)
+ (setq major-mode 'haskell-mode)
+ (setq mode-name "Haskell")
+ (define-abbrev-table 'haskell-mode-abbrev-table ())
+ (setq local-abbrev-table haskell-mode-abbrev-table)
+ (if haskell-mode-syntax-table
+ ()
+ (setq haskell-mode-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table)
+ (modify-syntax-entry ?} "){4" haskell-mode-syntax-table)
+; partain: out
+; (modify-syntax-entry ?- "_ 2356" haskell-mode-syntax-table)
+; (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table)
+; (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table)
+; partain: end out
+; partain: in
+ (modify-syntax-entry ?- "_ 23" haskell-mode-syntax-table)
+; (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table)
+; (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table)
+; partain: end in
+ (modify-syntax-entry ?\\ "\\" haskell-mode-syntax-table)
+ (modify-syntax-entry ?* "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?_ "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?' "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?: "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?| "." haskell-mode-syntax-table)
+ )
+ (set-syntax-table haskell-mode-syntax-table)
+ (make-local-variable 'require-final-newline) ; Always put a new-line
+ (setq require-final-newline t) ; in the end of file
+; (make-local-variable 'change-major-mode-hook)
+; (setq change-major-mode-hook nil)
+; (make-local-variable 'indent-line-function)
+; (setq indent-line-function 'haskell-indent-line)
+ (make-local-variable 'comment-start)
+ (setq comment-start "-- ")
+; (setq comment-start "{- ")
+ (make-local-variable 'comment-end)
+ (setq comment-end "")
+; (setq comment-end " -}")
+ (make-local-variable 'comment-column)
+ (setq comment-column 60) ; Start of comment in this column
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "{-+ *\\|--+ *") ; This matches a start of comment
+ (make-local-variable 'comment-multi-line)
+ (setq comment-multi-line nil)
+; (make-local-variable 'comment-indent-function)
+; (setq comment-indent-function 'haskell-comment-indent)
+ ;;
+ ;; Adding these will fool the matching of parens. I really don't
+ ;; know why. It would be nice to have comments treated as
+ ;; white-space
+ ;;
+ ;; (make-local-variable 'parse-sexp-ignore-comments)
+ ;; (setq parse-sexp-ignore-comments t)
+ ;;
+ (run-hooks 'haskell-mode-hook)) ; Run the hook
+
+(defun haskell-mode-version ()
+ (interactive)
+ (message haskell-mode-version-string))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; INDENTATION
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; some variables for later use
+
+(defvar haskell-open-comment "{-")
+(defvar haskell-close-comment "-}")
+(defvar haskell-indentation-counter 0
+ "count repeated invocations of indent-for-tab-command")
+(defvar haskell-literate-flag nil
+ "used to guide literate/illiterate behavior, set automagically")
+
+(defun haskell-newline-and-indent ()
+ (interactive)
+ (setq haskell-literate-flag
+ (save-excursion
+ (beginning-of-line)
+ (= (following-char) ?>)))
+ (newline)
+ (if haskell-literate-flag (insert ">"))
+ (haskell-indent-line))
+
+(defun haskell-indent-line ()
+ "Indent current line of ordinary or literate Haskell code."
+ (interactive)
+ (let ((indent (haskell-calculate-indentation-pjt-2)))
+ (if (/= (current-indentation) indent)
+ (let ((beg (progn
+ (beginning-of-line)
+ (if (= (following-char) ?>) (forward-char 1)) ;LITERATE
+ (point))))
+ (skip-chars-forward "\t ")
+ (delete-region beg (point))
+ (indent-to indent))
+ ;; If point is before indentation, move point to indentation
+ (if (< (current-column) (current-indentation))
+ (skip-chars-forward "\t ")))))
+
+(defun haskell-calculate-indentation ()
+ (save-excursion
+ (let ((col (current-column)))
+ (while (and (not (bobp)) ;skip over empty and comment-only lines
+ (= col (current-column)))
+ (previous-line 1)
+ (beginning-of-line) ; Go to first non whitespace
+ (if (= (following-char) ?>) ;LITERATE
+ (forward-char 1)
+ (if haskell-literate-flag ;ignore illiterate lines
+ (end-of-line)))
+ (skip-chars-forward "\t ") ; on the line.
+ (setq col (current-column))
+ (search-forward-regexp (concat haskell-open-comment "\\|--\\|\n") nil 0)
+ (goto-char (match-beginning 0)))
+ (search-backward-regexp "\\b\\(where\\|let\\|of\\|in\\)\\b\\|\n" nil 0)
+ (if (looking-at "\n")
+ ()
+ (setq col (current-column))
+ (forward-word 1)
+ (skip-chars-forward "\t ")
+ (if (looking-at "\\w")
+ (setq col (current-column))
+ (setq col (+ 2 col))))
+ col)))
+
+(defun haskell-calculate-indentation-pjt-2 ()
+ "Calculate indentation for Haskell program code, versatile version"
+ (save-excursion
+ (if (eq last-command 'haskell-indentation)
+ (setq haskell-indentation-counter (1+ haskell-indentation-counter))
+ (setq haskell-indentation-counter -1))
+ (setq this-command 'haskell-indentation)
+ (let* ((simple-indent (haskell-calculate-indentation))
+ (count haskell-indentation-counter)
+ (min-indent simple-indent) ; minimum indentation found in a non-comment line
+ (last-indent simple-indent) ; indentation of the following non-comment line
+ (return-indent nil) ; computed indentation
+ (comment-depth 0))
+ (previous-line 1)
+ (if (< haskell-indentation-counter 0) ; 1st tab gives simple indentation
+ (setq return-indent simple-indent))
+ (while (not return-indent)
+ (if (search-backward-regexp "\\b\\(where\\|let\\|of\\)\\b\\|\n\\|{-\\|-}" nil t 1)
+ (cond
+ ((looking-at haskell-open-comment)
+ (setq comment-depth (1- comment-depth)))
+ ((looking-at haskell-close-comment)
+ (setq comment-depth (1+ comment-depth)))
+ ((= 0 comment-depth)
+ (cond
+ ((looking-at "\n")
+ (save-excursion
+ (forward-char 1)
+ (if (= (following-char) ?>)
+ (forward-char 1)
+ (if haskell-literate-flag
+ (end-of-line))) ;LITERATE: ignore lines w/o >
+ (skip-chars-forward "\t ")
+ (if (looking-at (concat haskell-open-comment "\\|--\\|\n"))
+ ()
+ (setq last-indent (current-column))
+ (if (< last-indent min-indent)
+ (setq min-indent last-indent)))))
+ (t ; looking at a keyword
+ (save-excursion
+ (forward-word 1)
+ (skip-chars-forward " \t")
+ (if (and haskell-literate-flag ;LITERATE: ignore lines w/o >
+ (save-excursion
+ (beginning-of-line)
+ (/= (following-char) ?>)))
+ (end-of-line))
+ (if (looking-at (concat haskell-open-comment "\\|--\\|\n"))
+ ()
+ (setq last-indent (current-column)))
+ (if (<= last-indent min-indent)
+ (if (> count 0)
+ (setq count (1- count))
+ (setq return-indent last-indent)))
+ (if (< last-indent min-indent)
+ (setq min-indent last-indent)))))))
+ (setq return-indent simple-indent)
+ (setq haskell-indentation-counter -1)))
+ return-indent)))
+
+(defun haskell-skip-nested-comment ()
+ ;; point looks at opening {-, move over closing -}
+ ;; todo: specify what happens on failure, bounds check ...
+ (forward-char 2)
+ (let ((comment-depth 1))
+ (while (> comment-depth 0)
+ (search-forward-regexp "{-\\|-}")
+ (goto-char (match-beginning 0))
+ (setq comment-depth
+ (if (= (following-char) 123) ; code for opening brace
+ (1+ comment-depth)
+ (1- comment-depth)))
+ (goto-char (match-end 0)))))
+
+
+;;;seemingly obsolete functions
+(defun haskell-inside-of-inline-comment ()
+ (let ((bolp (save-excursion
+ (beginning-of-line)
+ (point))))
+ (search-backward comment-start bolp t 1)))
+
+(defun haskell-inside-of-nested-comment ()
+ (save-excursion
+ (let ((count 0))
+ (while
+ (search-backward-regexp "\\({-\\|-}\\)" 0 t 1)
+ (if (haskell-inside-of-inline-comment)
+ ()
+ (if (looking-at haskell-open-comment)
+ (setq count (1+ count))
+ (setq count (1- count)))))
+ (> count 0))))
+
+(defun haskell-inside-of-comment ()
+ (or (haskell-inside-of-inline-comment)
+ (haskell-inside-of-nested-comment)))
+
+;;;stolen from sml-mode.el
+(defun haskell-comment-indent ()
+ "Compute indentation for Haskell comments"
+ (if (looking-at "^--")
+ 0
+ (save-excursion
+ (skip-chars-backward " \t")
+ (max (1+ (current-column))
+ comment-column))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; INFERIOR SHELL
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar haskell-shell-map nil "The mode map for haskell-shell.")
+
+(defun haskell-shell ()
+ "Inferior shell invoking Haskell.
+It is not possible to have more than one shell running Haskell.
+Like the shell mode with the additional command:
+
+\\[haskell-run-on-file]\t Runs haskell on the file.
+\\{haskell-shell-map}
+Variables controlling the mode:
+
+haskell-prog-name (default \"hbi\")
+ The string used to invoke the haskell program.
+
+haskell-use-right-delim (default \"\\\"\")
+haskell-use-left-delim (default \"\\\"\")
+ The left and right delimiter used by your version of haskell, for
+ \"load file-name\".
+
+haskell-process-name (default \"Haskell\")
+ The name of the process running haskell.
+
+haskell-shell-prompt-pattern (default \"^> *\")
+ The prompt pattern.
+
+Runs haskell-shell-hook if not nil."
+ (interactive)
+ (if (not (process-status haskell-process-name))
+ (save-excursion ; Process is not running
+ (message "Starting Haskell...") ; start up a new process
+ (require 'shell)
+ (set-buffer (make-comint haskell-process-name haskell-prog-name))
+ (erase-buffer) ; Erase the buffer if a previous
+ (if haskell-shell-map ; process died in there
+ ()
+ (setq haskell-shell-map (copy-keymap shell-mode-map))
+ (define-key haskell-shell-map "\C-c\C-f" 'haskell-run-on-file))
+ (use-local-map haskell-shell-map)
+ (make-local-variable 'shell-prompt-pattern)
+ (setq shell-prompt-pattern haskell-shell-prompt-pattern)
+ (setq major-mode 'haskell-shell)
+ (setq mode-name "Haskell Shell")
+ (setq mode-line-format
+ "-----Emacs: %17b %M %[(%m: %s)%]----%3p--%-")
+ (set-process-filter (get-process haskell-process-name) 'haskell-process-filter)
+ (message "Starting Haskell...done.")
+ (run-hooks 'haskell-shell-hook))))
+
+(defun haskell-process-filter (proc str)
+ (let ((cur (current-buffer))
+ (pop-up-windows t))
+ (pop-to-buffer (concat "*" haskell-process-name "*"))
+ (goto-char (point-max))
+ (if (string= str "\b\b\b \b\b\b")
+ (backward-delete-char 4)
+ (insert str))
+ (set-marker (process-mark proc) (point-max))
+ (pop-to-buffer cur)))
+
+(defun haskell-pop-to-shell ()
+ (interactive)
+ (haskell-shell)
+ (pop-to-buffer (concat "*" haskell-process-name "*")))
+
+(defun haskell-run-on-file (fil)
+ (interactive "FRun Haskell on : ")
+ (haskell-shell)
+ (save-some-buffers)
+ (process-send-string haskell-process-name
+ (concat "load " haskell-use-left-delim (expand-file-name fil)
+ haskell-use-right-delim ";\n")))
+
+(defun haskell-save-buffer-use-file ()
+ "Save the buffer, and send a `use file' to the inferior shell
+running Haskell."
+ (interactive)
+ (let (file)
+ (if (setq file (buffer-file-name)) ; Is the buffer associated
+ (progn ; with file ?
+ (save-buffer)
+ (haskell-shell)
+ (process-send-string haskell-process-name
+ (concat "load " haskell-use-left-delim
+ (expand-file-name file)
+ haskell-use-right-delim ";\n")))
+ (error "Buffer not associated with file."))))
+
+(defvar haskell-tmp-files-list nil
+ "List of all temporary files created by haskell-simulate-send-region.
+Each element in the list is a list with the format:
+
+ (\"tmp-filename\" buffer start-line)")
+
+(defvar haskell-simulate-send-region-called-p nil
+ "Has haskell-simulate-send-region been called previously.")
+
+(defun haskell-make-temp-name (pre)
+ (concat (make-temp-name pre) ".m"))
+
+(defun haskell-simulate-send-region (point1 point2)
+ "Simulate send region. As send-region only can handle what ever the
+system sets as the default, we have to make a temporary file.
+Updates the list of temporary files (haskell-tmp-files-list)."
+ (let ((file (expand-file-name (haskell-make-temp-name haskell-tmp-template))))
+ ;; Remove temporary files when we leave emacs
+ (if (not haskell-simulate-send-region-called-p)
+ (progn
+ (setq haskell-old-kill-emacs-hook kill-emacs-hook)
+ (setq kill-emacs-hook 'haskell-remove-tmp-files)
+ (setq haskell-simulate-send-region-called-p t)))
+ (save-excursion
+ (goto-char point1)
+ (setq haskell-tmp-files-list
+ (cons (list file
+ (current-buffer)
+ (save-excursion ; Calculate line no.
+ (beginning-of-line)
+ (1+ (count-lines 1 (point)))))
+ haskell-tmp-files-list)))
+ (write-region point1 point2 file nil 'dummy)
+ (haskell-shell)
+ (message "Using temporary file: %s" file)
+ (process-send-string
+ haskell-process-name
+ ;; string to send: load file;
+ (concat "load " haskell-use-left-delim file haskell-use-right-delim ";\n"))))
+
+(defun haskell-remove-tmp-files ()
+ "Remove the temporary files, created by haskell-simulate-send-region, if
+they still exist. Only files recorded in haskell-tmp-files-list are removed."
+ (message "Removing temporary files created by haskell-mode...")
+ (while haskell-tmp-files-list
+ (condition-case ()
+ (delete-file (car (car haskell-tmp-files-list)))
+ (error ()))
+ (setq haskell-tmp-files-list (cdr haskell-tmp-files-list)))
+ (message "Removing temporary files created by haskell-mode...done.")
+ (run-hooks 'haskell-old-kill-emacs-hook))
+
+(defun haskell-send-region ()
+ "Send region."
+ (interactive)
+ (let (start end)
+ (save-excursion
+ (setq end (point))
+ (exchange-point-and-mark)
+ (setq start (point)))
+ (haskell-simulate-send-region start end)))
+
+(defun haskell-send-buffer ()
+ "Send the buffer."
+ (interactive)
+ (haskell-simulate-send-region (point-min) (point-max)))
+
+(defun haskell-evaluate-expression (h-expr)
+ "Prompt for and evaluate an expression"
+ (interactive "sExpression: ")
+ (let ((str (concat h-expr ";\n"))
+ (buf (current-buffer)))
+ (haskell-pop-to-shell)
+ (insert str)
+ (process-send-string haskell-process-name str)
+ (pop-to-buffer buf)))
+
+
+;;
+;; font-lock-mode patterns, based on specs. in an earlier version
+;; of haskell-mode.el
+;; (these patterns have only been tested with 19.30)
+
+(defconst haskell-font-lock-keywords nil
+ "Conservative highlighting of a Haskell buffer
+(using font-lock.)")
+
+(let ((haskell-id "[a-z_][a-zA-Z0-9_'#]+")
+ (haskell-reserved-ids
+ (concat "\\b\\("
+ (mapconcat
+ 'identity
+ '("case" "class" "data"
+ "default" "deriving" "else"
+ "hiding" "if" "import" "in"
+ "instance" "interface" "let"
+ "module" "of" "renaming"
+ "then" "to" "type" "where" "infix[rl]?")
+ "\\|")
+ "\\)[ \t\n:,]"))
+ (haskell-basic-types
+ (concat "\\b\\("
+ (mapconcat 'identity
+ '("Bool" "()" "String" "Char" "Int"
+ "Integer" "Float" "Double" "Ratio"
+ "Assoc" "Rational" "Array")
+ "\\|")
+ "\\)\\b"))
+ (haskell-prelude-classes
+ (concat "\\b\\("
+ (mapconcat 'identity
+ '("Eq" "Ord" "Text" "Num" "Real" "Fractional"
+ "Integral" "RealFrac" "Floating" "RealFloat"
+ "Complex" "Ix" "Enum"
+ ;; ghc-isms
+ "_CCallable" "_CReturnable")
+ "\\|")
+ "\\)\\b"))
+ (haskell-reserved-ops
+ (mapconcat 'identity
+ '("\\.\\." "::"
+ "=>" "/=" "@"
+ "<-" "->")
+ "\\|"))
+ (glasgow-haskell-ops
+ (concat "\\b\\("
+ (mapconcat
+ 'identity
+ '(">>" ">>=" "thenPrimIO"
+ "seqPrimIO" "returnPrimIO"
+ "return" "_ccall_" "_casm_"
+ "thenST" "seqST" "returnST"
+ "thenStrictlyST" "seqStrictlyST" "returnStrictlyST"
+ "unsafeInterleavePrimIO" "unsafePerformIO")
+ "\\|")
+ "\\)\\b"))
+ (glasgow-haskell-types
+ (concat "\\b\\("
+ (mapconcat
+ 'identity
+ '("IO" "PrimIO" "_?ST"
+ "_Word" "_Addr" "_?MVar"
+ "_?IVar" "_RealWorld"
+ "_?MutableByteArray"
+ "_?ByteArray")
+ "\\|")
+ "\\)\\b")))
+ (setq haskell-font-lock-keywords
+ (list
+ '("--.*$" . font-lock-comment-face)
+ (list "[ \t\n]*\\([A-Za-z[(_][]A-Za-z0-9_$', ~@|:[)(#]*[ \t\n]*\\)=" 1 font-lock-function-name-face)
+ (list (concat "^>?[ \t\n]*\\(" haskell-id "\\)[ \t]*::") 1 'font-lock-function-name-face)
+ (list haskell-reserved-ids 0 'font-lock-function-name-face)
+ (list glasgow-haskell-ops 0 'font-lock-function-name-face)
+ (list glasgow-haskell-types 0 'font-lock-type-face)
+ (list haskell-basic-types 0 'font-lock-type-face)
+ (list haskell-prelude-classes 0 'font-lock-type-face)
+ (list "^[ \t\n]*\\([A-Za-z[(_][]A-Za-z0-9_$', @:[)(#]*[ \t\n]*\\)->" 1 font-lock-variable-name-face)
+ )))
+
+;;
+;; To enable font-lock-mode for Haskell buffers, add something
+;; like this to your ~/.emacs
+
+;(cond (window-system
+; (require 'font-lock)
+; (add-hook 'haskell-mode-hook
+; '(lambda () (make-local-variable 'font-lock-defaults)
+; (make-local-variable 'font-lock-mode-hook) ; don't affect other buffers
+; (setq font-lock-mode-hook nil)
+; (add-hook 'font-lock-mode-hook
+; '(lambda ()
+; (setq font-lock-keywords haskell-font-lock-keywords)))
+; (font-lock-mode 1))))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; END OF Haskell-MODE
+;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(provide 'haskell-mode)
--- /dev/null
+;; haskell-mode.el. Major mode for editing Haskell.
+;; Copyright (C) 1989, Free Software Foundation, Inc., Lars Bo Nielsen
+;; and Lennart Augustsson
+;; modified by Peter Thiemann, March 1994
+
+;; This file is not officially part of GNU Emacs.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY. No author or distributor
+;; accepts responsibility to anyone for the consequences of using it
+;; or for whether it serves any particular purpose or works at all,
+;; unless he says so in writing. Refer to the GNU Emacs General Public
+;; License for full details.
+
+;; Everyone is granted permission to copy, modify and redistribute
+;; GNU Emacs, but only under the conditions described in the
+;; GNU Emacs General Public License. A copy of this license is
+;; supposed to have been given to you along with GNU Emacs so you
+;; can know your rights and responsibilities. It should be in a
+;; file named COPYING. Among other things, the copyright notice
+;; and this notice must be preserved on all copies.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Haskell Mode. A major mode for editing and running Haskell. (Version 0.0)
+;; =================================================================
+;;
+;; This is a mode for editing and running Haskell.
+;; It is very much based on the sml mode for GNU Emacs. It
+;; features:
+;;
+;; - Inferior shell running Haskell. No need to leave emacs, just
+;; keep right on editing while Haskell runs in another window.
+;;
+;; - Automatic "load file" in inferior shell. Send regions of code
+;; to the Haskell program.
+;;
+;;
+;; 1. HOW TO USE THE Haskell-MODE
+;; ==========================
+;;
+;; Here is a short introduction to the mode.
+;;
+;; 1.1 GETTING STARTED
+;; -------------------
+;;
+;; If you are an experienced user of Emacs, just skip this section.
+;;
+;; To use the haskell-mode, insert this in your "~/.emacs" file (Or ask your
+;; emacs-administrator to help you.):
+;;
+;; (setq auto-mode-alist (cons '("\\.hs$" . haskell-mode) (cons '("\\.lhs$" . haskell-mode)
+;; auto-mode-alist)))
+;; (autoload 'haskell-mode "haskell-mode" "Major mode for editing Haskell." t)
+;;
+;; Now every time a file with the extension `.hs' or `.lhs' is found, it is
+;; automatically started up in haskell-mode.
+;;
+;; You will also have to specify the path to this file, so you will have
+;; to add this as well:
+;;
+;; (setq load-path (cons "/usr/me/emacs" load-path))
+;;
+;; where "/usr/me/emacs" is the directory where this file is.
+;;
+;; You may also want to compile the this file (M-x byte-compile-file)
+;; for speed.
+;;
+;; You are now ready to start using haskell-mode. If you have tried other
+;; language modes (like lisp-mode or C-mode), you should have no
+;; problems. There are only a few extra functions in this mode.
+;;
+;; 1.2. EDITING COMMANDS.
+;; ----------------------
+;;
+;; The following editing and inferior-shell commands can ONLY be issued
+;; from within a buffer in haskell-mode.
+;;
+;; LFD (haskell-newline-and-indent).
+;; This is probably the function you will be using the most (press
+;; CTRL while you press Return, press C-j or press Newline). It
+;; makes a new line and performs indentation based on the last
+;; preceding non-comment line.
+;;
+;; M-; (indent-for-comment).
+;; Like in other language modes, this command will give you a comment
+;; at the of the current line. The column where the comment starts is
+;; determined by the variable comment-column (default: 40).
+;;
+;; C-c C-v (haskell-mode-version).
+;; Get the version of the haskell-mode.
+;;
+;;
+;; 1.3. COMMANDS RELATED TO THE INFERIOR SHELL
+;; -------------------------------------------
+;;
+;; C-c C-s (haskell-pop-to-shell).
+;; This command starts up an inferior shell running haskell. If the shell
+;; is running, it will just pop up the shell window.
+;;
+;; C-c C-u (haskell-save-buffer-use-file).
+;; This command will save the current buffer and send a "load file",
+;; where file is the file visited by the current buffer, to the
+;; inferior shell running haskell.
+;;
+;; C-c C-f (haskell-run-on-file).
+;; Will send a "load file" to the inferior shell running haskell,
+;; prompting you for the file name.
+;;
+;; C-c C-r (haskell-send-region).
+;; Will send region, from point to mark, to the inferior shell
+;; running haskell.
+;;
+;; C-c C-b (haskell-send-buffer).
+;; Will send whole buffer to inferior shell running haskell.
+;;
+;; 2. INDENTATION
+;; ================
+;;
+;; The first indentation command (using C-j or TAB) on a given line
+;; indents like the last preceding non-comment line. The next TAB
+;; indents to the indentation of the innermost enclosing scope. Further
+;; TABs get you to further enclosing scopes. After indentation has
+;; reached the first column, the process restarts using the indentation
+;; of the preceding non-comment line, again.
+;;
+;; 3. INFERIOR SHELL.
+;; ==================
+;;
+;; The mode for Standard ML also contains a mode for an inferior shell
+;; running haskell. The mode is the same as the shell-mode, with just one
+;; extra command.
+;;
+;; 3.1. INFERIOR SHELL COMMANDS
+;; ----------------------------
+;;
+;; C-c C-f (haskell-run-on-file). Send a `load file' to the process running
+;; haskell.
+;;
+;; 3.2. CONSTANTS CONTROLLING THE INFERIOR SHELL MODE
+;; --------------------------------------------------
+;;
+;; Because haskell is called differently on various machines, and the
+;; haskell-systems have their own command for reading in a file, a set of
+;; constants controls the behavior of the inferior shell running haskell (to
+;; change these constants: See CUSTOMIZING YOUR Haskell-MODE below).
+;;
+;; haskell-prog-name (default "hbi").
+;; This constant is a string, containing the command to invoke
+;; Standard ML on your system.
+;;
+;; haskell-use-right-delim (default "\"")
+;; haskell-use-left-delim (default "\"")
+;; The left and right delimiter used by your version of haskell, for
+;; `use file-name'.
+;;
+;; haskell-process-name (default "Haskell").
+;; The name of the process running haskell. (This will be the name
+;; appearing on the mode line of the buffer)
+;;
+;; NOTE: The haskell-mode functions: haskell-send-buffer, haskell-send-function and
+;; haskell-send-region, creates temporary files (I could not figure out how
+;; to send large amounts of data to a process). These files will be
+;; removed when you leave emacs.
+;;
+;; 4. FONTIFICATION
+;;
+;; There is support for Jamie Zawinski's font-lock-mode through the
+;; variable "haskell-font-lock-keywords".
+;;
+;; 5. CUSTOMIZING YOUR Haskell-MODE
+;; ============================
+;;
+;; If you have to change some of the constants, you will have to add a
+;; `hook' to the haskell-mode. Insert this in your "~/.emacs" file.
+;;
+;; (setq haskell-mode-hook 'my-haskell-constants)
+;;
+;; Your function "my-haskell-constants" will then be executed every time
+;; "haskell-mode" is invoked. Now you only have to write the emacs-lisp
+;; function "my-haskell-constants", and put it in your "~/.emacs" file.
+;;
+;; Say you are running a version of haskell that uses the syntax `load
+;; ["file"]', is invoked by the command "OurHaskell" and you don't want the
+;; indentation algorithm to indent according to open parenthesis, your
+;; function should look like this:
+;;
+;; (defun my-haskell-constants ()
+;; (setq haskell-prog-name "OurHaskell")
+;; (setq haskell-use-left-delim "[\"")
+;; (setq haskell-use-right-delim "\"]")
+;; (setq haskell-paren-lookback nil))
+;;
+;; The haskell-shell also runs a `hook' (haskell-shell-hook) when it is invoked.
+;;
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;
+;; ORIGINAL AUTHOR
+;; Lars Bo Nielsen
+;; Aalborg University
+;; Computer Science Dept.
+;; 9000 Aalborg
+;; Denmark
+;;
+;; lbn@iesd.dk
+;; or: ...!mcvax!diku!iesd!lbn
+;; or: mcvax!diku!iesd!lbn@uunet.uu.net
+;;
+;; MODIFIED FOR Haskell BY
+;; Lennart Augustsson
+;; indentation stuff by Peter Thiemann
+;;
+;;
+;; Please let me know if you come up with any ideas, bugs, or fixes.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst haskell-mode-version-string
+ "HASKELL-MODE, Version 0.2, PJT indentation")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; CONSTANTS CONTROLLING THE MODE.
+;;;
+;;; These are the constants you might want to change
+;;;
+
+;; The command used to start up the haskell-program.
+(defconst haskell-prog-name "hbi" "*Name of program to run as haskell.")
+
+;; The left delimmitter for `load file'
+(defconst haskell-use-left-delim "\""
+ "*The left delimiter for the filename when using \"load\".")
+
+;; The right delimmitter for `load file'
+(defconst haskell-use-right-delim "\""
+ "*The right delimiter for the filename when using \"load\".")
+
+;; A regular expression matching the prompt pattern in the inferior
+;; shell
+(defconst haskell-shell-prompt-pattern "^> *"
+ "*The prompt pattern for the inferion shell running haskell.")
+
+;; The template used for temporary files, created when a region is
+;; send to the inferior process running haskell.
+(defconst haskell-tmp-template "/tmp/haskell.tmp."
+ "*Template for the temporary file, created by haskell-simulate-send-region.")
+
+;; The name of the process running haskell (This will also be the name of
+;; the buffer).
+(defconst haskell-process-name "Haskell" "*The name of the Haskell-process")
+
+;;;
+;;; END OF CONSTANTS CONTROLLING THE MODE.
+;;;
+;;; If you change anything below, you are on your own.
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defvar haskell-mode-syntax-table nil "The syntax table used in haskell-mode.")
+
+(defvar haskell-mode-map nil "The mode map used in haskell-mode.")
+
+(defvar haskell-mode-abbrev-table nil "The abbrev-table used in haskell-mode.")
+
+(defvar haskell-old-kill-emacs-hook nil "Old value of kill-emacs-hook")
+
+(defun haskell-mode ()
+ "Major mode for editing Haskell code.
+Tab indents for Haskell code.
+Comments are delimited with --
+Paragraphs are separated by blank lines only.
+Delete converts tabs to spaces as it moves back.
+
+Key bindings:
+=============
+
+\\[haskell-pop-to-shell]\t Pop to the haskell window.
+\\[haskell-save-buffer-use-file]\t Save the buffer, and send a \"load file\".
+\\[haskell-send-region]\t Send region (point and mark) to haskell.
+\\[haskell-run-on-file]\t Send a \"load file\" to haskell.
+\\[haskell-send-buffer]\t Send whole buffer to haskell.
+\\[haskell-mode-version]\t Get the version of haskell-mode.
+\\[haskell-evaluate-expression]\t Prompt for an expression and evalute it.
+
+
+Mode map
+========
+\\{haskell-mode-map}
+Runs haskell-mode-hook if non nil."
+ (interactive)
+ (kill-all-local-variables)
+ (if haskell-mode-map
+ ()
+ (setq haskell-mode-map (make-sparse-keymap))
+ (define-key haskell-mode-map "\C-c\C-v" 'haskell-mode-version)
+ (define-key haskell-mode-map "\C-c\C-u" 'haskell-save-buffer-use-file)
+ (define-key haskell-mode-map "\C-c\C-s" 'haskell-pop-to-shell)
+ (define-key haskell-mode-map "\C-c\C-r" 'haskell-send-region)
+ (define-key haskell-mode-map "\C-c\C-m" 'haskell-region)
+ (define-key haskell-mode-map "\C-c\C-f" 'haskell-run-on-file)
+ (define-key haskell-mode-map "\C-c\C-b" 'haskell-send-buffer)
+ (define-key haskell-mode-map "\C-ce" 'haskell-evaluate-expression)
+ (define-key haskell-mode-map "\C-j" 'haskell-newline-and-indent)
+ (define-key haskell-mode-map "\177" 'backward-delete-char-untabify))
+ (use-local-map haskell-mode-map)
+ (setq major-mode 'haskell-mode)
+ (setq mode-name "Haskell")
+ (define-abbrev-table 'haskell-mode-abbrev-table ())
+ (setq local-abbrev-table haskell-mode-abbrev-table)
+ (if haskell-mode-syntax-table
+ ()
+ (setq haskell-mode-syntax-table (make-syntax-table))
+ (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table)
+ (modify-syntax-entry ?} "){4" haskell-mode-syntax-table)
+; partain: out
+; (modify-syntax-entry ?- "_ 2356" haskell-mode-syntax-table)
+; (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table)
+; (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table)
+; partain: end out
+; partain: in
+ (modify-syntax-entry ?- "_ 23" haskell-mode-syntax-table)
+; (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table)
+; (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table)
+; partain: end in
+ (modify-syntax-entry ?\\ "\\" haskell-mode-syntax-table)
+ (modify-syntax-entry ?* "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?_ "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?' "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?: "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?| "." haskell-mode-syntax-table)
+ )
+ (set-syntax-table haskell-mode-syntax-table)
+ (make-local-variable 'require-final-newline) ; Always put a new-line
+ (setq require-final-newline t) ; in the end of file
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'haskell-indent-line)
+ (make-local-variable 'comment-start)
+ (setq comment-start "-- ")
+ (make-local-variable 'comment-end)
+ (setq comment-end "")
+ (make-local-variable 'comment-column)
+ (setq comment-column 60) ; Start of comment in this column
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "--[^a-zA-Z0-9]*") ; This matches a start of comment
+ (make-local-variable 'comment-indent-function)
+ (setq comment-indent-function 'haskell-comment-indent)
+ ;;
+ ;; Adding these will fool the matching of parens. I really don't
+ ;; know why. It would be nice to have comments treated as
+ ;; white-space
+ ;;
+ ;; (make-local-variable 'parse-sexp-ignore-comments)
+ ;; (setq parse-sexp-ignore-comments t)
+ ;;
+ (run-hooks 'haskell-mode-hook)) ; Run the hook
+
+(defun haskell-mode-version ()
+ (interactive)
+ (message haskell-mode-version-string))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; INDENTATION
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; some variables for later use
+
+(defvar haskell-open-comment "{-")
+(defvar haskell-close-comment "-}")
+(defvar haskell-indentation-counter 0
+ "count repeated invocations of indent-for-tab-command")
+(defvar haskell-literate-flag nil
+ "used to guide literate/illiterate behavior, set automagically")
+
+(defun haskell-newline-and-indent ()
+ (interactive)
+ (setq haskell-literate-flag
+ (save-excursion
+ (beginning-of-line)
+ (= (following-char) ?>)))
+ (newline)
+ (if haskell-literate-flag (insert ">"))
+ (haskell-indent-line))
+
+(defun haskell-indent-line ()
+ "Indent current line of ordinary or literate Haskell code."
+ (interactive)
+ (let ((indent (haskell-calculate-indentation-pjt-2)))
+ (if (/= (current-indentation) indent)
+ (let ((beg (progn
+ (beginning-of-line)
+ (if (= (following-char) ?>) (forward-char 1)) ;LITERATE
+ (point))))
+ (skip-chars-forward "\t ")
+ (delete-region beg (point))
+ (indent-to indent))
+ ;; If point is before indentation, move point to indentation
+ (if (< (current-column) (current-indentation))
+ (skip-chars-forward "\t ")))))
+
+(defun haskell-calculate-indentation ()
+ (save-excursion
+ (let ((col (current-column)))
+ (while (and (not (bobp)) ;skip over empty and comment-only lines
+ (= col (current-column)))
+ (previous-line 1)
+ (beginning-of-line) ; Go to first non whitespace
+ (if (= (following-char) ?>) ;LITERATE
+ (forward-char 1)
+ (if haskell-literate-flag ;ignore illiterate lines
+ (end-of-line)))
+ (skip-chars-forward "\t ") ; on the line.
+ (setq col (current-column))
+ (search-forward-regexp (concat haskell-open-comment "\\|--\\|\n") nil 0)
+ (goto-char (match-beginning 0)))
+ (search-backward-regexp "\\b\\(where\\|let\\|of\\|in\\)\\b\\|\n" nil 0)
+ (if (looking-at "\n")
+ ()
+ (setq col (current-column))
+ (forward-word 1)
+ (skip-chars-forward "\t ")
+ (if (looking-at "\\w")
+ (setq col (current-column))
+ (setq col (+ 2 col))))
+ col)))
+
+(defun haskell-calculate-indentation-pjt-2 ()
+ "Calculate indentation for Haskell program code, versatile version"
+ (save-excursion
+ (if (eq last-command 'haskell-indentation)
+ (setq haskell-indentation-counter (1+ haskell-indentation-counter))
+ (setq haskell-indentation-counter -1))
+ (setq this-command 'haskell-indentation)
+ (let* ((simple-indent (haskell-calculate-indentation))
+ (count haskell-indentation-counter)
+ (min-indent simple-indent) ; minimum indentation found in a non-comment line
+ (last-indent simple-indent) ; indentation of the following non-comment line
+ (return-indent nil) ; computed indentation
+ (comment-depth 0))
+ (previous-line 1)
+ (if (< haskell-indentation-counter 0) ; 1st tab gives simple indentation
+ (setq return-indent simple-indent))
+ (while (not return-indent)
+ (if (search-backward-regexp "\\b\\(where\\|let\\|of\\)\\b\\|\n\\|{-\\|-}" nil t 1)
+ (cond
+ ((looking-at haskell-open-comment)
+ (setq comment-depth (1- comment-depth)))
+ ((looking-at haskell-close-comment)
+ (setq comment-depth (1+ comment-depth)))
+ ((= 0 comment-depth)
+ (cond
+ ((looking-at "\n")
+ (save-excursion
+ (forward-char 1)
+ (if (= (following-char) ?>)
+ (forward-char 1)
+ (if haskell-literate-flag
+ (end-of-line))) ;LITERATE: ignore lines w/o >
+ (skip-chars-forward "\t ")
+ (if (looking-at (concat haskell-open-comment "\\|--\\|\n"))
+ ()
+ (setq last-indent (current-column))
+ (if (< last-indent min-indent)
+ (setq min-indent last-indent)))))
+ (t ; looking at a keyword
+ (save-excursion
+ (forward-word 1)
+ (skip-chars-forward " \t")
+ (if (and haskell-literate-flag ;LITERATE: ignore lines w/o >
+ (save-excursion
+ (beginning-of-line)
+ (/= (following-char) ?>)))
+ (end-of-line))
+ (if (looking-at (concat haskell-open-comment "\\|--\\|\n"))
+ ()
+ (setq last-indent (current-column)))
+ (if (<= last-indent min-indent)
+ (if (> count 0)
+ (setq count (1- count))
+ (setq return-indent last-indent)))
+ (if (< last-indent min-indent)
+ (setq min-indent last-indent)))))))
+ (setq return-indent simple-indent)
+ (setq haskell-indentation-counter -1)))
+ return-indent)))
+
+(defun haskell-skip-nested-comment ()
+ ;; point looks at opening {-, move over closing -}
+ ;; todo: specify what happens on failure, bounds check ...
+ (forward-char 2)
+ (let ((comment-depth 1))
+ (while (> comment-depth 0)
+ (search-forward-regexp "{-\\|-}")
+ (goto-char (match-beginning 0))
+ (setq comment-depth
+ (if (= (following-char) 123) ; code for opening brace
+ (1+ comment-depth)
+ (1- comment-depth)))
+ (goto-char (match-end 0)))))
+
+
+;;;seemingly obsolete functions
+(defun haskell-inside-of-inline-comment ()
+ (let ((bolp (save-excursion
+ (beginning-of-line)
+ (point))))
+ (search-backward comment-start bolp t 1)))
+
+(defun haskell-inside-of-nested-comment ()
+ (save-excursion
+ (let ((count 0))
+ (while
+ (search-backward-regexp "\\({-\\|-}\\)" 0 t 1)
+ (if (haskell-inside-of-inline-comment)
+ ()
+ (if (looking-at haskell-open-comment)
+ (setq count (1+ count))
+ (setq count (1- count)))))
+ (> count 0))))
+
+(defun haskell-inside-of-comment ()
+ (or (haskell-inside-of-inline-comment)
+ (haskell-inside-of-nested-comment)))
+
+;;;stolen from sml-mode.el
+(defun haskell-comment-indent ()
+ "Compute indentation for Haskell comments"
+ (if (looking-at "^--")
+ 0
+ (save-excursion
+ (skip-chars-backward " \t")
+ (max (1+ (current-column))
+ comment-column))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; INFERIOR SHELL
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar haskell-shell-map nil "The mode map for haskell-shell.")
+
+(defun haskell-shell ()
+ "Inferior shell invoking Haskell.
+It is not possible to have more than one shell running Haskell.
+Like the shell mode with the additional command:
+
+\\[haskell-run-on-file]\t Runs haskell on the file.
+\\{haskell-shell-map}
+Variables controlling the mode:
+
+haskell-prog-name (default \"hbi\")
+ The string used to invoke the haskell program.
+
+haskell-use-right-delim (default \"\\\"\")
+haskell-use-left-delim (default \"\\\"\")
+ The left and right delimiter used by your version of haskell, for
+ \"load file-name\".
+
+haskell-process-name (default \"Haskell\")
+ The name of the process running haskell.
+
+haskell-shell-prompt-pattern (default \"^> *\")
+ The prompt pattern.
+
+Runs haskell-shell-hook if not nil."
+ (interactive)
+ (if (not (process-status haskell-process-name))
+ (save-excursion ; Process is not running
+ (message "Starting Haskell...") ; start up a new process
+ (require 'shell)
+ (set-buffer (make-comint haskell-process-name haskell-prog-name))
+ (erase-buffer) ; Erase the buffer if a previous
+ (if haskell-shell-map ; process died in there
+ ()
+ (setq haskell-shell-map (copy-keymap shell-mode-map))
+ (define-key haskell-shell-map "\C-c\C-f" 'haskell-run-on-file))
+ (use-local-map haskell-shell-map)
+ (make-local-variable 'shell-prompt-pattern)
+ (setq shell-prompt-pattern haskell-shell-prompt-pattern)
+ (setq major-mode 'haskell-shell)
+ (setq mode-name "Haskell Shell")
+ (setq mode-line-format
+ "-----Emacs: %17b %M %[(%m: %s)%]----%3p--%-")
+ (set-process-filter (get-process haskell-process-name) 'haskell-process-filter)
+ (message "Starting Haskell...done.")
+ (run-hooks 'haskell-shell-hook))))
+
+(defun haskell-process-filter (proc str)
+ (let ((cur (current-buffer))
+ (pop-up-windows t))
+ (pop-to-buffer (concat "*" haskell-process-name "*"))
+ (goto-char (point-max))
+ (if (string= str "\b\b\b \b\b\b")
+ (backward-delete-char 4)
+ (insert str))
+ (set-marker (process-mark proc) (point-max))
+ (pop-to-buffer cur)))
+
+(defun haskell-pop-to-shell ()
+ (interactive)
+ (haskell-shell)
+ (pop-to-buffer (concat "*" haskell-process-name "*")))
+
+(defun haskell-run-on-file (fil)
+ (interactive "FRun Haskell on : ")
+ (haskell-shell)
+ (save-some-buffers)
+ (process-send-string haskell-process-name
+ (concat "load " haskell-use-left-delim (expand-file-name fil)
+ haskell-use-right-delim ";\n")))
+
+(defun haskell-save-buffer-use-file ()
+ "Save the buffer, and send a `use file' to the inferior shell
+running Haskell."
+ (interactive)
+ (let (file)
+ (if (setq file (buffer-file-name)) ; Is the buffer associated
+ (progn ; with file ?
+ (save-buffer)
+ (haskell-shell)
+ (process-send-string haskell-process-name
+ (concat "load " haskell-use-left-delim
+ (expand-file-name file)
+ haskell-use-right-delim ";\n")))
+ (error "Buffer not associated with file."))))
+
+(defvar haskell-tmp-files-list nil
+ "List of all temporary files created by haskell-simulate-send-region.
+Each element in the list is a list with the format:
+
+ (\"tmp-filename\" buffer start-line)")
+
+(defvar haskell-simulate-send-region-called-p nil
+ "Has haskell-simulate-send-region been called previously.")
+
+(defun haskell-make-temp-name (pre)
+ (concat (make-temp-name pre) ".m"))
+
+(defun haskell-simulate-send-region (point1 point2)
+ "Simulate send region. As send-region only can handle what ever the
+system sets as the default, we have to make a temporary file.
+Updates the list of temporary files (haskell-tmp-files-list)."
+ (let ((file (expand-file-name (haskell-make-temp-name haskell-tmp-template))))
+ ;; Remove temporary files when we leave emacs
+ (if (not haskell-simulate-send-region-called-p)
+ (progn
+ (setq haskell-old-kill-emacs-hook kill-emacs-hook)
+ (setq kill-emacs-hook 'haskell-remove-tmp-files)
+ (setq haskell-simulate-send-region-called-p t)))
+ (save-excursion
+ (goto-char point1)
+ (setq haskell-tmp-files-list
+ (cons (list file
+ (current-buffer)
+ (save-excursion ; Calculate line no.
+ (beginning-of-line)
+ (1+ (count-lines 1 (point)))))
+ haskell-tmp-files-list)))
+ (write-region point1 point2 file nil 'dummy)
+ (haskell-shell)
+ (message "Using temporary file: %s" file)
+ (process-send-string
+ haskell-process-name
+ ;; string to send: load file;
+ (concat "load " haskell-use-left-delim file haskell-use-right-delim ";\n"))))
+
+(defun haskell-remove-tmp-files ()
+ "Remove the temporary files, created by haskell-simulate-send-region, if
+they still exist. Only files recorded in haskell-tmp-files-list are removed."
+ (message "Removing temporary files created by haskell-mode...")
+ (while haskell-tmp-files-list
+ (condition-case ()
+ (delete-file (car (car haskell-tmp-files-list)))
+ (error ()))
+ (setq haskell-tmp-files-list (cdr haskell-tmp-files-list)))
+ (message "Removing temporary files created by haskell-mode...done.")
+ (run-hooks 'haskell-old-kill-emacs-hook))
+
+(defun haskell-send-region ()
+ "Send region."
+ (interactive)
+ (let (start end)
+ (save-excursion
+ (setq end (point))
+ (exchange-point-and-mark)
+ (setq start (point)))
+ (haskell-simulate-send-region start end)))
+
+(defun haskell-send-buffer ()
+ "Send the buffer."
+ (interactive)
+ (haskell-simulate-send-region (point-min) (point-max)))
+
+(defun haskell-evaluate-expression (h-expr)
+ "Prompt for and evaluate an expression"
+ (interactive "sExpression: ")
+ (let ((str (concat h-expr ";\n"))
+ (buf (current-buffer)))
+ (haskell-pop-to-shell)
+ (insert str)
+ (process-send-string haskell-process-name str)
+ (pop-to-buffer buf)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; keywords for jwz's font-look-mode (lemacs 19)
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(setq haskell-font-lock-keywords
+ (list (concat "\\b\\("
+ (mapconcat 'identity
+ '("case" "class" "data" "default" "deriving" "else" "hiding"
+ "if" "import" "in" "infix" "infixl" "infixr" "instance"
+ "interface" "let" "module" "of" "renaming" "then" "to"
+ "type" "where")
+ "\\|")
+ "\\)\\b")
+ (list "^\\(#[ \t]*\\(if\\|ifdef\\|ifndef\\|else\\|endif\\|include\\)\\)")
+ (list "\\(^>?\\|\\bwhere\\b\\|\\blet\\b\\)[ \t]*\\(\\(\\w\\|\\s_\\)+\\)\\(\\([^=\n]*\\S.\\)?=\\(\\S.\\|$\\)\\|[ \t]*::\\S.\\).*$"
+ 2 'font-lock-function-name-face)
+ (list "\\b\\(data\\|type\\)\\b[ \t]+\\(\\(\\w\\|\\s_\\)+\\)"
+ 2 'font-lock-type-face)
+ (list (concat "'\\([^\\]\\|\\\\\\([0-9]+\\|"
+ (mapconcat 'identity
+ '("a" "b" "f" "n" "r" "t" "v" "\\\\" "\"" "'" "&")
+ "\\|")
+ "\\|\\^\\([][_^A-Z@\\\\]\\)"
+ "\\)\\)'") 1 'font-lock-string-face)))
+
+;;; font-lock-keywords for literate style files
+
+(setq haskell-font-lock-keywords-2
+ (list (concat "^>.*\\b\\("
+ (mapconcat 'identity
+ '("case" "class" "data" "default" "deriving" "else" "hiding"
+ "if" "import" "in" "infix" "infixl" "infixr" "instance"
+ "interface" "let" "module" "of" "renaming" "then" "to"
+ "type" "where")
+ "\\|")
+ "\\)\\b")
+ (list "^>\\(.*\\(\\bwhere\\b\\|\\blet\\b\\)\\|\\)[ \t]*\\(\\(\\w\\|\\s_\\)+\\)\\(\\([^=\n]*\\S.\\)?=\\(\\S.\\|$\\)\\|[ \t]*::\\S.\\).*$"
+ 3 'font-lock-function-name-face)
+ (list "^>.*\\b\\(data\\|type\\)\\b[ \t]+\\(\\(\\w\\|\\s_\\)+\\)"
+ 2 'font-lock-type-face)
+ (list (concat "^>.*'\\([^\\]\\|\\\\\\([0-9]+\\|"
+ (mapconcat 'identity
+ '("a" "b" "f" "n" "r" "t" "v" "\\\\" "\"" "'" "&")
+ "\\|")
+ "\\|\\^\\([][_^A-Z@\\\\]\\)"
+ "\\)\\)'") 1 'font-lock-string-face)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; END OF Haskell-MODE
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(provide 'haskell-mode)
--- /dev/null
+;; Haskell major mode
+;; (c) Copyright, Richard McPhee et al.
+;; University of Glasgow, February 1993
+
+
+
+;; if .hs is not recognised then put the extension in auto-mode-list
+
+(if (assoc "\\.hs" auto-mode-alist)
+ nil
+ (nconc auto-mode-alist '(("\\.hs". haskell-mode))))
+
+(if (assoc "\\.hi" auto-mode-alist)
+ nil
+ (nconc auto-mode-alist '(("\\.hi". haskell-mode))))
+
+(if (assoc "\\.gs" auto-mode-alist)
+ nil
+ (nconc auto-mode-alist '(("\\.gs". haskell-mode))))
+
+(defvar haskell-mode-syntax-table nil
+ "Syntax table for haskell-mode buffers.")
+
+(defvar haskell-mode-abbrev-table nil
+ "Abbrev table for haskell-mode buffers.")
+
+(defvar haskell-mode-map (make-sparse-keymap)
+ "Keymap for haskell-mode-buffers.")
+
+
+
+;;; Here are the keymaps used in haskell-mode
+
+(define-key haskell-mode-map "\M-;" 'haskell-insert-comment)
+(define-key haskell-mode-map "\C-c=" 'haskell-insert-concat)
+(define-key haskell-mode-map "\C-c;" 'set-haskell-comment-column)
+(define-key haskell-mode-map "\C-c+" 'set-haskell-concat-column)
+(define-key haskell-mode-map "\C-cn" 'set-haskell-indent-offset)
+(define-key haskell-mode-map "\C-cl" 'set-haskell-list-offset)
+(define-key haskell-mode-map "\C-ci" 'set-haskell-if-offset)
+(define-key haskell-mode-map "\C-ce" 'set-haskell-let-offset)
+(define-key haskell-mode-map "\C-cc" 'set-haskell-case-offset)
+(define-key haskell-mode-map "\C-ct" 'set-haskell-then-offset)
+(define-key haskell-mode-map "\C-co" 'set-haskell-comp-offset)
+(define-key haskell-mode-map "\C-cw" 'set-haskell-where-offset)
+(define-key haskell-mode-map "\C-cg" 'goto-line)
+(define-key haskell-mode-map "\C-j" 'haskell-reindent-then-newline-and-indent)
+(define-key haskell-mode-map "\t" 'haskell-indent-line)
+(define-key haskell-mode-map "}" 'electric-haskell-brace)
+(define-key haskell-mode-map "]" 'electric-haskell-brace)
+(define-key haskell-mode-map ")" 'haskell-insert-round-paren)
+(define-key haskell-mode-map "\C-cr" 'haskell-indent-region)
+(define-key haskell-mode-map "\C-cf" 'haskell-further-indent)
+(define-key haskell-mode-map "\C-cb" 'haskell-lesser-indent)
+(define-key haskell-mode-map "\177" 'backward-delete-char-untabify)
+(define-key haskell-mode-map "\M-\C-\177" 'delete-horizontal-space)
+
+(defun haskell-set-local-vars ()
+ "Set the local variables for haskell-mode."
+ (kill-all-local-variables)
+
+ (setq indent-line-function 'haskell-indent-line)
+
+ (make-local-variable 'haskell-std-list-indent)
+ ;;Non-nil means indent to the offset, 'haskell-list-offset' in a bracket rather than
+ ;; moving to the next word afer a function name
+ (setq haskell-std-list-indent t)
+
+ (make-local-variable 'haskell-nest-ifs)
+ ;;Non-nil means that 'if' statements are nested ie. lined up with `if' not `else'.
+ (setq haskell-nest-ifs nil)
+
+ (make-local-variable 'haskell-align-else-with-then)
+ ;;Non-nil means align an `else' under it's corresponding `then'
+ (setq haskell-align-else-with-then nil)
+
+
+ ;;The local vars for 'where' indentation
+
+ (make-local-variable 'haskell-align-where-with-eq)
+ ;;Non-nil means align a 'where' under it's corresponding equals sign
+ (setq haskell-align-where-with-eq t)
+
+ (make-local-variable 'haskell-align-where-after-eq)
+ ;;Non-nil means align a 'where' after it's corresponding equals sign
+ (setq haskell-align-where-after-eq nil)
+
+ (make-local-variable 'haskell-std-indent-where)
+ ;;put the 'where' the standard offset ie. 'haskell-indent-offset'
+ (setq haskell-std-indent-where nil)
+
+
+ (make-local-variable 'haskell-always-fixup-comment-space)
+ ;;Non-nil means always insert a (single) space after a comment, even
+ ;; if there is more or less than one.
+ (setq haskell-always-fixup-comment-space t)
+
+
+ (make-local-variable 'haskell-indent-offset)
+ ;;Extra indentation for a line continued after a keyword.
+ (setq haskell-indent-offset 4)
+
+ (make-local-variable 'haskell-list-offset)
+ ;;Extra indentation for continuing a list.
+ (setq haskell-list-offset 4)
+
+ (make-local-variable 'haskell-comp-offset)
+ ;;Extra indentation for a list comprehension.
+ (setq haskell-comp-offset 4)
+
+ (make-local-variable 'haskell-case-offset)
+ (setq haskell-case-offset 4)
+
+ (make-local-variable 'haskell-where-offset)
+ (setq haskell-where-offset 4)
+
+ (make-local-variable 'haskell-let-offset)
+ (setq haskell-let-offset 4)
+
+ (make-local-variable 'haskell-then-offset)
+ (setq haskell-then-offset 0)
+
+ (make-local-variable 'haskell-if-offset)
+ (setq haskell-if-offset 4)
+
+ (make-local-variable 'haskell-comment-column)
+ (setq haskell-comment-column 35)
+
+ (make-local-variable 'haskell-concat-column)
+ (setq haskell-concat-column 69)
+
+ (make-local-variable 'haskell-where-threshold)
+ (setq haskell-where-threshold 35)
+
+ (make-local-variable 'line-comment)
+ (setq line-comment "-- ")
+
+ (make-local-variable 'haskell-indent-style)
+ (setq haskell-indent-style "none"))
+
+
+(defun haskell-set-syntax-table ()
+ "Set the syntax table for Haskell-mode."
+ (setq haskell-mode-syntax-table (make-syntax-table))
+ (set-syntax-table haskell-mode-syntax-table)
+ (modify-syntax-entry ?\" "\"")
+ (modify-syntax-entry ?\\ "\\")
+ (modify-syntax-entry ?\' "w")
+ (modify-syntax-entry ?_ "w")
+ (modify-syntax-entry ?# "_")
+ (modify-syntax-entry ?$ "_")
+ (modify-syntax-entry ?% "_")
+ (modify-syntax-entry ?: "_")
+ (modify-syntax-entry ?? "_")
+ (modify-syntax-entry ?@ "_")
+ (modify-syntax-entry ?! "_")
+ (modify-syntax-entry ?^ "_")
+ (modify-syntax-entry ?~ "_")
+ (modify-syntax-entry ?- "_ 12")
+ (modify-syntax-entry ?\n ">")
+ (modify-syntax-entry ?{ "(}")
+ (modify-syntax-entry ?} "){")
+ (set-syntax-table haskell-mode-syntax-table))
+
+
+
+(defun haskell-mode ()
+ "Major mode for editing Haskell code.
+Linefeed reindents current line, takes newline and indents.
+Tab indents current line for Haskell code.
+Functions are seperated by blank lines.
+Delete converts tabs to spaces as it moves back.
+\\{haskell-mode-map}
+Variables controlling indentation style:
+ haskell-indent-offset
+ Standard extra indentation for continuing Haskell
+ code under the scope of an expression. The default is 4.
+
+ haskell-list-offset
+ Extra indentation for indenting in a list. Used if variable
+ haskell-std-list-indent is non-nil. The default is 4.
+
+ haskell-comp-offset
+ Extra indentation for continuing a list comprehension.
+ The default is 4.
+
+ haskell-case-offset
+ Standard extra indentation for continuing Haskell
+ code under the scope of an expression. The default is 4.
+
+ haskell-where-offset
+ Standard extra indentation for continuing Haskell
+ code under the scope of a `where'. The default is 4.
+
+ haskell-let-offset
+ Standard extra indentation for continuing Haskell
+ code under the scope of a `let'. The default is 4.
+
+ haskell-then-offset
+ Standard extra indentation for a `then' beyond
+ its corresponding `if'. The default is 0.
+
+ haskell-if-offset
+ Standard extra indentation for continuing Haskell
+ code under the scope of an `if'. The default is 4.
+
+ haskell-comment-column
+ Column to which line comments `--' will be inserted.
+ The default is 35.
+
+ haskell-concat-column
+ Column to which concatenation operator `++' will be inserted.
+ The default is 69.
+
+ haskell-where-threshold
+ Column beyond which a `where' will be indented to the
+ start of a line (to avoid spilling over lines).
+ The default is 35.
+
+ set-haskell-indent-offset (C-c i)
+ Changes the default value of the local variable,
+ haskell-indent-offset. May be a number from 0-10.
+
+ set-haskell-list-indent (C-c l)
+ Change the value of the local variable,
+ haskell-list-offset. May be a number from 0-100.
+
+ set-haskell-comment-column (C-x ;)
+ Changes the value of the local variable,
+ haskell-comment-column. May be any number from 0-100."
+
+ (interactive)
+ (haskell-set-local-vars)
+ (haskell-set-syntax-table)
+ (use-local-map haskell-mode-map)
+ (setq major-mode 'haskell-mode)
+ (setq mode-name "Haskell")
+ (define-abbrev-table 'haskell-mode-abbrev-table ()))
+
+
+
+
+;;; Returns the indentation column for a comment on this line.
+;;; The point is positioned at the last char of any code on the line.
+
+(defun haskell-comment-indent ()
+ "Returns the indentation for a comment on the given line.
+If the line has code on it or the point is not at the beginning of the line,
+then indent to indent-column.
+Otherwise, don't indent."
+ (cond ((or (haskell-code-on-linep)
+ (not (bolp)))
+ ;;There is code before the haskell-comment-column
+ ;; or not at the beginning of the line
+ ;;Return the largest of
+ ;; the current column +1 and the haskell-comment-column
+ (max (1+ (current-column))
+ haskell-comment-column))
+ (t
+ ;;Otherwise, return 0
+ 0)))
+
+
+
+;;; Returns whether a comment is on the current line
+;;; Search from bol, and beware of "--", {-- etc!
+;;; DOES NOT RECOGNISE {- COMMENTS YET or -- within a string
+
+(defun haskell-comment-on-linep ()
+ "Returns the truth value of whether there is a '--' comment on the current line."
+ (save-excursion
+ (beginning-of-line)
+ (looking-at ".*--")))
+
+
+;;; This doesn't account for comments '{-'. Test explicitly if you use this function!
+
+(defun haskell-code-on-linep ()
+ "Returns a truth value as to whether there is code on the current line."
+ (save-excursion
+ (beginning-of-line)
+ (not
+ ;; Code on line if not looking at a comment directly
+ ;; and the line is not blank
+ (or
+ (looking-at "^[ \t]*--")
+ (looking-at "^[ \t]*$")))))
+
+
+;;; Insert a Haskell "--" comment on the current line.
+;;; Move to the comment position if there's already a comment here.
+;;; Otherwise, the comment is inserted either at the comment column
+;;; or one column after the last non-space character, whichever is further
+;;; to the right.
+;;; This function is executed by M-;
+
+(defun haskell-insert-comment ()
+ "Inserts a '--' comment on the given line."
+ (interactive)
+ (cond ((haskell-comment-on-linep)
+ ;;There is a comment on the line
+ ;;Just reindent existing comment
+ (haskell-reindent-comment))
+ (t
+ (if (haskell-code-on-linep)
+ ;;There is code on the line
+ ;; and guarenteed that a comment
+ ;; does not already exist.
+ ;;Move to the last nonspace char
+ ;; (there may be spaces after the last char)
+ (progn
+ (end-of-line)
+ (skip-chars-backward " \t")))
+ ;;Indent to required level
+ ;; and insert the line comment '--'
+ (indent-to (haskell-comment-indent))
+ (insert line-comment))))
+
+
+;;; Reindents a comment.
+;;; The comment is indented according to the normal rules.
+;;; Skips over ---- and following spaces or tabs
+
+(defun haskell-reindent-comment ()
+ "Indents a comment on a line to keep it at haskell-comment-column,
+if possible.
+It is guaranteed that a comment exists on the current line."
+ (beginning-of-line)
+ ;;Go back to beginning of comment
+ (re-search-forward "--")
+ (forward-char -2)
+ ;;Delete all spaces and reindent to
+ ;; the correct location.
+ (delete-horizontal-space)
+ (indent-to (haskell-comment-indent))
+ ;;Move past the comment and insert
+ ;; only one space between it and the text.
+ ;;Leave point just after comment.
+ (skip-chars-forward "- \t")
+ (if haskell-always-fixup-comment-space
+ (progn
+ (fixup-whitespace)
+ (forward-char 1))))
+
+
+
+;;; Inserts a haskell concatenation operator, `++', at the
+;;; column dictated by haskell-concat-column
+
+(defun haskell-insert-concat()
+ "Inserts a `++' operator on the given line."
+ (interactive)
+ (end-of-line)
+ (skip-chars-backward " \t")
+ ;;Indent to required level
+ ;; and insert the concat operator `++'
+ (indent-to (haskell-concat-indent))
+ (insert "++"))
+
+
+
+;;; Returns the indentation column for a concatenation operator on this line.
+;;; The point is positioned at the last char of any code on the line.
+
+(defun haskell-concat-indent ()
+ "Returns the indentation for a concat operator on the given line."
+ (max (1+ (current-column))
+ haskell-concat-column))
+
+
+
+;;; Returns the indentation of the current line of haskell code.
+;;; A blank line has ZERO indentation
+
+(defun haskell-current-indentation ()
+ "Returns the indentation for the current haskell line. A blank line has
+indentation zero."
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at "^[ \t]*$")
+ ;;The line is empty
+ ;; so the indentation is zero
+ 0
+ ;;Otherwise find the normal value of indentation
+ (current-indentation))))
+
+
+
+;;; Returns the indentation of the previous line of haskell code.
+;;; A blank line has ZERO indentation
+
+(defun haskell-previous-indentation ()
+ "Returns the previous line's indentation as Haskell indentation."
+ (save-excursion
+ (if (not (bobp))
+ ;;Not at the start of the buffer
+ ;; so get the previous lines indentation
+ (progn
+ (forward-line -1)
+ (haskell-current-indentation))
+ ;;We are at the start of buffer
+ ;;There is no previous line; Indent is zero
+ 0)))
+
+
+
+;;; Move back to the last line which is aligned in the left column.
+;;; Ignores comments and blank lines.
+;;; The point is left at the beginning of the line.
+
+(defun haskell-back-to-zero-indent ()
+ "Moves point to last line which has zero as indentation."
+ ;;Not at the beginning of buffer.
+ ;;Continue to go to the previous line until
+ ;; we find a line whose indentation is non-zero.
+ ;;Blank lines and lines containing only comments
+ ;; are ignored.
+ (beginning-of-line)
+ (while (and
+ (or (not (zerop (haskell-current-indentation)))
+ (looking-at "^[ \t]*\\($\\|--\\)"))
+ (not (bobp)))
+ (haskell-backward-to-noncomment)
+ (beginning-of-line)))
+
+
+
+;;; Find the last symbol, usually an equality.
+
+;;; Note: we check for "=" as a complete WORD (and ignore
+;;; comments) when searching for this. Ie. an `=' may be
+;;; surrounded only by a letter, digit, or whitespace .
+;;; Strings are not considered.
+;;; Don't go beyond the first character in the (possibly narrowed) buffer.
+;;; From the beginning of the line,
+;;; find the comment position (or end-of-line)
+;;; search forward to this position, looking for a "where"
+;;; If one's found, then search forward for "\b=\b"
+;;; If there's no equality sign then
+;;; search forward from the start of the line for an equals
+;;; Otherwise we found it.
+;;; If there's no where then search forward for an equals, as above.
+
+(defun haskell-back-to-symbol (exp)
+ "Goes backward from point until a symbol, EXP, is found.
+The point is left at the first symbol matching the context
+of the haskell code."
+ (let* ((found nil)
+ (symbol (concat "[ \ta-z0-9A-Z]" exp "[ \t\na-z0-9A-Z]"))
+ eol-limit
+ bol-limit
+ (zero-indent (save-excursion
+ (haskell-back-to-zero-indent)
+ (point)))
+ (initial-depth (car (parse-partial-sexp
+ (point)
+ zero-indent))))
+
+ (while (and (not found)
+ (> (point) zero-indent))
+ ;;Not found and point > point min
+ ;;Record the limit of search for the beginning and
+ ;; end of the line.
+ (setq eol-limit (point))
+ (beginning-of-line)
+ (setq bol-limit (point))
+ (goto-char eol-limit)
+ (re-search-backward "\\bwhere\\b" bol-limit 't)
+ ;;Search back from the end of the line
+ ;; to find the most recent 'where'.
+
+ (cond ((and (re-search-backward symbol bol-limit 't)
+ (= initial-depth
+ (car (parse-partial-sexp
+ (point)
+ zero-indent))))
+ ;;Found a symbol sign surrounded by
+ ;; a letter, digit or space only, or at the
+ ;; beginning of the buffer and they are at
+ ;; the same depth level
+ (setq found 't))
+ ((and (re-search-backward symbol bol-limit 't)
+ (zerop
+ (car (parse-partial-sexp
+ (point)
+ zero-indent))))
+ ;; Found a symbol and it is not in any parens
+ (setq found 't))
+ ;;Otherwise, go back a line.
+ (t (haskell-backward-to-noncomment))))
+ (if found
+ (forward-char 1))))
+
+
+;;; Goes back to the last keyword. The point is left at the
+;;; beginning of the keyword.
+;;; The words recognised are:
+;;; `case',`of',`where',`let',`in',`if',`then',`else'
+
+(defun haskell-back-to-keyword ()
+ "Goes backward from point until a keyword is found.
+The point is left after the first keyword."
+ (let* ((found nil)
+ eol-limit
+ bol-limit
+ (zero-indent (save-excursion
+ (haskell-back-to-zero-indent)
+ (point)))
+ (initial-depth (car (parse-partial-sexp
+ (point)
+ zero-indent))))
+
+ (while (and (not found)
+ (>= (point) zero-indent))
+ ;;Not found and point > point min
+ ;;Go back past any comment.
+ ;;Record the limit of search for the beginning and
+ ;; end of the line.
+ (setq eol-limit (point))
+ (beginning-of-line)
+ (setq bol-limit (point))
+ (goto-char eol-limit)
+ (if (and (re-search-backward
+ "\\b\\(case\\|of\\|where\\|let\\|in\\|if\\|then\\|else\\)\\b"
+ bol-limit 't)
+ (= initial-depth
+ (car (parse-partial-sexp
+ (point)
+ zero-indent))))
+ ;;Found a keyword and it is at the same level as the initial position
+ (progn
+ (setq found 't)
+ (forward-word 1))
+ ;;Otherwise, go back a line.
+ (haskell-backward-to-noncomment)))))
+
+
+
+;;; Returns the end of line (point) of the current line, excluding any
+;;; line comments on it.
+
+(defun haskell-eol ()
+ "Returns the end (point) of the current line, excluding any line comments."
+ (save-excursion
+ (end-of-line)
+ (let ((eol-limit (point)))
+ (beginning-of-line)
+ (if (search-forward "--" eol-limit 'move-to-eol)
+ ;;Found a '--'
+ ;;So move to the beginning of the comment
+ ;;If fail then move to end of line
+ (forward-char -2)))
+ (point)))
+
+
+
+;;; Returns whether or not the current line contains an equality outwith a
+;;; comment. The equality may only be surrounded by a letter, digit or
+;;; whitespace.
+
+(defun haskell-looking-at-eqp ()
+ "Returns whether or not the current line contains an equality outwith a
+comment."
+ (save-excursion
+ (beginning-of-line)
+ (re-search-forward "[ \ta-z0-9A-Z]=[ \t\na-z0-9A-Z]" (1+ (haskell-eol)) 't)))
+
+
+;;; This function does not require all keywords, just those which
+;;; may have a bracket before them.
+(defun haskell-looking-at-keywordp ()
+ "Returns whether or not there is a keyword after the point outwith a
+comment."
+ (save-excursion
+ (re-search-forward
+ "\\(\\(=>\\|=\\|++\\|->\\|<-\\|::\\)\\|\\b\\(case\\|of\\|if\\|then\\|else\\|let\\|in\\)\\b\\)"
+ (haskell-eol) 't)))
+
+
+;;; This function returns whether or not there is a keyword contained in
+;;; the region START END. START < END.
+
+(defun haskell-keyword-in-regionp (start end)
+ "Returns whether or not there is a keyword between START and END."
+ (save-excursion
+ (goto-char start)
+ (let ((found nil)
+ (eol-limit (haskell-eol)))
+ (while (and (not found) (< (point) end))
+ (if (> eol-limit end)
+ (setq eol-limit end))
+ (if (re-search-forward
+ "\\b\\(case\\|of\\|if\\|then\\|else\\|let\\|in\\)\\b"
+ eol-limit 'move)
+ (setq found t)
+ ;;Otherwise, have not found a keyword. Now at haskell-eol.
+ (if (< (point) end)
+ ;;We still have an area to search
+ ;; so go forward one line
+ (progn
+ (beginning-of-line)
+ (forward-line 1)
+ (setq eol-limit (haskell-eol))))))
+ ;;found is `t' or point >= end
+ found)))
+
+
+;;; Goes back to the last line which is not entirely commented out.
+;;; The point is left just before the comment.
+
+(defun haskell-backward-to-noncomment ()
+ "Sets the point to the last char on the line of Haskell code before a comment."
+ (let ((comment 't)
+ (limit (point-min)))
+ (while (and comment (> (point) limit))
+ ;; comment is true and point > limit
+ (beginning-of-line)
+ (if (< (forward-line -1) 0)
+ ;;This was the first line in the buffer
+ (setq comment nil)
+ ;;Otherwise, this was not the first line
+ (if (not (looking-at "^[ \t]*\\($\\|--\\)"))
+ ;;There is not a comment at the beginning of the line
+ ;; and the line is not blank
+ (progn
+ ;;The line is either blank or has code on it.
+ (setq comment nil)
+ (goto-char (haskell-eol))))))
+
+ ;;return point
+ (point)))
+
+
+
+;;; Indents a region (by applying "tab" to each line).
+;;; The marker upper-marker is set to the end of the region.
+;;; We indent from the beginning of the region to this marker.
+;;; Implements C-c r.
+
+(defun haskell-indent-region ()
+ "Indents the region between the point and mark."
+ (interactive)
+ (let ((lower-limit (min (point) (mark)))
+ (upper-limit (max (point) (mark))))
+ (indent-region lower-limit upper-limit 'nil)))
+
+
+
+;;; Implements TAB.
+;;; This actually indents a line.
+;;; Eventually it will handle a line split at any point,
+
+(defun haskell-indent-line ()
+ "Indent current line as Haskell code.
+Keeps the point at the same position on the line unless the
+point is less then the current indentation, in which case the
+point is moved to the first char."
+ (interactive)
+ (save-excursion
+ (let ((indent (haskell-calculate-indentation)))
+ (beginning-of-line)
+ (delete-horizontal-space)
+ ;;Kill any spaces that may preceed the code
+ ;; and reindent to the correct level.
+ (indent-to indent)))
+ (if (< (current-column) (current-indentation))
+ ;;The point is in the indentation
+ ;; so move to the first char on the line
+ (move-to-column (current-indentation))))
+
+
+
+;;; This is the haskell version of the Emacs function
+;;; reindent-then-newline-and-indent. It was necessary
+;;; to write this because the Emacs version has the
+;;; terrible property of deleting whitespace BEFORE
+;;; reindenting the original line.
+
+(defun haskell-reindent-then-newline-and-indent ()
+ "Reidents the current line of Haskell code then takes a
+newline and indents this new line."
+ (interactive)
+ (skip-chars-backward " \t")
+ (haskell-indent-line)
+ (newline)
+ (delete-horizontal-space)
+ (haskell-indent-line))
+
+
+
+;;; Returns whether the first word of the last line with zero indentation
+;;; is the same as the first word of the current line.
+;;; This function is based on the (reasonable?) assumption that
+;;; a function definition occurs on the left hand margin.
+;;; This is not quit reasonable since recusive functions are not
+;;; recognised.
+
+(defun haskell-continued-fn-defp ()
+ "Returns whether the first word on the last line with zero indentation
+matches the first word on the current line."
+ (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward " \t")
+ ;;Goto the first non space char
+ (haskell-word-eq (point)
+ (save-excursion
+ (forward-line -1)
+ (haskell-back-to-zero-indent)
+ (point)))))
+
+
+;;; Returns whether two words are the same.
+;;; The beginning of both words are given as their
+;;; respective points in the buffer.
+
+(defun haskell-word-eq (current-pos previous-pos)
+ (let ((OK 't))
+ (goto-char previous-pos)
+ ;;We shall compare the two words starting
+ ;; at previous-pos and current-pos.
+ (while (and OK (looking-at "\\S-"))
+ ;;OK and looking at a word constituent
+ (if (eq (char-after current-pos)
+ (char-after previous-pos))
+ ;;The two chars are the same
+ (progn
+ ;;Increment the two postions
+ ;; and update location of point
+ (setq current-pos (1+ current-pos))
+ (setq previous-pos (1+ previous-pos))
+ (goto-char previous-pos))
+ ;;The two chars are different
+ ;; so set OK to be false
+ (setq OK 'nil)))
+
+ ;;Return the value of OK
+ OK))
+
+
+
+
+;;; This function returns the column of the last unbalanced
+;;; expression.
+;;; It is called when an keyword is found. The point is
+;;; initially placed before the corresponding keyword.
+;;; The function looks at every word to see if it is a
+;;; `let' or `in'. Each word must be outwith a comment.
+
+(defun haskell-last-unbalanced-key-column (open close)
+ "Returns the column of the last unbalanced keyword, open."
+ (save-excursion
+ (let ((original-pos (point))
+ (bol-limit (save-excursion
+ (beginning-of-line)
+ (setq bol-limit (point))))
+ (depth 1))
+ (setq open (concat "\\b" open "\\b"))
+ (setq close (concat "\\b" close "\\b"))
+ (while (and
+ (> depth 0)
+ (> (point) (point-min)))
+ (forward-word -1)
+ (if (< (point) bol-limit)
+ ;;Moved past the beginning of line limit
+ ;; so go back to the previous line past
+ ;; any comments.
+ (progn
+ (goto-char original-pos)
+ (haskell-backward-to-noncomment)
+ (setq original-pos (point))
+ (setq bol-limit (save-excursion
+ (beginning-of-line)
+ (point))))
+ ;;Otherwise, still on the same line
+ (if (looking-at open)
+ ;;This word is an open keyword
+ (setq depth (1- depth))
+ ;;Otherwise,
+ (if (looking-at close)
+ ;;This word is a close keyword
+ (setq depth (1+ depth))))))
+
+ (if (string= open "\\bif\\b")
+ ;;The argument is `if'
+ (if (not (save-excursion (skip-chars-backward " \t") (bolp)))
+ ;;There is something before the `if'
+ (if (and (save-excursion
+ (forward-word -1)
+ (looking-at "\\belse\\b"))
+ (not haskell-nest-ifs))
+ ;;There is an `else' before the 'if'
+ (forward-word -1))))
+
+
+ (current-column))))
+
+
+
+;;; Return the indentation for a line given that we expect a `where'.
+;;; The point lies on the corresponding symbol
+;;; that the `where' scopes over.
+
+(defun haskell-indent-where ()
+ "Return the indentation for a line, given that we expect a `where'
+clause."
+ (let ((symbol (if (looking-at "=")
+ "="
+ "->")))
+
+ (cond ((or haskell-std-indent-where
+ (> (current-column) haskell-where-threshold))
+ ;;Set indentation as the sum of the previous
+ ;; line's layout column and the standard offset
+ ;; (ie. 'haskell-where-offset)
+ (save-excursion
+ (beginning-of-line)
+ (cond ((looking-at (concat "^[ \t]*" symbol))
+ ;;The line starts with the symbol
+ (setq indent (current-indentation)))
+ ((looking-at "^[ \t]*where\\b")
+ ;;The line starts with a 'where'
+ (forward-word 1)
+ (skip-chars-forward " \t")
+ (setq indent (+ (current-column) haskell-where-offset)))
+ (t
+ ;;The line begins on the layout column
+ (setq indent (+ (current-indentation)
+ haskell-indent-offset))))))
+ ((or haskell-align-where-with-eq
+ haskell-align-where-after-eq)
+ (if (looking-at (concat symbol "[ \t]*$"))
+ ;;The symbol is at the end of the line
+ (setq indent (+ (current-indentation)
+ haskell-where-offset))
+ (save-excursion
+ ;;Set the indentation as required
+ (if haskell-align-where-after-eq
+ (skip-chars-forward (concat symbol " \t")))
+ (setq indent (current-column))))))))
+
+
+
+;;; Calculates the indentation for the current line.
+;;; When we come here, we are in a line which we want to indent.
+;;; We should leave the point at the same relative position it
+;;; was in before we called the function, that is, if a line
+;;; is already correctly indented, nothing happens!
+
+;;; The main problems are handling "where" definitions
+;;; and the syntax of expressions when these are continued
+;;; over multiple lines (e.g. tuples, lists, or just plain
+;;; bracketed expressions). Watch out for let ... in, too!
+
+;;; For example, think about the following tricky cases:
+
+;;; f x = x + <NL>
+
+;;; f x = [ x + y, <NL>
+
+;;; f x = [ <NL>
+
+;;; f x = [ -- start of a large list
+;;; -- which I'm commenting in as I go
+;;; <TAB>
+
+(defun haskell-calculate-indentation ()
+ "Returns the indentation level for the current line of haskell code."
+ (save-excursion
+ (let ((indent 0)
+ (eol-position (point)))
+ (beginning-of-line)
+ (cond ((bobp)
+ ;;We are at the beginning of the buffer so do nothing at all
+ (setq indent 0))
+
+ ((looking-at "^[ \t]*--")
+ ;;There is a comment on the line by itself
+ ;;Leave it the way it is
+ (setq indent (current-indentation)))
+
+ ((looking-at "^[ \t]*\\(data\\|type\\|module\\|import\\|instance\\)\\b")
+ ;;There is a 'data', 'type', 'module' or 'import' at start of line
+ (setq indent 0))
+
+ ((haskell-continued-fn-defp)
+ ;;This is clearly same function
+ ;; so set indent to be 0
+ (setq indent 0))
+
+ ((looking-at "^[ \t]*[]}]")
+ ;;There is a "]" or "}" at the start of the line
+ (let ((state (parse-partial-sexp (match-end 0)
+ (save-excursion
+ (haskell-back-to-zero-indent)
+ (point)))))
+ (if (>= (car state) 0)
+ ;;Since the point is just after a parenthesis
+ ;; it has a match if the depth is >= 0
+ (save-excursion
+ (goto-char (nth 2 state))
+ ;;Move to the match.
+ (if (not
+ (save-excursion
+ (skip-chars-backward " \t")
+ (bolp)))
+ ;;There is something before the brace.
+ (progn
+ (let ((initial-pos (point)))
+ (forward-word -1)
+ (if (not (looking-at
+ "\\(let\\|where\\)"))
+ ;;The word is not `where' or `let'
+ ;; so go back.
+ (progn
+ (goto-char initial-pos)
+ (skip-chars-forward " \t"))))))
+ (setq indent (current-column)))
+ (setq indent 0))))
+
+ ((looking-at "^[ \t]*\\(->\\|=>\\)")
+ ;; '->' or '=>' at start of line
+ (save-excursion
+ (haskell-backward-to-noncomment)
+ ;;Go back to previous line
+ (let ((eol-limit (point)))
+ (beginning-of-line)
+ (if (re-search-forward "::" eol-limit 't)
+ ;;There is a '::' on this (previous) line
+ ;; set indent to be at the start of it
+ (setq indent (- (current-column) 2))
+ ;;Otherwise copy this (previous) line's indentation
+ (setq indent (current-indentation))))))
+
+ ((looking-at "^[ \t]*where\\b")
+ ;;There is a 'where' at the start of the line
+ ;;Look for the equality (which will not
+ ;; be on this line).
+ (haskell-backward-to-noncomment)
+ (goto-char (max (save-excursion
+ (haskell-back-to-symbol "=")
+ (point))
+ (save-excursion
+ (haskell-back-to-symbol "->")
+ (point))))
+ (setq indent (haskell-indent-where)))
+
+ ((looking-at "^[ \t]*then\\b")
+ ;;The first thing on the line is a `then'
+ (setq indent (+ (haskell-last-unbalanced-key-column "if" "then")
+ haskell-then-offset)))
+
+ ((looking-at "^[ \t]*else\\b")
+ ;;The first thing on the line is a `else'
+ (if haskell-align-else-with-then
+ (setq indent (haskell-last-unbalanced-key-column "then" "else"))
+ (setq indent (haskell-last-unbalanced-key-column "if" "else"))))
+
+ ((looking-at "^[ \t]*|")
+ ;;There is a `|' at beginning of line
+ (save-excursion
+ (let ((state
+ (parse-partial-sexp (save-excursion
+ (haskell-back-to-zero-indent)
+ (point))
+ (point))))
+ (if (not (or (nth 3 state) (nth 4 state)))
+ ;;Not in a comment or string
+ (if (> (car state) 0)
+ ;;In an unbalanced parenthesis.
+ (progn
+ (goto-char (nth 1 state))
+ ;;Move to the beginning of the unbalanced parentheses
+ (if (and (looking-at "\\[")
+ (search-forward "|" (haskell-eol) 't))
+ ;;It is a list comprehension
+ (setq indent (1- (current-column)))
+ (setq indent (+ (current-column)
+ haskell-comp-offset))))
+ ;;Otherwise, not in an unbalanced parenthesis
+ (setq indent (save-excursion
+ (haskell-back-to-symbol "=")
+ (cond ((not (looking-at "="))
+ ;;Did not find an equals
+ (+ (haskell-previous-indentation)
+ haskell-indent-offset))
+ ((save-excursion
+ (beginning-of-line)
+ (looking-at "^[ \t]*data\\b"))
+ ;;There is a `data' at beginning
+ (setq indent (current-column)))
+ ((save-excursion
+ (beginning-of-line)
+ (search-forward
+ "|" (haskell-eol) 't))
+ ;;There is a `|' on this line
+ ;; so set this to be the indent
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (current-column)))
+ (t
+ ;;Otherwise, set `=' as indent
+ (current-column))))))))))
+
+ ((looking-at "^[ \t]*=")
+ ;;There is an equals at the start of the line
+ ;;Set the indentation to be the previous line's
+ ;; indentation plus the standard offset
+ (setq indent (+ haskell-indent-offset
+ (haskell-previous-indentation))))
+
+ ((looking-at "^[ \t]*in\\b")
+ ;;The line starts with 'in'
+ (beginning-of-line)
+ (setq indent (haskell-last-unbalanced-key-column "let" "in")))
+
+ ((looking-at "^[ \t]*of\\b")
+ ;;The line starts with `of'
+ (beginning-of-line)
+ (setq indent (haskell-last-unbalanced-key-column "case" "of")))
+
+ ((looking-at "^.*::")
+ ;;There is a '::' in the line
+ ;;There are several possibilities for indentation
+ (if (looking-at "[ \t]*::")
+ ;;The '::' is the first thing on the line
+ ;; so set indent to be the previous line's
+ ;; indentation plus the standard offset
+ (setq indent (+ (haskell-previous-indentation)
+ haskell-indent-offset))
+ (save-excursion
+ ;;Otherwise, the '::' is contained in the line somewhere
+ ;; so use contextual indentation
+ (setq indent (haskell-context-indent)))))
+
+ (t
+ ;;Do not recognise the first word on the line.
+ (setq indent (haskell-context-indent))))
+
+ indent))) ;return indent as indentation value
+
+
+
+;;; Returns the indentation for the current line by looking at the
+;;; previous line to give clues to the indentation.
+
+(defun haskell-context-indent ()
+ "Returns the indentation for the current line by looking at
+the previous line to dictate the indentation."
+ (save-excursion
+ (let ((original-position (point))
+ indent)
+ (beginning-of-line)
+ (if (bobp)
+ ;;At the beginning of the buffer
+ (setq indent 0)
+ ;;Otherwise, we are not at the beginning of the buffer
+ (haskell-backward-to-noncomment)
+ (let ((eol-limit (point))
+ ;;Record the (upper) limit for any search on this line
+ bol-limit
+ (paren-indent 'nil))
+ ;;`paren-indent' flags whether we are indenting a list or not
+ (beginning-of-line)
+ (setq bol-limit (point))
+ ;;Record the (lower) limit for any search on this line
+ (goto-char eol-limit) ;goto the end of the line
+ (flag)
+ (if (save-excursion
+ (goto-char eol-limit)
+ (and (re-search-backward
+ "[])][^][()]*" bol-limit 't)
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (not (haskell-looking-at-keywordp)))))
+
+ ;;There is a close parenthesis at the end of the line
+ ;; followed by anything except "(", ")", "[", "]"
+ ;; or a keyword
+ (progn
+ ;;Search back for the close parenthesis
+ ;; and move to just after it.
+ (re-search-backward "[])]" bol-limit 't)
+ (forward-char 1)
+ (let ((state
+ (parse-partial-sexp (save-excursion
+ (haskell-back-to-zero-indent)
+ (point))
+ (point))))
+ (if (not (or (nth 3 state) (nth 4 state)))
+ ;;Not in a comment or string
+ (if (>= (car state) 0)
+ ;;The parenthesis has a match
+ (progn
+ (goto-char (nth 2 state))
+ ;;Move to the beginning of the parentheses
+ ;; as this new line will determine
+ ;; further indentation
+ (if (zerop (car state))
+ ;;This paren closes all unbalanced parens
+ ;; so move to
+ ;; the eol of last line with an equality.
+ (progn
+ (setq eol-limit (point))
+ (goto-char
+ (max (save-excursion
+ (haskell-back-to-symbol "=")
+ (point))
+ (save-excursion
+ (haskell-back-to-keyword)
+ (point))))
+ (goto-char eol-limit))
+ ;;esle just go to the end of the line
+ (goto-char (haskell-eol)))
+ (setq paren-indent 't)
+ ;;Set 'paren-indent' to true to indicate we
+ ;; are indenting a list.
+ (setq eol-limit (point))
+ (beginning-of-line)
+ (setq bol-limit (point))
+ ;;Reduce the scope of any later
+ ;; indentation to
+ ;; exclude the balanced parentheses
+ ;; by making this point
+ ;; be the eol-limit.
+ (goto-char eol-limit)))))))
+ (flag)
+ ;;This cond expression is structured, to an
+ ;; extent, such that the keywords with highest
+ ;; indentation precedence come first. Order is important.
+ ;;In each condition, the point of match is noted so
+ ;; that we can see if this point is in a string.
+ (let ((indent-point (point)))
+ (cond ((re-search-backward "\\bof\\b" bol-limit 't)
+ ;; `of' is contained in previous line
+ (setq indent-point (point))
+ (if (looking-at "of[ \t]*$")
+ ;;`of' at end of line
+ (setq indent (+ (haskell-last-unbalanced-key-column
+ "case" "of")
+ haskell-case-offset))
+ ;;Otherwise, `of' is in line
+ (forward-word 1)
+ (skip-chars-forward " \t")
+ (setq indent (current-column))
+ (setq indent (list indent))))
+
+ ((re-search-backward
+ "\\bthen[ \t]*$" bol-limit 't)
+ ;;There is a `then' at the end of the line.
+ (setq indent-point (point))
+ (if haskell-align-else-with-then
+ ;;We want to align the `else' (to follow) with the `then'
+ (setq indent (+ (current-column)
+ haskell-if-offset))
+ (setq indent (+ (haskell-last-unbalanced-key-column
+ "if" "then")
+ haskell-if-offset))))
+ ;; This was here but don't know why (setq indent (list indent))))
+
+ ((save-excursion
+ (and (re-search-backward "\\bif\\b" bol-limit 't)
+ (setq indent-point (point))
+ (not (re-search-forward "\\bthen\\b" eol-limit 't))))
+ ;;There is an `if' on the (previous) line and the line does
+ ;; not have a `then' on it.
+ (setq indent (+ (haskell-last-unbalanced-key-column
+ "if" "then")
+ haskell-then-offset)))
+
+ ((save-excursion
+ (and (re-search-backward "\\bif\\b" bol-limit 't)
+ (setq indent-point (point))
+ (not (re-search-forward "\\belse\\b" eol-limit 't))))
+ ;;There is an `if' on the (previous) line (the line may
+ ;; have a `then' on it) and does not have an else on it.
+ (if (re-search-backward "\\bthen\\b" bol-limit 't)
+ ;;There is a then on the line and it is followed by
+ ;; some code.
+ (progn
+ (forward-word 1)
+ (skip-chars-forward " \t")
+ (setq indent (current-column)))
+ (if haskell-align-else-with-then
+ ;;We want to align the `else' with the `then'
+ (setq indent (haskell-last-unbalanced-key-column
+ "then" "else"))
+ (setq indent (haskell-last-unbalanced-key-column
+ "if" "else")))))
+
+ ((re-search-backward "\\b\\(let\\|in\\)\\b" bol-limit 't)
+ ;; 'let' or 'in' is contained in the (previous) line
+ (setq indent-point (point))
+ (forward-word 1) ;skip past the word
+ (skip-chars-forward " \t{")
+ (if (looking-at "\\($\\|--\\)")
+ ;;looking-at eol or comment
+ (progn
+ (forward-word -1)
+ (setq indent (+ (current-column)
+ haskell-let-offset)))
+ (setq indent (current-column))))
+
+ ((re-search-backward
+ "\\belse[ \t]*$" bol-limit 't)
+ ;;There is a `else' at end of line
+ (setq indent-point (point))
+ (save-excursion
+ (goto-char eol-limit)
+ (forward-word -1)
+ (setq indent (+ (current-column)
+ haskell-if-offset))))
+
+ ((re-search-backward
+ "\\belse\\b" bol-limit 't)
+ ;;There is a `else' on the line with no if or then
+ (setq indent-point (point))
+ (save-excursion
+ (forward-word 1)
+ (skip-chars-forward " \t")
+ (setq indent (current-column))))
+
+ ((save-excursion
+ (beginning-of-line)
+ (looking-at
+ "^[ \t]*then\\b"))
+ ;;There is a 'then' at beginning of line
+ (setq indent-point (point))
+ (setq indent (current-indentation)))
+
+ ((save-excursion
+ (beginning-of-line)
+ (looking-at "^[ \t]*else[ \t]*if\\b"))
+ (setq indent-point (point))
+ ;;There is an 'else if' at start of (previous) line
+ (save-excursion
+ (beginning-of-line)
+ (if haskell-nest-ifs
+ (save-excursion
+ (forward-word 1)
+ (skip-chars-forward " \t")
+ (setq indent (current-column)))
+ (skip-chars-forward " \t")
+ (setq indent (current-column)))))
+
+ ((re-search-backward "\\bcase\\b" bol-limit 't)
+ ;;There is a 'case' on the previous line
+ ;; so copy this line's indentation and add on
+ ;; the offset unless there is not an of.
+ (setq indent-point (point))
+ (setq indent (+ (current-column)
+ haskell-case-offset)))
+
+ ((save-excursion
+ (beginning-of-line)
+ (looking-at "^\\(instance\\|class\\)\\b"))
+ ;;This (previous) line has an 'instance' or 'class' at start
+ ;; so just set indentation to be this line indentation
+ ;; plus the standard offset
+ (setq indent-point (point))
+ (setq indent (+ (current-indentation)
+ haskell-indent-offset)))
+
+ ((re-search-backward "where\\b" bol-limit 't)
+ ;;There is a 'where' on the (previous) line
+ (setq indent-point (point))
+ (if (looking-at "where[ \t]*$")
+ ;;There is nothing after the 'where'
+ ;; so set indent to be this column
+ ;; (ie. the column of the 'w')
+ ;; plus the standard offset
+ (if (save-excursion
+ (skip-chars-backward " \t")
+ (bolp))
+ ;;The 'where' is the only thing on the line.
+ (setq indent (+ (current-column)
+ haskell-where-offset))
+ ;;Otherwise, the 'where' is at the end
+ ;; of the line and there is code before it.
+ ;;Look before the 'where' for the symbol
+ ;; it scopes over.
+ (forward-word -1)
+ (goto-char (max (save-excursion
+ (haskell-back-to-symbol "=")
+ (point))
+ (save-excursion
+ (haskell-back-to-symbol "->")
+ (point))))
+ (setq indent (haskell-indent-where)))
+
+ ;;Otherwise, go past the 'where'
+ ;; and goto the last non space character.
+ ;;Set this column to be the indentation.
+ (forward-word 1)
+ (skip-chars-forward " \t")
+ (setq indent (current-column))))
+
+ ((re-search-backward
+ "[ \ta-z0-9A-Z]=[ \t]*$" bol-limit 't)
+ ;;There is an equals is at the end of line
+ ;; so make the indentation be this line's indentation
+ ;; plus the standard offset
+ (setq indent-point (point))
+ (setq indent (+ (current-indentation)
+ haskell-indent-offset)))
+
+ ((re-search-backward
+ "[ \ta-z0-9A-Z]\\+\\+[ \t]*$" bol-limit 't)
+ ;;There is a concat operator at the end of line
+ ;; so make the indentation be this line's indentation
+ (setq indent-point (point))
+ (setq indent (current-indentation)))
+
+ ((save-excursion
+ (beginning-of-line)
+ (looking-at
+ "^[ \t]*=[ \ta-z0-9A-Z]"))
+ ;;There is an equals is at the beginning of line
+ ;; so make the indentation be the previous line's
+ ;; indentation unless the previous line's
+ ;; indentation is zero.
+ (setq indent-point (point))
+ (save-excursion
+ (haskell-backward-to-noncomment)
+ (if (zerop (current-indentation))
+ (setq indent (+ (current-indentation)
+ haskell-indent-offset))
+ (setq indent (haskell-current-indentation)))))
+
+ ((re-search-backward "|" bol-limit 't)
+ ;;There is an `|' on this line.
+ (setq indent-point (point))
+ (if (save-excursion
+ (goto-char original-position)
+ (looking-at "^[ \t]*\\($\\|--\\||\\)"))
+ ;;The original line is empty or has a `|' at the
+ ;; start. So set indent to be first `|' on this line
+ (save-excursion
+ (goto-char bol-limit)
+ (re-search-forward "|" eol-limit 't)
+ (setq indent (1- (current-column))))
+ ;;Otherwise set indent to be this (previous) line's
+ (setq indent 0)))
+
+ ((re-search-backward "->" bol-limit 't)
+ ;;There is a `->' in the line.
+ ;;This may be from a `case' or a
+ ;; type declaration.
+ (setq indent-point (point))
+ (save-excursion
+ (if (re-search-backward "::" bol-limit 't)
+ ;;There is a '::' on this line
+ (if (looking-at ".*->[ \t]*$")
+ ;;The '->' is at the end of line.
+ ;;Move past the '::' and any spaces
+ ;; and set indent to be this column.
+ (progn
+ (skip-chars-forward ": \t")
+ (setq indent (current-column)))
+ ;;Otherwise, the '->' is not at end of line
+ ;; so copy the indentation
+ (setq indent (haskell-context-indent)))
+
+ ;;Otherwise, there is not a
+ ;; `::' on this line so copy this
+ ;; (previous) indentation.
+ (setq indent (haskell-context-indent)))))
+
+ ((re-search-backward "::" bol-limit 't)
+ ;;There is an '::' on this line.
+ ;;We know that the line does not end with '->'.
+ (setq indent-point (point))
+ (if (looking-at "::[ \t]*$")
+ ;;The '::' is at the end of the line
+ ;; so set indent to be this line's
+ ;; indentation plus the offset.
+ (setq indent (+ (current-indentation)
+ haskell-indent-offset))
+ ;;Otherwise the `::' is in the line
+ (setq indent (current-indentation))))
+
+ ((re-search-backward
+ "\\b\\(import\\|class\\)\\b"
+ bol-limit 't)
+ ;;There is an `import' or `class' on the line.
+ ;;Copy this indentation.
+ (setq indent-point (point))
+ (setq indent (current-indentation)))
+
+ ((or
+ (haskell-looking-at-eqp)
+ (save-excursion
+ (beginning-of-line)
+ (looking-at "^[ \t]*$")))
+ ;;There is an '=' on the line
+ ;; or it is blank
+ (setq indent-point (point))
+ (cond ((save-excursion
+ (beginning-of-line)
+ (looking-at "^[ \t]*data\\b"))
+ ;;`data' at start of line
+ ;; so expect a `|'
+ (haskell-back-to-symbol "=")
+ (setq indent (current-column)))
+ ((zerop (current-indentation))
+ ;;If the indentation is zero, we expect a `where'
+ (goto-char eol-limit)
+ (haskell-back-to-symbol "=")
+ (setq indent (haskell-indent-where)))
+ ((looking-at "^[ \t]*=[ \t\na-z0-9A-Z]")
+ ;;The equality is the first thing on the line
+ ;; so copy the last lines indentation
+ (save-excursion
+ (haskell-backward-to-noncomment)
+ (setq indent (current-indentation))))
+ (t
+ ;;Otherwise, copy the indentation
+ (setq indent (current-indentation)))))
+
+ ((save-excursion
+ (beginning-of-line)
+ (and (zerop (current-indentation))
+ (not (looking-at "^[ \t]*$"))))
+ ;;The line is not blank and its indentation is zero
+ ;;It is a function definition. We know that
+ ;; there is not an equals on the line
+ (goto-char eol-limit)
+ ;;We expect a keyword
+ ;; so set indent to be this line's indentation
+ ;; plus the offset
+ (setq indent-point (point))
+ (setq indent (+ (current-indentation)
+ haskell-indent-offset)))
+
+ ((bobp)
+ ;;At the beginning of buffer
+ (setq indent 0))
+
+ (paren-indent
+ ;;We are indenting a list and none
+ ;; of the above indentations are applicable
+ ;; so copy the indentation of this line
+ (setq indent (current-indentation)))
+
+ (t
+ (save-excursion
+ (setq indent (haskell-context-indent)))))
+
+ (if (nth 3 (parse-partial-sexp
+ (save-excursion
+ (goto-char indent-point)
+ (haskell-back-to-zero-indent)
+ (point))
+ (save-excursion
+ (goto-char indent-point))))
+ ;;The point we determined indentation at is in a
+ ;; string so go to this point and go back one line to
+ ;; find indentation.
+ (setq indent (haskell-context-indent))))
+
+
+ ;;HOWEVER, we may have to override any indentation if we are in
+ ;; an unbalanced parenthesis (on the original line).
+ (flag)
+ (save-excursion
+ (goto-char original-position)
+ (let* ((eq-point (save-excursion
+ (haskell-back-to-symbol "=")
+ (point)))
+ (state (parse-partial-sexp
+ eq-point
+ (point))))
+ (if (> (car state) 0)
+ ;;There is an unbalanced parenthesis between
+ ;; the function and here.
+ (if (not (or (nth 3 state) (nth 4 state)))
+ ;;We are not in a string or comment
+ ;; so goto the parenthesis
+ (progn
+ (goto-char (nth 1 state))
+ (if (not (haskell-keyword-in-regionp
+ (point)
+ original-position))
+ ;;There is not a keyword after the open
+ ;; bracket so we override the indentation
+ (progn
+ (if (not (looking-at "{"))
+ ;;The parenthesis is not a `{'
+ (if (or (looking-at "\\[")
+ (save-excursion
+ (goto-char (haskell-eol))
+ (skip-chars-backward " \t")
+ (and
+ (char-equal (preceding-char) ?,)
+ (= (car state)
+ (car (parse-partial-sexp
+ eq-point
+ (point)))))))
+ ;;The paren is a square one
+ ;; or it is a tuple.
+ ;;Don't ignore what is after it.
+ (setq indent (haskell-list-align (haskell-eol)))
+ ;;Otherwise, ignore what comes after it.
+ (setq indent (haskell-list-align (point))))))))))))
+ ))
+
+ indent)))
+
+
+;;; Inserts the close parenthesis and reindents the line.
+;;; We want to reindent the line if the parenthesis is
+;;; the first character on the line. The parenthesis
+;;; recognised by this function are `]', `}'.
+
+(defun electric-haskell-brace ()
+ "Inserts the character `]' or `}' and reindents the current line."
+ "Insert character and correct line's indentation."
+ (interactive)
+ (if (save-excursion
+ (skip-chars-backward " \t")
+ (bolp))
+ ;;The parenthesis is at the beginning of the line.
+ (progn
+ (insert last-command-char)
+ (haskell-indent-line))
+ ;;Otherwise it is not at the beginning of line.
+ (insert last-command-char))
+ ;; Match its beginning.
+ (haskell-blink-open))
+
+
+
+
+;;; This function returns the indentation for the next line given
+;;; that it is contained in a bracket or we are extending a functions
+;;; parameters over a line. For the case of being in an unbalanced
+;;; parenthesis list, the point lies on the unbalanced parenthesis.
+;;; The parameter eol-limit is used to delimit the end of the line.
+
+(defun haskell-list-align (eol-limit)
+ "Returns the indentation for the next line given that
+the point lies on an unbalanced open parenthesis."
+ (save-excursion
+ (let ((indent (1+ (current-column))))
+ ;;Set indent to be the next char (at least).
+
+ (cond ((not
+ (looking-at ".[ \t]*\\($\\|--\\)"))
+ ;;There is something after the parenthesis
+ ;;ie. the line is not empty and ignore comments
+ (cond ((save-excursion
+ (goto-char eol-limit)
+ (skip-chars-backward " \t")
+ (and (char-equal (preceding-char) ?,)
+ (save-excursion
+ (beginning-of-line)
+ (not (search-forward "|" eol-limit 't)))))
+ ;;This is a normal list since a `,' at end
+ ;; and there is no a `|' on the line.
+ (forward-char 1)
+ (skip-chars-forward " \t")
+ (setq indent (current-column)))
+
+ ((looking-at "\\[")
+ ;;It is a list comp we are looking at
+ ;;Goto the bar.
+ (forward-char 1)
+ (search-forward "|" eol-limit 't)
+ (skip-chars-forward " \t")
+ (setq indent (current-column)))
+
+ ((looking-at ".[ \t]*(")
+ ;;We are looking at an open parenthesis
+ ;; after this character.
+ ;;It must be balanced so
+ ;; move to the start of this paren
+ ;; and set indent to be here
+ (forward-char 1)
+ (skip-chars-forward " \t")
+ (setq indent (current-column)))
+
+ (t
+ (forward-word 1)
+ ;;We are not looking at another open
+ ;; parenthesis, so move forward past the
+ ;; (assumed) function name.
+ (if (or
+ haskell-std-list-indent
+ (looking-at"[ \t]*\\($\\|--\\)"))
+ ;;There is nothing after the name
+ ;; or haskell-std-list-offset is set
+ ;; so set indent to be its original
+ ;; value plus the offset minus 1
+ ;; since we added one on earlier.
+ (setq indent
+ (+ indent
+ (1- haskell-list-offset)))
+
+ ;;Otherwise there is something after the
+ ;; name, so skip to the first non space
+ ;; character.
+ (skip-chars-forward " \t")
+ (setq indent (current-column)))))))
+
+
+ indent)))
+
+
+
+(defun haskell-insert-round-paren ()
+ "Inserts a `(' and blinks to its matching parenthesis."
+ (interactive)
+ (insert last-command-char)
+ (haskell-blink-open))
+
+
+
+;;; This function is called when a close parenthesis
+;;; `)', `]', or `}' is typed.
+;;; Blinks the cursor on the corresponding open parnethesis.
+;;; The point lies just after the close parenthesis.
+
+(defun haskell-blink-open ()
+ "Blinks the cursor to the matching open parenthesis.
+The point lies just after a parenthesis."
+ (let ((state (parse-partial-sexp (point)
+ (save-excursion
+ (haskell-back-to-zero-indent)
+ (point)))))
+ (if (and
+ (>= (car state) 0)
+ (not (or (nth 3 state) (nth 4 state))))
+ ;;The parenthesis just inserted has a match
+ ;; and is not in a string or a comment
+ ;; so blink on its match
+ (save-excursion
+ (goto-char (nth 2 state))
+ (sit-for 1)))))
+
+
+
+;;; This function indents the line expecting the line to be a
+;;; continued function application.
+
+;;; foo a = bar a
+;;; b {haskell-further-indent applied to this line
+;;; indents the line as shown}
+
+;;; The line would look like this if only tab had been applied:
+;;; foo a = bar a
+;;; b
+
+(defun haskell-further-indent ()
+ "Indents the line more than the ordinary indentation in order to
+extend function arguments over multiple lines."
+ (interactive)
+ (let (indent
+ (new-point (max (save-excursion
+ (haskell-back-to-symbol "=")
+ (point))
+ (save-excursion
+ (haskell-back-to-keyword)
+ (point)))))
+ (save-excursion
+ ;;This may be a continuation of a function
+ ;; application so go back to the last '='
+ ;; and set indent as designated by the style chosen
+ (goto-char new-point)
+ (skip-chars-forward "= \t")
+ (setq indent (haskell-list-align (haskell-eol))))
+ ;;The argument to haskell-list-align is not important here.
+ (save-excursion
+ (beginning-of-line)
+ (delete-horizontal-space)
+ (indent-to indent))
+ (if (< (current-column) indent)
+ (move-to-column indent))))
+
+
+;;; This function indents the current line to the first previous
+;;; indentation value which is less than the current indentation.
+
+(defun haskell-lesser-indent ()
+ "Indents the current line to the first previous indentation
+value which is less than the current indentation."
+ (interactive)
+ (let ((original-indent
+ (current-indentation))
+ (indent (haskell-context-indent))
+ (done nil))
+ (save-excursion
+ (while (not done)
+ (while (and (not (bobp))
+ (not (zerop (current-indentation)))
+ (>= indent original-indent))
+ (haskell-backward-to-noncomment)
+ (setq indent (current-indentation)))
+ ;;bobp or indent < original-indent
+ (if (>= indent original-indent)
+ ;;indent is still greater than or equal to original indent
+ (progn
+ (setq indent 0)
+ (setq done t))
+ ;;Otherwise, indent is less than orignal indent.
+ (forward-line 1)
+ (setq indent (haskell-context-indent))
+ (if (< indent original-indent)
+ ;;The new indent is an improvement
+ (setq done t)
+ ;;Otherwise, indent is still >= original
+ ;; so go back to the line and keep typing.
+ (forward-line -1)))))
+ (save-excursion
+ (beginning-of-line)
+ (delete-horizontal-space)
+ (indent-to indent))
+ (if (< (current-column) indent)
+ (move-to-column indent))))
+
+
+
+;;; Here are the functions which change the local variables
+;;; to facilitate tailorability.
+
+(defun default-mode ()
+ "Calls the function haskell-mode."
+ (interactive)
+ (haskell-mode)
+ (message haskell-indent-style))
+
+(defun wadler-mode ()
+ "Sets defaults according to Dr. Philip L. Wadler's preferences.
+ - Aligns `where' clauses with the corresponding equality.
+ - Aligns `else' keyword with the corresponding `then'
+ - haskell-list-offset 2
+ - haskell-indent-offset 8
+ - haskell-if-indent 2
+ - haskell-comment-column 0
+ - haskell-case-offset 2
+ - haskell-let-offset 5."
+ ;;Preferences:
+ ;;'haskell-align-where-with-eq non-nil
+ ;;'haskell-list-offset 2
+ (interactive)
+ (haskell-mode)
+ (or haskell-align-where-with-eq
+ (progn
+ (setq haskell-align-where-with-eq t)
+ (setq haskell-std-indent-where nil)))
+ (setq haskell-align-else-with-then t)
+ (setq haskell-list-offset 2)
+ (setq haskell-indent-offset 8)
+ (setq haskell-if-offset 2)
+ (setq haskell-case-offset 2)
+ (setq haskell-let-offset 5)
+ (setq haskell-comment-column 0)
+ (setq haskell-indent-style "Wadler")
+ (message haskell-indent-style))
+
+
+(defun report-mode ()
+ "Sets defaults according to the style of the Haskell Report.
+ - Aligns `where' clauses after the corresponding equality.
+ - Aligns `else' with `then'.
+ - haskell-then-offset = 3
+ - haskell-where-offset = 0.
+ - haskell-case-offset = 5."
+ ;;Preferences:
+ ;; haskell-align-where-after-eq non-nil
+ ;; haskell-then-offset 3
+ ;; haskell-where-offset 0
+ ;; haskell-case-offset 5
+ (interactive)
+ (haskell-mode)
+ (haskell-align-where-after-eq)
+ (or haskell-align-else-with-then
+ (haskell-align-else-with-then))
+ (setq haskell-then-offset 3)
+ (setq haskell-where-offset 0)
+ (setq haskell-case-offset 5)
+ (setq haskell-indent-style "Report")
+ (message haskell-indent-style))
+
+
+(defun haskell-align-where-with-eq ()
+ "Sets indentation so that a 'where' clause lines up underneath
+its corresponding equals sign."
+ (interactive)
+ (or haskell-align-where-with-eq
+ (progn
+ (setq haskell-align-where-after-eq nil)
+ (setq haskell-std-indent-where nil)
+ (setq haskell-align-where-with-eq t)
+ haskell-align-where-with-eq)))
+
+
+
+(defun haskell-align-where-after-eq ()
+ "Sets indentation so that a 'where' clause lines up underneath
+the first nonspace character after its corresponding equals sign."
+ (interactive)
+ (or haskell-align-where-after-eq
+ (progn
+ (setq haskell-align-where-with-eq nil)
+ (setq haskell-std-indent-where nil)
+ (setq haskell-align-where-after-eq t)
+ haskell-align-where-after-eq)))
+
+
+(defun haskell-std-indent-where ()
+ "Sets indentation so that a `where' clause lines up underneath
+its corresponding equals sign."
+ (interactive)
+ (or haskell-std-indent-where
+ (progn
+ (setq haskell-align-where-after-eq nil)
+ (setq haskell-align-where-with-eq nil)
+ (setq haskell-std-indent-where t)
+ haskell-std-indent-where)))
+
+
+(defun haskell-align-else-with-then ()
+ "Sets indentation so that an `else' lines up underneath
+it's corresponding `then'."
+ (interactive)
+ (setq haskell-align-else-with-then
+ (not haskell-align-else-with-then))
+ (setq haskell-nest-ifs nil))
+
+(defun haskell-nest-ifs ()
+ "Sets indentation so that an `if' is lined up
+under an `if' in an `else ."
+ (interactive)
+ (setq haskell-nest-ifs
+ (not haskell-nest-ifs))
+ (setq haskell-align-else-with-then nil))
+
+
+(defun haskell-always-fixup-comment-space ()
+ "Non-nil means always position one space after a line comment `--',
+when reindenting or inserting a comment,
+whether or not one space exists."
+ (setq haskell-always-fixup-comment-space
+ (not haskell-always-fixup-comment-space))
+ haskell-always-fixup-comment-space)
+
+(defun haskell-indent-style ()
+ "Echos the chosen indentation style in the mini-buffer."
+ (interactive)
+ (message haskell-indent-style))
+
+(defun set-haskell-let-offset (offset)
+ "Changes the value of haskell-let-offset, the variable which
+determines extra indentation after a `let' and `in'."
+ (interactive "nSet haskell-let-offset to: ")
+ (if (and (>= offset 0) (<= offset 10))
+ (setq haskell-let-offset offset)))
+
+(defun set-haskell-if-offset (offset)
+ "Changes the value of haskell-let-offset, the variable which
+determines extra indentation after an `if', `then' and `else'."
+ (interactive "nSet haskell-if-offset to: ")
+ (if (and (>= offset 0) (<= offset 10))
+ (setq haskell-if-offset offset)))
+
+(defun set-haskell-case-offset (offset)
+ "Changes the value of haskell-case-offset, the variable which
+determines extra indentation after a `case' and `of'."
+ (interactive "nSet haskell-case-offset to: ")
+ (if (and (>= offset 0) (<= offset 10))
+ (setq haskell-case-offset offset)))
+
+
+(defun set-haskell-where-offset (offset)
+ "Changes the value of haskell-where-offset, the variable which
+determines extra indentation after a line of haskell code."
+ (interactive "nSet haskell-where-offset to: ")
+ (if (and (>= offset 0) (<= offset 10))
+ (setq haskell-where-offset offset)))
+
+
+(defun set-haskell-indent-offset (offset)
+ "Changes the value of haskell-indent-offset, the variable which
+determines extra indentation after a line of haskell code."
+ (interactive "nSet haskell-indent-offset to: ")
+ (if (and (>= offset 1) (<= offset 10))
+ (setq haskell-indent-offset offset)))
+
+
+(defun set-haskell-list-offset (offset)
+ "Changes the value of haskell-list-offset, the variable which
+determines extra indentation after a line of haskell code for a list."
+ (interactive "nSet haskell-list-offset to: ")
+ (if (and (>= offset 0) (<= offset 10))
+ (setq haskell-list-offset offset)))
+
+
+(defun set-haskell-comp-offset (offset)
+ "Changes the value of haskell-comp-offset, the variable which
+determines extra indentation after a list comprehension."
+ (interactive "nSet haskell-comp-offset to: ")
+ (if (and (>= offset 0) (<= offset 10))
+ (setq haskell-comp-offset offset)))
+
+
+(defun set-haskell-then-offset (offset)
+ "Changes the value of haskell-then-offset, the variable which
+determines extra indentation for a `then' keyword after an `if'."
+ (interactive "nSet haskell-then-offset to: ")
+ (if (and (>= offset 0) (<= offset 10))
+ (setq haskell-then-offset offset)))
+
+
+(defun set-haskell-comment-column (column)
+ "Changes the value of haskell-comment-column, the variable which
+determines where to postition a line comment `--'."
+ (interactive "nSet haskell-comment-column to: ")
+ (if (and (>= column 0) (<= column 100))
+ (setq haskell-comment-column column)))
+
+(defun set-haskell-concat-column (column)
+ "Changes the value of haskell-concat-column, the variable which
+determines where to postition a concatenation operator `++'."
+ (interactive "nSet haskell-concat-column to: ")
+ (if (and (>= column 0) (<= column 100))
+ (setq haskell-concat-column column)))
+
+(defun set-haskell-where-threshold (column)
+ "Changes the value of haskell-where-threshold, the variable which
+determines when to override positioning a `where' under or after
+its corresponding equality."
+ (interactive "nSet haskell-where-threshold to: ")
+ (if (and (>= column 0) (<= column 100))
+ (setq haskell-where-threshold column)))
+
+(defun flag ())
\ No newline at end of file
--- /dev/null
+;;; Haskell mode for emacs (c) Simon Marlow 11/1/92
+
+(defvar haskell-mode-map ()
+ "Keymap used in Haskell mode.")
+
+(defvar haskell-literate-mode-map ()
+ "Keymap used in Haskell literate script mode.")
+
+(defvar haskell-mode-syntax-table ()
+ "Syntax table for haskell mode.")
+
+(if haskell-mode-map
+ ()
+ (setq haskell-mode-map (make-sparse-keymap))
+ (define-key haskell-mode-map "\C-j" 'haskell-newline-and-indent))
+
+(if haskell-literate-mode-map
+ ()
+ (setq haskell-literate-mode-map (make-sparse-keymap))
+ (define-key haskell-literate-mode-map "\C-j"
+ 'haskell-literate-newline-and-indent)
+ (define-key haskell-literate-mode-map "\M-\C-i"
+ 'haskell-literate-toggle-bird-track-line)
+ (define-key haskell-literate-mode-map "\M-m"
+ 'haskell-literate-back-to-indentation))
+
+
+(if haskell-mode-syntax-table
+ ()
+ (let ((i 0))
+ (setq haskell-mode-syntax-table (make-syntax-table))
+; (while (< i ?0)
+; (modify-syntax-entry i "." haskell-mode-syntax-table)
+; (setq i (1+ i)))
+; (while (< i (1+ ?9))
+; (modify-syntax-entry i "_" haskell-mode-syntax-table)
+; (setq i (1+ i)))
+; (while (< i ?A)
+; (modify-syntax-entry i "." haskell-mode-syntax-table)
+; (setq i (1+ i)))
+; (while (< i (1+ ?Z))
+; (modify-syntax-entry i "w" haskell-mode-syntax-table)
+; (setq i (1+ i)))
+; (while (< i ?a)
+; (modify-syntax-entry i "." haskell-mode-syntax-table)
+; (setq i (1+ i)))
+; (while (< i (1+ ?z))
+; (modify-syntax-entry i "w" haskell-mode-syntax-table)
+; (setq i (1+ i)))
+; (while (< i 128)
+; (modify-syntax-entry i "." haskell-mode-syntax-table)
+; (setq i (1+ i)))
+ (modify-syntax-entry ? " " haskell-mode-syntax-table)
+ (modify-syntax-entry ?\t " " haskell-mode-syntax-table)
+ (modify-syntax-entry ?\f "> b" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\n "> b" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\" "\"" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\' "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?_ "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\\ "." haskell-mode-syntax-table)
+ (modify-syntax-entry ?\( "()" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\) ")(" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\[ "(]" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\] ")[" haskell-mode-syntax-table)
+ (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table)
+ (modify-syntax-entry ?} "){4" haskell-mode-syntax-table)
+ (modify-syntax-entry ?- ". 12b" haskell-mode-syntax-table)
+ ))
+
+(defun haskell-vars ()
+ (kill-all-local-variables)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^$\\|" page-delimiter))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+ (make-local-variable 'comment-start)
+ (setq comment-start "--")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "--[^a-zA-Z0-9]*")
+ (make-local-variable 'comment-column)
+ (setq comment-column 40)
+ (make-local-variable 'comment-indent-function)
+ (setq comment-indent-function 'haskell-comment-indent)
+ ;(make-local-variable 'font-lock-keywords)
+ ;(setq font-lock-keywords haskell-literate-font-lock-keywords)
+ )
+
+(defun haskell-mode ()
+ "Major mode for editing Haskell programs.
+Blank lines separate paragraphs, Comments start with '--'.
+Use Linefeed to do a newline and indent to the level of the previous line.
+Tab simply inserts a TAB character.
+Entry to this mode calls the value of haskell-mode-hook if non-nil."
+ (interactive)
+ (haskell-vars)
+ (setq major-mode 'haskell-mode)
+ (setq mode-name "Haskell")
+ (use-local-map haskell-mode-map)
+ (set-syntax-table haskell-mode-syntax-table)
+ (run-hooks 'haskell-mode-hook))
+
+(defun haskell-literate-mode ()
+ "Major mode for editing haskell programs in literate script form.
+Linefeed produces a newline, indented maybe with a bird track on it.
+M-TAB toggles the state of the bird track on the current-line.
+Entry to this mode calls haskell-mode-hook and haskell-literate-mode-hook."
+ (interactive)
+ (haskell-vars)
+ (setq major-mode 'haskell-literate-mode)
+ (setq mode-name "Literate Haskell")
+ (use-local-map haskell-literate-mode-map)
+ (set-syntax-table haskell-mode-syntax-table)
+ (run-hooks 'haskell-mode-hook)
+ (run-hooks 'haskell-literate-mode-hook))
+
+;; Find the indentation level for a comment..
+(defun haskell-comment-indent ()
+ (skip-chars-backward " \t")
+ ;; if the line is blank, put the comment at the beginning,
+ ;; else at comment-column
+ (if (bolp) 0 (max (1+ (current-column)) comment-column)))
+
+;; Newline, and indent according to the previous line's indentation.
+;; Don't forget to use 'indent-tabs-mode' if you require tabs to be used
+;; for indentation.
+(defun haskell-newline-and-indent ()
+ (interactive)
+ (newline)
+ (let ((c 0))
+ (save-excursion
+ (forward-line -1)
+ (back-to-indentation)
+ (setq c (if (eolp) 0 (current-column))))
+ (indent-to c))) ;ident new line to this level
+
+;;; Functions for literate scripts
+
+;; Newline and maybe add a bird track, indent
+(defun haskell-literate-newline-and-indent ()
+ (interactive)
+ (newline)
+ (let ((bird-track nil) (indent-column 0))
+ (save-excursion
+ (forward-line -1)
+ (if (= (following-char) ?>) (setq bird-track t))
+ (skip-chars-forward "^ \t")
+ (skip-chars-forward " \t")
+ (setq indent-column (if (eolp) 0 (current-column))))
+ (if bird-track (insert-char ?> 1))
+ (indent-to indent-column)))
+
+;; Toggle bird-track ][
+(defun haskell-literate-toggle-bird-track-line ()
+ (interactive)
+ (save-excursion
+ (beginning-of-line)
+ (if (= (following-char) ? )
+ (progn (delete-char 1) (insert-char ?> 1))
+ (if (= (following-char) ?>)
+ (progn (delete-char 1) (insert-char ? 1))
+ (progn (insert-char ?> 1) (insert-char ? 1))))))
+
+(defun haskell-literate-toggle-bird-track-region (start end)
+ (interactive "r")
+ (save-excursion
+ (goto-char start)
+ (while (<= (point) end)
+ (beginning-of-line)
+ (haskell-literate-toggle-bird-track-line)
+ (forward-line 1))))
+
+(defun haskell-literate-back-to-indentation ()
+ (interactive)
+ (beginning-of-line)
+ (if (= (following-char) ?>)
+ (forward-char 1))
+ (skip-chars-forward " \t"))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; keywords for jwz's font-look-mode (lemacs 19)
+;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar haskell-literate-font-lock-keywords ()
+ "Font definitions for Literate Haskell files.")
+
+(setq haskell-literate-font-lock-keywords
+ (list
+ '("^[^>\n].*$" . font-lock-comment-face)
+ (concat "\\b\\("
+ (mapconcat 'identity
+ '("case" "class" "data" "default" "deriving" "else" "hiding"
+ "if" "import" "in" "infix" "infixl" "infixr" "instance"
+ "interface" "let" "module" "of" "renaming" "then" "to"
+ "type" "where")
+ "\\|")
+ "\\)\\b")
+ ))
+
--- /dev/null
+;;; ==================================================================
+;;; File: haskell.el ;;;
+;;; ;;;
+;;; Author: A. Satish Pai ;;;
+;;; Maria M. Gutierrez ;;;
+;;; Dan Rabin (Jul-1991) ;;;
+;;; ==================================================================
+;;; Time-stamp: <Sat Oct 7 1995 17:48:39 Stardate: [-31]6403.50 hwloidl>
+;;; ==================================================================
+;;;
+;;; extended by Manuel M.T. Chakravarty with rudimentary editing features
+;;; (including better syntax table) and support for the font-lock-mode;
+;;; changes are marked with !chak!
+;;;
+;;; using this mode on a 19.x Emacs running under a window system automagically
+;;; applies the font-lock-mode; this feature can be switched off by setting
+;;; `haskell-auto-font-lock' to `nil'
+
+;;; Description: Haskell mode for GNU Emacs.
+
+;;; Related files: comint.el
+
+;;; Contents:
+
+;;; Update Log
+
+;;; Known bugs / problems
+;;; - the haskell editing mode (indentation, etc) is still missing.
+;;; - the handling for errors from haskell needs to be rethought.
+;;; - general cleanup of code.
+
+
+;;; Errors generated
+
+;;; ==================================================================
+;;; Haskell mode for editing files, and an Inferior Haskell mode to
+;;; run a Haskell process. This file contains stuff snarfed and
+;;; modified from tea.el, scheme.el, etc. This file may be freely
+;;; modified; however, if you have any bug-corrections or useful
+;;; improvements, I'd appreciate it if you sent me the mods so that
+;;; I can merge them into the version I maintain.
+;;;
+;;; The inferior Haskell mode requires comint.el.
+;;;
+;;; You might want to add this to your .emacs to go automagically
+;;; into Haskell mode while finding .hs files.
+;;;
+;;; (setq auto-mode-alist
+;;; (cons '("\\.hs$" . haskell-mode)
+;;; auto-mode-alist)_)
+;;;
+;;; To use this file, set up your .emacs to autoload this file for
+;;; haskell-mode. For example:
+;;;
+;;; (autoload 'haskell-mode "$HASKELL/emacs-tools/haskell.elc"
+;;; "Load Haskell mode" t)
+;;;
+;;; (autoload 'run-mode "$HASKELL/emacs-tools/haskell.elc"
+;;; "Load Haskell mode" t)
+;;;
+;;; [Note: The path name given above is Yale specific!! Modify as
+;;; required.]
+;;; ================================================================
+
+;;; Announce your existence to the world at large.
+
+(provide 'haskell)
+
+
+;;; Load these other files.
+
+(require 'comint) ; Olin Shivers' comint mode is the substratum
+
+;;; !chak!
+;;;
+(if (and window-system (string-match "19." emacs-version))
+ (require 'font-lock))
+
+
+\f
+;;; ================================================================
+;;; Declare a bunch of variables.
+;;; ================================================================
+
+
+;;; User settable (via M-x set-variable and M-x edit-options)
+
+(defvar haskell-program-name (getenv "HASKELLPROG")
+ "*Program invoked by the haskell command.")
+
+(defvar haskell-auto-create-process t
+ "*If not nil, create a Haskell process automatically when required to evaluate or compile Haskell code.")
+
+(defvar haskell-auto-switch-input t
+ "*If not nil, jump to *haskell* buffer automatically on input request.")
+
+(defvar haskell-ask-before-saving t
+ "*If not nil, ask before saving random haskell-mode buffers.")
+
+(defvar haskell-initial-printers '("interactive")
+ "*Printers to set when starting a new Haskell process.")
+
+
+;;; Pad/buffer Initialization variables
+
+(defvar *haskell-buffer* "*haskell*"
+ "Name of the haskell process buffer")
+
+(defvar haskell-main-pad "\*Main-pad\*"
+ "Scratch pad associated with module Main")
+
+(defvar haskell-main-module "Main")
+
+
+(defvar *last-loaded* nil)
+(defvar *last-module* haskell-main-module)
+(defvar *last-pad* haskell-main-pad)
+
+
+;;; These are used for haskell-tutorial mode.
+
+(defvar *ht-source-file* "$HASKELL/progs/tutorial/tutorial.lhs")
+(defvar *ht-temp-buffer* nil)
+(defvar *ht-file-buffer* "Haskell-Tutorial-Master")
+
+;;; !chak! variables for font-lock-mode support
+;;;
+
+(defvar haskell-auto-font-lock t
+ "Use font-lock-mode by default.")
+
+(defvar haskell-font-lock-keywords
+ (list
+ "\\bcase\\b" "\\bclass\\b" "\\bdata\\b" "\\bdefault\\b" "\\bderiving\\b"
+ "\\belse\\b" "\\bhiding\\b" "\\bif\\b" "\\bimport\\b" "\\bin\\b"
+ "\\binfix\\b" "\\binfixl\\b" "\\binfixr\\b" "\\binstance\\b"
+ "\\binterface\\b" "\\blet\\b" "\\bmodule\\b" "\\bof\\b" "\\brenaming\\b"
+ "\\bthen\\b" "\\bto\\b" "\\btype\\b" "\\bwhere\\b"
+ ;'("\\S_\\(\\.\\.\\|::\\|=>\\|=\\|@\\||\\|~\\|-\\|<-\\|->\\)\\S_" . 1)
+ '("\\bdata\\b\\s *\\(\\w+\\)\\(\\w\\|\\s \\)*=[^>]" 1 font-lock-type-face)
+ '("\\bdata\\b\\(\\s \\|(\\|)\\|\\w\\)*=>\\s *\n?\\s *\\(\\w+\\)" 2
+ font-lock-type-face)
+ '("\\btype\\b\\s *\\(\\w+\\)" 1 font-lock-type-face)
+ '("\\(\\w+\\)\\s *::\\(\\s \\|$\\)" 1 font-lock-function-name-face)
+ '("(\\(\\s_+\\))\\s *::\\(\\s \\|$\\)" 1 font-lock-function-name-face)
+; '("\\($\\|[^\\\\]\\)\\('[^\\\\]'\\)" 2 font-lock-string-face t)
+ '("\\('\\([^\\\\]\\|\\\\'\\)'\\)" 1 font-lock-string-face t)
+ )
+ "Additional expressions to highlight in Haskell mode.")
+
+
+\f
+;;; ================================================================
+;;; Haskell editing mode stuff
+;;; ================================================================
+
+;;; Leave this place alone...
+;;; The definitions below have been pared down to the bare
+;;; minimum; they will be restored later.
+;;;
+;;; -Satish 2/5.
+
+;;; Keymap for Haskell mode
+(defvar haskell-mode-map (make-sparse-keymap)
+ "Keymap used for haskell-mode")
+
+(defun haskell-establish-key-bindings (keymap)
+ (define-key keymap "\C-ce" 'haskell-eval)
+ (define-key keymap "\C-cr" 'haskell-run)
+ (define-key keymap "\C-ct" 'haskell-report-type)
+ (define-key keymap "\C-cm" 'haskell-run-main)
+ (define-key keymap "\C-c\C-r" 'haskell-run-file)
+ (define-key keymap "\C-cp" 'haskell-get-pad)
+ (define-key keymap "\C-c\C-o" 'haskell-optimizers)
+ (define-key keymap "\C-c\C-p" 'haskell-printers)
+ (define-key keymap "\C-cc" 'haskell-compile)
+ (define-key keymap "\C-cl" 'haskell-load)
+ (define-key keymap "\C-ch" 'haskell-switch)
+ (define-key keymap "\C-c\C-k" 'haskell-kill)
+ (define-key keymap "\C-c:" 'haskell-command)
+ (define-key keymap "\C-cq" 'haskell-exit)
+ (define-key keymap "\C-ci" 'haskell-interrupt)
+ (define-key keymap "\C-cu" 'haskell-edit-unit))
+
+
+(haskell-establish-key-bindings haskell-mode-map)
+
+
+(defvar haskell-mode-syntax-table nil
+ "Syntax table used for haskell-mode")
+
+;; !chak! taken from lisp-mode
+;;
+(defvar haskell-mode-abbrev-table nil
+ "Abbrev table used for the haskell-mode")
+
+;; !chak! took syntax table from haskell mode distributed with GHC and modified
+;; it; we treat numbers as parts of words and operators as elements of
+;; the syntactic class `_'
+;;
+(if haskell-mode-syntax-table
+ ()
+ (let ((i 0))
+ (setq haskell-mode-syntax-table (make-syntax-table))
+ (while (< i ?0)
+ (modify-syntax-entry i "." haskell-mode-syntax-table)
+ (setq i (1+ i)))
+ (while (< i (1+ ?9))
+ (modify-syntax-entry i "w" haskell-mode-syntax-table)
+ (setq i (1+ i)))
+ (while (< i ?A)
+ (modify-syntax-entry i "." haskell-mode-syntax-table)
+ (setq i (1+ i)))
+ (while (< i (1+ ?Z))
+ (modify-syntax-entry i "w" haskell-mode-syntax-table)
+ (setq i (1+ i)))
+ (while (< i ?a)
+ (modify-syntax-entry i "." haskell-mode-syntax-table)
+ (setq i (1+ i)))
+ (while (< i (1+ ?z))
+ (modify-syntax-entry i "w" haskell-mode-syntax-table)
+ (setq i (1+ i)))
+ (while (< i 128)
+ (modify-syntax-entry i "." haskell-mode-syntax-table)
+ (setq i (1+ i)))
+ (modify-syntax-entry ? " " haskell-mode-syntax-table)
+ (modify-syntax-entry ?\t " " haskell-mode-syntax-table)
+ (modify-syntax-entry ?\n ">" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\f ">" haskell-mode-syntax-table)
+ (modify-syntax-entry ?! "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?# "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?$ "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?% "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?& "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?* "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?+ "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?. "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?/ "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?< "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?= "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?> "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?? "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?@ "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?^ "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?| "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?~ "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\" "\"" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\' "w" haskell-mode-syntax-table)
+ (modify-syntax-entry ?_ "w" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\\ "_" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\( "()" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\) ")(" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\[ "(]" haskell-mode-syntax-table)
+ (modify-syntax-entry ?\] ")[" haskell-mode-syntax-table)
+ (modify-syntax-entry ?{ "(}1" haskell-mode-syntax-table)
+ (modify-syntax-entry ?} "){4" haskell-mode-syntax-table)
+ (modify-syntax-entry ?- "_ 123" haskell-mode-syntax-table)
+ ))
+
+;; !chak! taken from lisp-mode
+;;
+(define-abbrev-table 'haskell-mode-abbrev-table ())
+
+;; !chak! adapted from lisp-mode
+;;
+(defun haskell-mode-variables (haskell-syntax)
+ (cond (haskell-syntax
+ (set-syntax-table haskell-mode-syntax-table)))
+ (setq local-abbrev-table haskell-mode-abbrev-table)
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat "^$\\|" page-delimiter))
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+ (make-local-variable 'paragraph-ignore-fill-prefix)
+ (setq paragraph-ignore-fill-prefix t)
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'haskell-indent-line)
+; (make-local-variable 'indent-region-function)
+; (setq indent-region-function 'haskell-indent-region)
+ (make-local-variable 'parse-sexp-ignore-comments)
+ (setq parse-sexp-ignore-comments t)
+; (make-local-variable 'outline-regexp)
+; (setq outline-regexp ";;; \\|(....")
+ (make-local-variable 'comment-start)
+ (setq comment-start "--")
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip "-- *")
+ (make-local-variable 'comment-column)
+ (setq comment-column 40)
+; (make-local-variable 'comment-indent-function)
+; (setq comment-indent-function 'haskell-comment-indent)
+ (make-local-variable 'font-lock-keywords)
+ (setq font-lock-keywords haskell-font-lock-keywords)
+ )
+
+;; !chak!
+;;
+(defun haskell-indent-line ()
+ "Simple indentation function using `indent-relative'."
+ (interactive)
+ (save-excursion
+ (beginning-of-line)
+ (delete-horizontal-space)
+ (indent-relative)
+ )
+ )
+
+;;; Command for invoking the Haskell mode
+(defun haskell-mode nil
+ "Major mode for editing Haskell code to run in Emacs
+The following commands are available:
+\\{haskell-mode-map}
+
+A Haskell process can be fired up with \"M-x haskell\".
+
+Customization: Entry to this mode runs the hooks that are the value of variable
+haskell-mode-hook.
+
+Windows:
+
+There are 3 types of windows associated with Haskell mode. They are:
+ *haskell*: which is the process window.
+ Pad: which are buffers available for each module. It is here
+ where you want to test things before preserving them in a
+ file. Pads are always associated with a module.
+ When issuing a command:
+ The pad and its associated module are sent to the Haskell
+ process prior to the execution of the command.
+ .hs: These are the files where Haskell programs live. They
+ have .hs as extension.
+ When issuing a command:
+ The file is sent to the Haskell process prior to the
+ execution of the command.
+
+Commands:
+
+Each command behaves differently according to the type of the window in which
+the cursor is positioned when the command is issued .
+
+haskell-eval: \\[haskell-eval]
+ Always promts user for a Haskell expression to be evaluated. If in a
+ .hs file buffer, then the cursor tells which module is the current
+ module and the pad for that module (if any) gets loaded as well.
+
+haskell-run: \\[haskell-run]
+ Always queries for a variable of type Dialogue to be evaluated.
+
+haskell-run-main: \\[haskell-run-main]
+ Run Dialogue named main in the current module.
+
+haskell-report-type: \\[haskell-report-type]
+ Like haskell-eval, but prints the type of the expression without
+ evaluating it.
+
+haskell-mode: \\[haskell-mode]
+ Puts the current buffer in haskell mode.
+
+haskell-compile: \\[haskell-compile]
+ Compiles file in current buffer.
+
+haskell-load: \\[haskell-load]
+ Loads file in current buffer.
+
+haskell-run-file: \\[haskell-run-file]
+ Runs file in the current buffer.
+
+haskell-pad: \\[haskell-pad]
+ Creates a scratch pad for the current module.
+
+haskell-optimizers: \\[haskell-optimizers]
+ Shows the list of available optimizers. Commands for turning them on/off.
+
+haskell-printers: \\[haskell-printers]
+ Shows the list of available printers. Commands for turning them on/off.
+
+haskell-command: \\[haskell-command]
+ Prompts for a command to be sent to the command interface. You don't
+ need to put the : before the command.
+
+haskell-quit: \\[haskell-quit]
+ Terminates the haskell process.
+
+haskell-switch: \\[haskell-switch]
+ Switches to the inferior Haskell buffer (*haskell*) and positions the
+ cursor at the end of the buffer.
+
+haskell-kill: \\[haskell-kill]
+ Kill the current contents of the *haskell* buffer.
+
+haskell-interrupt: \\[haskell-interrupt]
+ Interrupts haskell process and resets it.
+
+haskell-edit-unit: \\[haskell-edit-unit]
+ Edit the .hu file for the unit containing this file.
+"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map haskell-mode-map)
+ (setq major-mode 'haskell-mode)
+ (setq mode-name "Haskell")
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'indent-relative-maybe)
+ ;(setq local-abbrev-table haskell-mode-abbrev-table)
+ (set-syntax-table haskell-mode-syntax-table)
+ ;(setq tab-stop-list haskell-tab-stop-list) ;; save old list??
+ (haskell-mode-variables t) ; !chak!
+ (cond (haskell-auto-font-lock ; !chak!
+ (font-lock-mode 1) ; !chak!
+ )) ; !chak!
+ (run-hooks 'haskell-mode-hook))
+
+
+\f
+;;;================================================================
+;;; Inferior Haskell stuff
+;;;================================================================
+
+
+(defvar inferior-haskell-mode-map (copy-keymap comint-mode-map))
+
+(haskell-establish-key-bindings inferior-haskell-mode-map)
+(define-key inferior-haskell-mode-map "\C-m" 'haskell-send-input)
+
+(defvar haskell-source-modes '(haskell-mode)
+ "*Used to determine if a buffer contains Haskell source code.
+If it's loaded into a buffer that is in one of these major modes,
+it's considered a Haskell source file.")
+
+(defvar haskell-prompt-pattern "^[A-Z]\\([A-Z]\\|[a-z]\\|[0-9]\\)*>\\s-*"
+ "Regular expression capturing the Haskell system prompt.")
+
+(defvar haskell-prompt-ring ()
+ "Keeps track of input to haskell process from the minibuffer")
+
+(defun inferior-haskell-mode-variables ()
+ nil)
+
+
+;;; INFERIOR-HASKELL-MODE (adapted from comint.el)
+
+(defun inferior-haskell-mode ()
+ "Major mode for interacting with an inferior Haskell process.
+
+The following commands are available:
+\\{inferior-haskell-mode-map}
+
+A Haskell process can be fired up with \"M-x haskell\".
+
+Customization: Entry to this mode runs the hooks on comint-mode-hook and
+inferior-haskell-mode-hook (in that order).
+
+You can send text to the inferior Haskell process from other buffers containing
+Haskell source.
+
+
+Windows:
+
+There are 3 types of windows in the inferior-haskell-mode. They are:
+ *haskell*: which is the process window.
+ Pad: which are buffers available for each module. It is here
+ where you want to test things before preserving them in a
+ file. Pads are always associated with a module.
+ When issuing a command:
+ The pad and its associated module are sent to the Haskell
+ process prior to the execution of the command.
+ .hs: These are the files where Haskell programs live. They
+ have .hs as extension.
+ When issuing a command:
+ The file is sent to the Haskell process prior to the
+ execution of the command.
+
+Commands:
+
+Each command behaves differently according to the type of the window in which
+the cursor is positioned when the command is issued.
+
+haskell-eval: \\[haskell-eval]
+ Always promts user for a Haskell expression to be evaluated. If in a
+ .hs file, then the cursor tells which module is the current module and
+ the pad for that module (if any) gets loaded as well.
+
+haskell-run: \\[haskell-run]
+ Always queries for a variable of type Dialogue to be evaluated.
+
+haskell-run-main: \\[haskell-run-main]
+ Run Dialogue named main.
+
+haskell-report-type: \\[haskell-report-type]
+ Like haskell-eval, but prints the type of the expression without
+ evaluating it.
+
+haskell-mode: \\[haskell-mode]
+ Puts the current buffer in haskell mode.
+
+haskell-compile: \\[haskell-compile]
+ Compiles file in current buffer.
+
+haskell-load: \\[haskell-load]
+ Loads file in current buffer.
+
+haskell-run-file: \\[haskell-run-file]
+ Runs file in the current buffer.
+
+haskell-pad: \\[haskell-pad]
+ Creates a scratch pad for the current module.
+
+haskell-optimizers: \\[haskell-optimizers]
+ Shows the list of available optimizers. Commands for turning them on/off.
+
+haskell-printers: \\[haskell-printers]
+ Shows the list of available printers. Commands for turning them on/off.
+
+haskell-command: \\[haskell-command]
+ Prompts for a command to be sent to the command interface. You don't
+ need to put the : before the command.
+
+haskell-quit: \\[haskell-quit]
+ Terminates the haskell process.
+
+haskell-switch: \\[haskell-switch]
+ Switches to the inferior Haskell buffer (*haskell*) and positions the
+ cursor at the end of the buffer.
+
+haskell-kill: \\[haskell-kill]
+ Kill the current contents of the *haskell* buffer.
+
+haskell-interrupt: \\[haskell-interrupt]
+ Interrupts haskell process and resets it.
+
+haskell-edit-unit: \\[haskell-edit-unit]
+ Edit the .hu file for the unit containing this file.
+
+The usual comint functions are also available. In particular, the
+following are all available:
+
+comint-bol: Beginning of line, but skip prompt. Bound to C-a by default.
+comint-delchar-or-maybe-eof: Delete char, unless at end of buffer, in
+ which case send EOF to process. Bound to C-d by default.
+
+Note however, that the default keymap bindings provided shadow some of
+the default comint mode bindings, so that you may want to bind them
+to your choice of keys.
+
+Comint mode's dynamic completion of filenames in the buffer is available.
+(Q.v. comint-dynamic-complete, comint-dynamic-list-completions.)
+
+If you accidentally suspend your process, use \\[comint-continue-subjob]
+to continue it."
+
+ (interactive)
+ (comint-mode)
+ (setq comint-prompt-regexp haskell-prompt-pattern)
+ ;; Customise in inferior-haskell-mode-hook
+ (inferior-haskell-mode-variables)
+ (setq major-mode 'inferior-haskell-mode)
+ (setq mode-name "Inferior Haskell")
+ (setq mode-line-process '(": %s : busy"))
+ (use-local-map inferior-haskell-mode-map)
+ (setq comint-input-filter 'haskell-input-filter)
+ (setq comint-input-sentinel 'ignore)
+ (setq comint-get-old-input 'haskell-get-old-input)
+ (run-hooks 'inferior-haskell-mode-hook)
+ ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook.
+ ;The test is so we don't lose history if we run comint-mode twice in
+ ;a buffer.
+ (setq haskell-prompt-ring (make-ring comint-input-ring-size)))
+
+
+(defun haskell-input-filter (str)
+ "Don't save whitespace."
+ (not (string-match "\\s *" str)))
+
+
+\f
+;;; ==================================================================
+;;; Random utilities
+;;; ==================================================================
+
+
+;;; This keeps track of the status of the haskell process.
+;;; Values are:
+;;; busy -- The process is busy.
+;;; ready -- The process is ready for a command.
+;;; input -- The process is waiting for input.
+;;; debug -- The process is in the debugger.
+
+(defvar *haskell-status* 'busy
+ "Status of the haskell process")
+
+(defun set-haskell-status (value)
+ (setq *haskell-status* value)
+ (haskell-update-mode-line))
+
+(defun get-haskell-status ()
+ *haskell-status*)
+
+(defun haskell-update-mode-line ()
+ (save-excursion
+ (set-buffer *haskell-buffer*)
+ (cond ((eq *haskell-status* 'ready)
+ (setq mode-line-process '(": %s: ready")))
+ ((eq *haskell-status* 'input)
+ (setq mode-line-process '(": %s: input")))
+ ((eq *haskell-status* 'busy)
+ (setq mode-line-process '(": %s: busy")))
+ ((eq *haskell-status* 'debug)
+ (setq mode-line-process '(": %s: debug")))
+ (t
+ (haskell-mode-error "Confused about status of haskell process!")))
+ ;; Yes, this is the officially sanctioned technique for forcing
+ ;; a redisplay of the mode line.
+ (set-buffer-modified-p (buffer-modified-p))))
+
+
+(defun haskell-send-to-process (string)
+ (process-send-string "haskell" string)
+ (process-send-string "haskell" "\n"))
+
+
+\f
+;;; ==================================================================
+;;; Handle input in haskell process buffer; history commands.
+;;; ==================================================================
+
+(defun haskell-get-old-input ()
+ "Get old input text from Haskell process buffer."
+ (save-excursion
+ (if (re-search-forward haskell-prompt-pattern (point-max) 'move)
+ (goto-char (match-beginning 0)))
+ (cond ((re-search-backward haskell-prompt-pattern (point-min) t)
+ (comint-skip-prompt)
+ (let ((temp (point)))
+ (end-of-line)
+ (buffer-substring temp (point)))))))
+
+
+(defun haskell-send-input ()
+ "Send input to Haskell while in the process buffer"
+ (interactive)
+ (if (eq (get-haskell-status) 'debug)
+ (comint-send-input)
+ (haskell-send-input-aux)))
+
+(defun haskell-send-input-aux ()
+ ;; Note that the input string does not include its terminal newline.
+ (let ((proc (get-buffer-process (current-buffer))))
+ (if (not proc)
+ (haskell-mode-error "Current buffer has no process!")
+ (let* ((pmark (process-mark proc))
+ (pmark-val (marker-position pmark))
+ (input (if (>= (point) pmark-val)
+ (buffer-substring pmark (point))
+ (let ((copy (funcall comint-get-old-input)))
+ (goto-char pmark)
+ (insert copy)
+ copy))))
+ (insert ?\n)
+ (if (funcall comint-input-filter input)
+ (ring-insert input-ring input))
+ (funcall comint-input-sentinel input)
+ (set-marker (process-mark proc) (point))
+ (set-marker comint-last-input-end (point))
+ (haskell-send-to-process input)))))
+
+
+\f
+;;; ==================================================================
+;;; Minibuffer input stuff
+;;; ==================================================================
+
+;;; Haskell input history retrieval commands (taken from comint.el)
+;;; M-p -- previous input M-n -- next input
+
+(defvar haskell-minibuffer-local-map nil
+ "Local map for minibuffer when in Haskell")
+
+(if haskell-minibuffer-local-map
+ nil
+ (progn
+ (setq haskell-minibuffer-local-map
+ (copy-keymap minibuffer-local-map))
+ ;; Haskell commands
+ (define-key haskell-minibuffer-local-map "\ep" 'haskell-previous-input)
+ (define-key haskell-minibuffer-local-map "\en" 'haskell-next-input)
+ ))
+
+(defun haskell-previous-input (arg)
+ "Cycle backwards through input history."
+ (interactive "*p")
+ (let ((len (ring-length haskell-prompt-ring)))
+ (cond ((<= len 0)
+ (message "Empty input ring.")
+ (ding))
+ (t
+ (cond ((eq last-command 'haskell-previous-input)
+ (delete-region (mark) (point))
+ (set-mark (point)))
+ (t
+ (setq input-ring-index
+ (if (> arg 0) -1
+ (if (< arg 0) 1 0)))
+ (push-mark (point))))
+ (setq input-ring-index (comint-mod (+ input-ring-index arg) len))
+ (insert (ring-ref haskell-prompt-ring input-ring-index))
+ (setq this-command 'haskell-previous-input))
+ )))
+
+(defun haskell-next-input (arg)
+ "Cycle forwards through input history."
+ (interactive "*p")
+ (haskell-previous-input (- arg)))
+
+(defvar haskell-last-input-match ""
+ "Last string searched for by Haskell input history search, for defaulting.
+Buffer local variable.")
+
+(defun haskell-previous-input-matching (str)
+ "Searches backwards through input history for substring match"
+ (interactive (let ((s (read-from-minibuffer
+ (format "Command substring (default %s): "
+ haskell-last-input-match))))
+ (list (if (string= s "") haskell-last-input-match s))))
+ (setq haskell-last-input-match str) ; update default
+ (let ((str (regexp-quote str))
+ (len (ring-length haskell-prompt-ring))
+ (n 0))
+ (while (and (<= n len)
+ (not (string-match str (ring-ref haskell-prompt-ring n))))
+ (setq n (+ n 1)))
+ (cond ((<= n len) (haskell-previous-input (+ n 1)))
+ (t (haskell-mode-error "Not found.")))))
+
+
+;;; Actually read an expression from the minibuffer using the new keymap.
+
+(defun haskell-get-expression (prompt)
+ (let ((exp (read-from-minibuffer prompt nil haskell-minibuffer-local-map)))
+ (ring-insert haskell-prompt-ring exp)
+ exp))
+
+
+\f
+;;; ==================================================================
+;;; Handle output from Haskell process
+;;; ==================================================================
+
+;;; The haskell process produces output with embedded control codes.
+;;; These control codes are used to keep track of what kind of input
+;;; the haskell process is expecting. Ordinary output is just displayed.
+;;;
+;;; This is kind of complicated because control sequences can be broken
+;;; across multiple batches of text received from the haskell process.
+;;; If the string ends in the middle of a control sequence, save it up
+;;; for the next call.
+
+(defvar *haskell-saved-output* nil)
+
+;;; On the Next, there is some kind of race condition that causes stuff
+;;; sent to the Haskell subprocess before it has really started to be lost.
+;;; The point of this variable is to force the Emacs side to wait until
+;;; Haskell has started and printed out its banner before sending it
+;;; anything. See start-haskell below.
+
+(defvar *haskell-process-alive* nil)
+
+(defun haskell-output-filter (process str)
+ "Filter for output from Yale Haskell command interface"
+ ;; *** debug
+ ;;(let ((buffer (get-buffer-create "haskell-output")))
+ ;; (save-excursion
+ ;; (set-buffer buffer)
+ ;; (insert str)))
+ (setq *haskell-process-alive* t)
+ (let ((next 0)
+ (start 0)
+ (data (match-data)))
+ (unwind-protect
+ (progn
+ ;; If there was saved output from last time, glue it in front of the
+ ;; newly received input.
+ (if *haskell-saved-output*
+ (progn
+ (setq str (concat *haskell-saved-output* str))
+ (setq *haskell-saved-output* nil)))
+ ;; Loop, looking for complete command sequences.
+ ;; Set next to point to the first one.
+ ;; start points to first character to be processed.
+ (while (setq next
+ (string-match *haskell-message-match-regexp*
+ str start))
+ ;; Display any intervening ordinary text.
+ (if (not (eq next start))
+ (haskell-display-output (substring str start next)))
+ ;; Now dispatch on the particular command sequence found.
+ ;; Handler functions are called with the string and start index
+ ;; as arguments, and should return the index of the "next"
+ ;; character.
+ (let ((end (match-end 0)))
+ (haskell-handle-message str next)
+ (setq start end)))
+ ;; Look to see whether the string ends with an incomplete
+ ;; command sequence.
+ ;; If so, save the tail of the string for next time.
+ (if (and (setq next
+ (string-match *haskell-message-prefix-regexp* str start))
+ (eq (match-end 0) (length str)))
+ (setq *haskell-saved-output* (substring str next))
+ (setq next (length str)))
+ ;; Display any leftover ordinary text.
+ (if (not (eq next start))
+ (haskell-display-output (substring str start next))))
+ (store-match-data data))))
+
+(defvar *haskell-message-match-regexp*
+ "EMACS:.*\n")
+
+(defvar *haskell-message-prefix-regexp*
+ "E\\(M\\(A\\(C\\(S\\(:.*\\)?\\)?\\)?\\)?\\)?")
+
+(defvar *haskell-message-dispatch*
+ '(("EMACS:debug\n" . haskell-got-debug)
+ ("EMACS:busy\n" . haskell-got-busy)
+ ("EMACS:input\n" . haskell-got-input)
+ ("EMACS:ready\n" . haskell-got-ready)
+ ("EMACS:printers .*\n" . haskell-got-printers)
+ ("EMACS:optimizers .*\n" . haskell-got-optimizers)
+ ("EMACS:message .*\n" . haskell-got-message)
+ ("EMACS:error\n" . haskell-got-error)
+ ))
+
+(defun haskell-handle-message (str idx)
+ (let ((list *haskell-message-dispatch*)
+ (fn nil))
+ (while (and list (null fn))
+ (if (eq (string-match (car (car list)) str idx) idx)
+ (setq fn (cdr (car list)))
+ (setq list (cdr list))))
+ (if (null fn)
+ (haskell-mode-error "Garbled message from Haskell!")
+ (let ((end (match-end 0)))
+ (funcall fn str idx end)
+ end))))
+
+
+(defun haskell-message-data (string start end)
+ (let ((real-start (+ (string-match " " string start) 1))
+ (real-end (- end 1)))
+ (substring string real-start real-end)))
+
+(defun haskell-got-debug (string start end)
+ (beep)
+ (message "In the debugger!")
+ (set-haskell-status 'debug))
+
+(defun haskell-got-busy (string start end)
+ (set-haskell-status 'busy))
+
+(defun haskell-got-input (string start end)
+ (if haskell-auto-switch-input
+ (progn
+ (haskell-switch)
+ (beep)))
+ (set-haskell-status 'input)
+ (message "Waiting for input..."))
+
+(defun haskell-got-ready (string start end)
+ (set-haskell-status 'ready))
+
+(defun haskell-got-printers (string start end)
+ (haskell-printers-update (haskell-message-data string start end)))
+
+(defun haskell-got-optimizers (string start end)
+ (haskell-optimizers-update (haskell-message-data string start end)))
+
+(defun haskell-got-message (string start end)
+ (message "%s" (haskell-message-data string start end)))
+
+(defun haskell-got-error (string start end)
+; [[!chak! I found that annoying]] (beep)
+ (message "Haskell error."))
+
+
+;;; Displays output at end of given buffer.
+;;; This function only ensures that the output is visible, without
+;;; selecting the buffer in which it is displayed.
+;;; Note that just using display-buffer instead of all this rigamarole
+;;; won't work; you need to temporarily select the window containing
+;;; the *haskell-buffer*, or else the display won't be scrolled to show
+;;; the new output.
+;;; *** This should really position the window in the buffer so that
+;;; *** the point is on the last line of the window.
+
+(defun haskell-display-output (str)
+ (let ((window (selected-window)))
+ (unwind-protect
+ (progn
+ (pop-to-buffer *haskell-buffer*)
+ (haskell-display-output-aux str))
+ (select-window window))))
+
+(defun haskell-display-output-aux (str)
+ (haskell-move-marker)
+ (insert str)
+ (haskell-move-marker))
+
+
+\f
+;;; ==================================================================
+;;; Interactive commands
+;;; ==================================================================
+
+
+;;; HASKELL
+;;; -------
+;;;
+;;; This is the function that fires up the inferior haskell process.
+
+(defun haskell ()
+ "Run an inferior Haskell process with input and output via buffer *haskell*.
+Takes the program name from the variable haskell-program-name.
+Runs the hooks from inferior-haskell-mode-hook
+(after the comint-mode-hook is run).
+\(Type \\[describe-mode] in the process buffer for a list of commands.)"
+ (interactive)
+ (if (not (haskell-process-exists-p))
+ (start-haskell)))
+
+(defun start-haskell ()
+ (message "Starting haskell subprocess...")
+ ;; Kill old haskell process. Normally this routine is only called
+ ;; after checking haskell-process-exists-p, but things can get
+ ;; screwed up if you rename the *haskell* buffer while leaving the
+ ;; old process running. This forces it to get rid of the old process
+ ;; and start a new one.
+ (if (get-process "haskell")
+ (delete-process "haskell"))
+ (let ((haskell-buffer
+ (apply 'make-comint
+ "haskell"
+ (or haskell-program-name
+ (haskell-mode-error "Haskell-program-name undefined!"))
+ nil
+ nil)))
+ (save-excursion
+ (set-buffer haskell-buffer)
+ (inferior-haskell-mode))
+ (haskell-session-init)
+ ;; Wait for process to get started before sending it anything
+ ;; to avoid race condition on NeXT.
+ (setq *haskell-process-alive* nil)
+ (while (not *haskell-process-alive*)
+ (sleep-for 1))
+ (haskell-send-to-process ":(use-emacs-interface)")
+ (haskell-printers-set haskell-initial-printers nil)
+ (display-buffer haskell-buffer))
+ (message "Starting haskell subprocess... Done."))
+
+
+(defun haskell-process-exists-p ()
+ (let ((haskell-buffer (get-buffer *haskell-buffer*)))
+ (and haskell-buffer (comint-check-proc haskell-buffer))))
+
+
+
+;;; Initialize things on the emacs side, and tell haskell that it's
+;;; talking to emacs.
+
+(defun haskell-session-init ()
+ (set-haskell-status 'busy)
+ (setq *last-loaded* nil)
+ (setq *last-module* haskell-main-module)
+ (setq *last-pad* haskell-main-pad)
+ (setq *haskell-saved-output* nil)
+ (haskell-create-main-pad)
+ (set-process-filter (get-process "haskell") 'haskell-output-filter)
+ )
+
+
+(defun haskell-create-main-pad ()
+ (let ((buffer (get-buffer-create haskell-main-pad)))
+ (save-excursion
+ (set-buffer buffer)
+ (haskell-mode))
+ (haskell-record-pad-mapping
+ haskell-main-pad haskell-main-module nil)
+ buffer))
+
+
+;;; Called from evaluation and compilation commands to start up a Haskell
+;;; process if none is already in progress.
+
+(defun haskell-maybe-create-process ()
+ (cond ((haskell-process-exists-p)
+ t)
+ (haskell-auto-create-process
+ (start-haskell))
+ (t
+ (haskell-mode-error "No Haskell process!"))))
+
+
+
+;;; HASKELL-GET-PAD
+;;; ------------------------------------------------------------------
+
+;;; This always puts the pad buffer in the "other" window.
+;;; Having it wipe out the .hs file window is clearly the wrong
+;;; behavior.
+
+(defun haskell-get-pad ()
+ "Creates a new scratch pad for the current module.
+Signals an error if the current buffer is not a .hs file."
+ (interactive)
+ (let ((fname (buffer-file-name)))
+ (if fname
+ (do-get-pad fname (current-buffer))
+ (haskell-mode-error "Not in a .hs buffer!"))))
+
+
+(defun do-get-pad (fname buff)
+ (let* ((mname (or (haskell-get-modname buff)
+ (read-no-blanks-input "Scratch pad for module? " nil)))
+ (pname (haskell-lookup-pad mname fname))
+ (pbuff nil))
+ ;; Generate the base name of the pad buffer, then create the
+ ;; buffer. The actual name of the pad buffer may be something
+ ;; else because of name collisions.
+ (if (not pname)
+ (progn
+ (setq pname (format "*%s-pad*" mname))
+ (setq pbuff (generate-new-buffer pname))
+ (setq pname (buffer-name pbuff))
+ (haskell-record-pad-mapping pname mname fname)
+ )
+ (setq pbuff (get-buffer pname)))
+ ;; Make sure the pad buffer is in haskell mode.
+ (pop-to-buffer pbuff)
+ (haskell-mode)))
+
+
+
+;;; HASKELL-SWITCH
+;;; ------------------------------------------------------------------
+
+(defun haskell-switch ()
+ "Switches to \*haskell\* buffer."
+ (interactive)
+ (haskell-maybe-create-process)
+ (pop-to-buffer *haskell-buffer*)
+ (push-mark)
+ (goto-char (point-max)))
+
+
+
+;;; HASKELL-KILL
+;;; ------------------------------------------------------------------
+
+(defun haskell-kill ()
+ "Kill contents of *haskell* buffer. \\[haskell-kill]"
+ (interactive)
+ (save-excursion
+ (set-buffer *haskell-buffer*)
+ (beginning-of-buffer)
+ (let ((mark (point)))
+ (end-of-buffer)
+ (kill-region mark (point)))))
+
+
+
+;;; HASKELL-COMMAND
+;;; ------------------------------------------------------------------
+
+(defun haskell-command (str)
+ "Format STRING as a haskell command and send it to haskell process. \\[haskell-command]"
+ (interactive "sHaskell command: ")
+ (haskell-send-to-process (format ":%s" str)))
+
+
+;;; HASKELL-EVAL and HASKELL-RUN
+;;; ------------------------------------------------------------------
+
+(defun haskell-eval ()
+ "Evaluate expression in current module. \\[haskell-eval]"
+ (interactive)
+ (haskell-maybe-create-process)
+ (haskell-eval-aux (haskell-get-expression "Haskell expression: ")
+ "emacs-eval"))
+
+(defun haskell-run ()
+ "Run Haskell Dialogue in current module"
+ (interactive)
+ (haskell-maybe-create-process)
+ (haskell-eval-aux (haskell-get-expression "Haskell dialogue: ")
+ "emacs-run"))
+
+(defun haskell-run-main ()
+ "Run Dialogue named main in current module"
+ (interactive)
+ (haskell-maybe-create-process)
+ (haskell-eval-aux "main" "emacs-run"))
+
+(defun haskell-report-type ()
+ "Print the type of the expression."
+ (interactive)
+ (haskell-maybe-create-process)
+ (haskell-eval-aux (haskell-get-expression "Haskell expression: ")
+ "emacs-report-type"))
+
+(defun haskell-eval-aux (exp fn)
+ (cond ((equal *haskell-buffer* (buffer-name))
+ ;; In the *haskell* buffer.
+ (let* ((pname *last-pad*)
+ (mname *last-module*)
+ (fname *last-loaded*))
+ (haskell-eval-aux-aux exp pname mname fname fn)))
+ ((buffer-file-name)
+ ;; In a .hs file.
+ (let* ((fname (buffer-file-name))
+ (mname (haskell-get-modname (current-buffer)))
+ (pname (haskell-lookup-pad mname fname)))
+ (haskell-eval-aux-aux exp pname mname fname fn)))
+ (t
+ ;; In a pad.
+ (let* ((pname (buffer-name (current-buffer)))
+ (mname (haskell-get-module-from-pad pname))
+ (fname (haskell-get-file-from-pad pname)))
+ (haskell-eval-aux-aux exp pname mname fname fn)))
+ ))
+
+(defun haskell-eval-aux-aux (exp pname mname fname fn)
+ (haskell-save-modified-source-files fname)
+ (haskell-send-to-process (format ":(%s" fn))
+ (haskell-send-to-process
+ (prin1-to-string exp))
+ (haskell-send-to-process
+ (prin1-to-string (or pname fname "interactive")))
+ (haskell-send-to-process
+ (prin1-to-string
+ (if (and pname (get-buffer pname))
+ (save-excursion
+ (set-buffer pname)
+ (buffer-string))
+ "")))
+ (haskell-send-to-process
+ (format "'|%s|" mname))
+ (haskell-send-to-process
+ (if fname
+ (prin1-to-string (haskell-maybe-get-unit-file-name fname))
+ "'#f"))
+ (haskell-send-to-process ")")
+ (setq *last-pad* pname)
+ (setq *last-module* mname)
+ (setq *last-loaded* fname))
+
+
+
+;;; HASKELL-RUN-FILE, HASKELL-LOAD, HASKELL-COMPILE
+;;; ------------------------------------------------------------------
+
+(defun haskell-run-file ()
+ "Runs Dialogue named main in current file."
+ (interactive)
+ (haskell-maybe-create-process)
+ (let ((fname (haskell-get-file-to-operate-on)))
+ (haskell-save-modified-source-files fname)
+ (haskell-send-to-process ":(emacs-run-file")
+ (haskell-send-to-process (prin1-to-string fname))
+ (haskell-send-to-process ")")))
+
+(defun haskell-load ()
+ "Load current file."
+ (interactive)
+ (haskell-maybe-create-process)
+ (let ((fname (haskell-get-file-to-operate-on)))
+ (haskell-save-modified-source-files fname)
+ (haskell-send-to-process ":(emacs-load-file")
+ (haskell-send-to-process (prin1-to-string fname))
+ (haskell-send-to-process ")")))
+
+(defun haskell-compile ()
+ "Compile current file."
+ (interactive)
+ (haskell-maybe-create-process)
+ (let ((fname (haskell-get-file-to-operate-on)))
+ (haskell-save-modified-source-files fname)
+ (haskell-send-to-process ":(emacs-compile-file")
+ (haskell-send-to-process (prin1-to-string fname))
+ (haskell-send-to-process ")")))
+
+
+(defun haskell-get-file-to-operate-on ()
+ (cond ((equal *haskell-buffer* (buffer-name))
+ ;; When called from the haskell process buffer, prompt for a file.
+ (call-interactively 'haskell-get-file/prompt))
+ ((buffer-file-name)
+ ;; When called from a .hs file buffer, use the unit file
+ ;; associated with it, if there is one.
+ (haskell-maybe-get-unit-file-name (buffer-file-name)))
+ (t
+ ;; When called from a pad, use the file that the module the
+ ;; pad belongs to lives in.
+ (haskell-maybe-get-unit-file-name
+ (haskell-get-file-from-pad (buffer-name (current-buffer)))))))
+
+(defun haskell-get-file/prompt (filename)
+ (interactive "fHaskell file: ")
+ filename)
+
+
+
+;;; HASKELL-EXIT
+;;; ------------------------------------------------------------------
+
+(defun haskell-exit ()
+ "Quit the haskell process."
+ (interactive)
+ (cond ((not (haskell-process-exists-p))
+ (message "No process currently running."))
+ ((y-or-n-p "Do you really want to quit Haskell? ")
+ (haskell-send-to-process ":quit")
+ ;; If we were running the tutorial, mark the temp buffer as unmodified
+ ;; so we don't get asked about saving it later.
+ (if (and *ht-temp-buffer*
+ (get-buffer *ht-temp-buffer*))
+ (save-excursion
+ (set-buffer *ht-temp-buffer*)
+ (set-buffer-modified-p nil)))
+ ;; Try to remove the haskell output buffer from the screen.
+ (bury-buffer *haskell-buffer*)
+ (replace-buffer-in-windows *haskell-buffer*))
+ (t
+ nil)))
+
+
+;;; HASKELL-INTERRUPT
+;;; ------------------------------------------------------------------
+
+(defun haskell-interrupt ()
+ "Interrupt the haskell process."
+ (interactive)
+ (if (haskell-process-exists-p)
+ (haskell-send-to-process "\C-c")))
+
+
+
+;;; HASKELL-EDIT-UNIT
+;;; ------------------------------------------------------------------
+
+(defun haskell-edit-unit ()
+ "Edit the .hu file."
+ (interactive)
+ (let ((fname (buffer-file-name)))
+ (if fname
+ (let ((find-file-not-found-hooks (list 'haskell-new-unit))
+ (file-not-found nil)
+ (units-fname (haskell-get-unit-file-name fname)))
+ (find-file-other-window units-fname)
+ ;; If creating a new file, initialize it to contain the name
+ ;; of the haskell source file.
+ (if file-not-found
+ (save-excursion
+ (insert
+ (if (string= (file-name-directory fname)
+ (file-name-directory units-fname))
+ (file-name-nondirectory fname)
+ fname)
+ "\n"))))
+ (haskell-mode-error "Not in a .hs buffer!"))))
+
+(defun haskell-new-unit ()
+ (setq file-not-found t))
+
+
+;;; Look for a comment like "-- unit:" at top of file.
+;;; If not found, assume unit file has same name as the buffer but
+;;; a .hu extension.
+
+(defun haskell-get-unit-file-name (fname)
+ (or (haskell-get-unit-file-name-from-file fname)
+ (concat (haskell-strip-file-extension fname) ".hu")))
+
+(defun haskell-maybe-get-unit-file-name (fname)
+ (or (haskell-get-unit-file-name-from-file fname)
+ (haskell-strip-file-extension fname)))
+
+(defun haskell-get-unit-file-name-from-file (fname)
+ (let ((buffer (get-file-buffer fname)))
+ (if buffer
+ (save-excursion
+ (beginning-of-buffer)
+ (if (re-search-forward "-- unit:[ \t]*" (point-max) t)
+ (let ((beg (match-end 0)))
+ (end-of-line)
+ (buffer-substring beg (point)))
+ nil))
+ nil)))
+
+
+
+\f
+;;; ==================================================================
+;;; Support for printers/optimizers menus
+;;; ==================================================================
+
+;;; This code was adapted from the standard buff-menu.el code.
+
+(defvar haskell-menu-mode-map nil "")
+
+(if (not haskell-menu-mode-map)
+ (progn
+ (setq haskell-menu-mode-map (make-keymap))
+ (suppress-keymap haskell-menu-mode-map t)
+ (define-key haskell-menu-mode-map "m" 'hm-mark)
+ (define-key haskell-menu-mode-map "u" 'hm-unmark)
+ (define-key haskell-menu-mode-map "x" 'hm-exit)
+ (define-key haskell-menu-mode-map "q" 'hm-exit)
+ (define-key haskell-menu-mode-map " " 'next-line)
+ (define-key haskell-menu-mode-map "\177" 'hm-backup-unmark)
+ (define-key haskell-menu-mode-map "?" 'describe-mode)))
+
+;; Printers Menu mode is suitable only for specially formatted data.
+
+(put 'haskell-menu-mode 'mode-class 'special)
+
+(defun haskell-menu-mode ()
+ "Major mode for editing Haskell flags.
+Each line describes a flag.
+Letters do not insert themselves; instead, they are commands.
+m -- mark flag (turn it on)
+u -- unmark flag (turn it off)
+x -- exit; tell the Haskell process to update the flags, then leave menu.
+q -- exit; same as x.
+Precisely,\\{haskell-menu-mode-map}"
+ (kill-all-local-variables)
+ (use-local-map haskell-menu-mode-map)
+ (setq truncate-lines t)
+ (setq buffer-read-only t)
+ (setq major-mode 'haskell-menu-mode)
+ (setq mode-name "Haskell Flags Menu")
+ ;; These are all initialized elsewhere
+ (make-local-variable 'hm-current-flags)
+ (make-local-variable 'hm-request-fn)
+ (make-local-variable 'hm-update-fn)
+ (run-hooks 'haskell-menu-mode-hook))
+
+
+(defun haskell-menu (help-file buffer request-fn update-fn)
+ (haskell-maybe-create-process)
+ (if (get-buffer buffer)
+ (progn
+ (pop-to-buffer buffer)
+ (goto-char (point-min)))
+ (progn
+ (pop-to-buffer buffer)
+ (insert-file-contents help-file)
+ (haskell-menu-mode)
+ (setq hm-request-fn request-fn)
+ (setq hm-update-fn update-fn)
+ ))
+ (hm-mark-current)
+ (message "m = mark; u = unmark; x = execute; q = quit; ? = more help."))
+
+
+
+;;; A line that starts with *hm-marked* is a menu item turned on.
+;;; A line that starts with *hm-unmarked* is turned off.
+;;; A line that starts with anything else is just random text and is
+;;; ignored by commands that deal with menu items.
+
+(defvar *hm-marked* " on")
+(defvar *hm-unmarked* " ")
+(defvar *hm-marked-regexp* " on \\w")
+(defvar *hm-unmarked-regexp* " \\w")
+
+(defun hm-mark ()
+ "Mark flag to be turned on."
+ (interactive)
+ (beginning-of-line)
+ (cond ((looking-at *hm-marked-regexp*)
+ (forward-line 1))
+ ((looking-at *hm-unmarked-regexp*)
+ (let ((buffer-read-only nil))
+ (delete-char (length *hm-unmarked*))
+ (insert *hm-marked*)
+ (forward-line 1)))
+ (t
+ (forward-line 1))))
+
+(defun hm-unmark ()
+ "Unmark flag."
+ (interactive)
+ (beginning-of-line)
+ (cond ((looking-at *hm-unmarked-regexp*)
+ (forward-line 1))
+ ((looking-at *hm-marked-regexp*)
+ (let ((buffer-read-only nil))
+ (delete-char (length *hm-marked*))
+ (insert *hm-unmarked*)
+ (forward-line 1)))
+ (t
+ (forward-line 1))))
+
+(defun hm-backup-unmark ()
+ "Move up and unmark."
+ (interactive)
+ (forward-line -1)
+ (hm-unmark)
+ (forward-line -1))
+
+
+;;; Actually make the changes.
+
+(defun hm-exit ()
+ "Update flags, then leave menu."
+ (interactive)
+ (hm-execute)
+ (hm-quit))
+
+(defun hm-execute ()
+ "Tell haskell process to tweak flags."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((flags-on nil)
+ (flags-off nil))
+ (while (not (eq (point) (point-max)))
+ (cond ((looking-at *hm-unmarked-regexp*)
+ (setq flags-off (cons (hm-flag) flags-off)))
+ ((looking-at *hm-marked-regexp*)
+ (setq flags-on (cons (hm-flag) flags-on)))
+ (t
+ nil))
+ (forward-line 1))
+ (funcall hm-update-fn flags-on flags-off))))
+
+
+(defun hm-quit ()
+ (interactive)
+ "Make the menu go away."
+ (bury-buffer (current-buffer))
+ (replace-buffer-in-windows (current-buffer)))
+
+(defun hm-flag ()
+ (save-excursion
+ (beginning-of-line)
+ (forward-char 6)
+ (let ((beg (point)))
+ ;; End of flag name marked by tab or two spaces.
+ (re-search-forward "\t\\| ")
+ (buffer-substring beg (match-beginning 0)))))
+
+
+;;; Update the menu to mark only those items currently turned on.
+
+(defun hm-mark-current ()
+ (funcall hm-request-fn)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eq (point) (point-max)))
+ (cond ((and (looking-at *hm-unmarked-regexp*)
+ (hm-item-currently-on-p (hm-flag)))
+ (hm-mark))
+ ((and (looking-at *hm-marked-regexp*)
+ (not (hm-item-currently-on-p (hm-flag))))
+ (hm-unmark))
+ (t
+ (forward-line 1))))))
+
+
+;;; See if a menu item is turned on.
+
+(defun hm-item-currently-on-p (item)
+ (member-string= item hm-current-flags))
+
+(defun member-string= (item list)
+ (cond ((null list)
+ nil)
+ ((string= item (car list))
+ list)
+ (t
+ (member-string= item (cdr list)))))
+
+
+
+;;; Make the menu for printers.
+
+(defvar *haskell-printers-help*
+ (concat (getenv "HASKELL") "/emacs-tools/printer-help.txt")
+ "Help file for printers.")
+
+(defvar *haskell-printers-buffer* "*Haskell printers*")
+
+(defun haskell-printers ()
+ "Set printers interactively."
+ (interactive)
+ (haskell-menu
+ *haskell-printers-help*
+ *haskell-printers-buffer*
+ 'haskell-printers-inquire
+ 'haskell-printers-set))
+
+(defun haskell-printers-inquire ()
+ (setq hm-current-flags t)
+ (haskell-send-to-process ":(emacs-send-printers)")
+ (while (eq hm-current-flags t)
+ (sleep-for 1)))
+
+(defun haskell-printers-update (data)
+ (setq hm-current-flags (read data)))
+
+(defun haskell-printers-set (flags-on flags-off)
+ (haskell-send-to-process ":(emacs-set-printers '")
+ (haskell-send-to-process (prin1-to-string flags-on))
+ (haskell-send-to-process ")"))
+
+
+;;; Equivalent stuff for the optimizers menu
+
+(defvar *haskell-optimizers-help*
+ (concat (getenv "HASKELL") "/emacs-tools/optimizer-help.txt")
+ "Help file for optimizers.")
+
+(defvar *haskell-optimizers-buffer* "*Haskell optimizers*")
+
+(defun haskell-optimizers ()
+ "Set optimizers interactively."
+ (interactive)
+ (haskell-menu
+ *haskell-optimizers-help*
+ *haskell-optimizers-buffer*
+ 'haskell-optimizers-inquire
+ 'haskell-optimizers-set))
+
+(defun haskell-optimizers-inquire ()
+ (setq hm-current-flags t)
+ (haskell-send-to-process ":(emacs-send-optimizers)")
+ (while (eq hm-current-flags t)
+ (sleep-for 1)))
+
+(defun haskell-optimizers-update (data)
+ (setq hm-current-flags (read data)))
+
+(defun haskell-optimizers-set (flags-on flags-off)
+ (haskell-send-to-process ":(emacs-set-optimizers '")
+ (haskell-send-to-process (prin1-to-string flags-on))
+ (haskell-send-to-process ")"))
+
+
+\f
+;;; ==================================================================
+;;; Random utilities
+;;; ==================================================================
+
+
+;;; Keep track of the association between pads, modules, and files.
+;;; The global variable is a list of (pad-buffer-name module-name file-name)
+;;; lists.
+
+(defvar *haskell-pad-mappings* ()
+ "Associates pads with their corresponding module and file.")
+
+(defun haskell-record-pad-mapping (pname mname fname)
+ (setq *haskell-pad-mappings*
+ (cons (list pname mname fname) *haskell-pad-mappings*)))
+
+(defun haskell-get-module-from-pad (pname)
+ (car (cdr (assoc pname *haskell-pad-mappings*))))
+
+(defun haskell-get-file-from-pad (pname)
+ (car (cdr (cdr (assoc pname *haskell-pad-mappings*)))))
+
+(defun haskell-lookup-pad (mname fname)
+ (let ((pname (haskell-lookup-pad-aux mname fname *haskell-pad-mappings*)))
+ (if (and pname (get-buffer pname))
+ pname
+ nil)))
+
+(defun haskell-lookup-pad-aux (mname fname list)
+ (cond ((null list)
+ nil)
+ ((and (equal mname (car (cdr (car list))))
+ (equal fname (car (cdr (cdr (car list))))))
+ (car (car list)))
+ (t
+ (haskell-lookup-pad-aux mname fname (cdr list)))))
+
+
+
+;;; Save any modified .hs and .hu files.
+;;; Yes, the two set-buffer calls really seem to be necessary. It seems
+;;; that y-or-n-p makes emacs forget we had temporarily selected some
+;;; other buffer, and if you just do save-buffer directly it will end
+;;; up trying to save the current buffer instead. The built-in
+;;; save-some-buffers function has this problem....
+
+(defun haskell-save-modified-source-files (filename)
+ (let ((buffers (buffer-list))
+ (found-any nil))
+ (while buffers
+ (let ((buffer (car buffers)))
+ (if (and (buffer-modified-p buffer)
+ (save-excursion
+ (set-buffer buffer)
+ (and buffer-file-name
+ (haskell-source-file-p buffer-file-name)
+ (setq found-any t)
+ (or (null haskell-ask-before-saving)
+ (and filename (string= buffer-file-name filename))
+ (y-or-n-p
+ (format "Save file %s? " buffer-file-name))))))
+ (save-excursion
+ (set-buffer buffer)
+ (save-buffer))))
+ (setq buffers (cdr buffers)))
+ (if found-any
+ (message "")
+ (message "(No files need saving)"))))
+
+(defun haskell-source-file-p (filename)
+ (or (string-match "\\.hs$" filename)
+ (string-match "\\.lhs$" filename)
+ (string-match "\\.hi$" filename)
+ (string-match "\\.hu$" filename)))
+
+
+
+;;; Buffer utilities
+
+(defun haskell-move-marker ()
+ "Moves the marker and point to the end of buffer"
+ (set-marker comint-last-input-end (point-max))
+ (set-marker (process-mark (get-process "haskell")) (point-max))
+ (goto-char (point-max)))
+
+
+
+;;; Extract the name of the module the point is in, from the given buffer.
+
+(defvar *haskell-re-module-hs* "^module\\s *")
+(defvar *haskell-re-module-lhs* "^>\\s *module\\s *")
+(defvar *haskell-re-modname* "[A-Z]\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\)*")
+
+(defun haskell-get-modname (buff)
+ "Get module name in BUFFER that point is in."
+ (save-excursion
+ (set-buffer buff)
+ (let ((regexp (if (haskell-lhs-filename-p (buffer-file-name))
+ *haskell-re-module-lhs*
+ *haskell-re-module-hs*)))
+ (if (or (looking-at regexp)
+ (re-search-backward regexp (point-min) t)
+ (re-search-forward regexp (point-max) t))
+ (progn
+ (goto-char (match-end 0))
+ (if (looking-at *haskell-re-modname*)
+ (buffer-substring (match-beginning 0) (match-end 0))
+ (haskell-mode-error "Module name not found!!")))
+ "Main"))))
+
+
+;;; Strip file extensions.
+;;; Only strip off extensions we know about; e.g.
+;;; "foo.hs" -> "foo" but "foo.bar" -> "foo.bar".
+
+(defvar *haskell-filename-regexp* "\\(.*\\)\\.\\(hs\\|lhs\\)$")
+
+(defun haskell-strip-file-extension (filename)
+ "Strip off the extension from a filename."
+ (if (string-match *haskell-filename-regexp* filename)
+ (substring filename (match-beginning 1) (match-end 1))
+ filename))
+
+
+;;; Is this a .lhs filename?
+
+(defun haskell-lhs-filename-p (filename)
+ (string-match ".*\\.lhs$" filename))
+
+
+;;; Haskell mode error
+
+(defun haskell-mode-error (msg)
+ "Show MSG in message line as an error from the haskell mode."
+ (error (concat "Haskell mode: " msg)))
+
+
+\f
+;;; ==================================================================
+;;; User customization
+;;; ==================================================================
+
+(defvar haskell-load-hook nil
+ "This hook is run when haskell is loaded in.
+This is a good place to put key bindings."
+ )
+
+(run-hooks 'haskell-load-hook)
+
+
+
+\f
+;;;======================================================================
+;;; Tutorial mode setup
+;;;======================================================================
+
+;;; Set up additional key bindings for tutorial mode.
+
+(defvar ht-mode-map (make-sparse-keymap))
+
+(haskell-establish-key-bindings ht-mode-map)
+(define-key ht-mode-map "\C-c\C-f" 'ht-next-page)
+(define-key ht-mode-map "\C-c\C-b" 'ht-prev-page)
+(define-key ht-mode-map "\C-c\C-l" 'ht-restore-page)
+(define-key ht-mode-map "\C-c?" 'describe-mode)
+
+(defun haskell-tutorial-mode ()
+ "Major mode for running the Haskell tutorial.
+You can use these commands:
+\\{ht-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map ht-mode-map)
+ (setq major-mode 'haskell-tutorial-mode)
+ (setq mode-name "Haskell Tutorial")
+ (set-syntax-table haskell-mode-syntax-table)
+ (run-hooks 'haskell-mode-hook))
+
+
+(defun haskell-tutorial ()
+ "Run the haskell tutorial."
+ (interactive)
+ (ht-load-tutorial)
+ (ht-make-buffer)
+ (ht-display-page)
+ (haskell-maybe-create-process)
+ (haskell-send-to-process ":(emacs-set-printers '(interactive))")
+ )
+
+
+;;; Load the tutorial file into a read-only buffer. Do not display this
+;;; buffer.
+
+(defun ht-load-tutorial ()
+ (let ((buffer (get-buffer *ht-file-buffer*)))
+ (if buffer
+ (save-excursion
+ (set-buffer buffer)
+ (beginning-of-buffer))
+ (save-excursion
+ (set-buffer (setq buffer (get-buffer-create *ht-file-buffer*)))
+ (let ((fname (substitute-in-file-name *ht-source-file*)))
+ (if (file-readable-p fname)
+ (ht-load-tutorial-aux fname)
+ (call-interactively 'ht-load-tutorial-aux)))))))
+
+(defun ht-load-tutorial-aux (filename)
+ (interactive "fTutorial file: ")
+ (insert-file filename)
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t)
+ (beginning-of-buffer))
+
+
+;;; Create a buffer to use for messing about with each page of the tutorial.
+;;; Put the buffer into haskell-tutorial-mode.
+
+(defun ht-make-buffer ()
+ (find-file (concat "/tmp/" (make-temp-name "ht") ".lhs"))
+ (setq *ht-temp-buffer* (buffer-name))
+ (haskell-tutorial-mode))
+
+
+;;; Commands for loading text into the tutorial pad buffer
+
+(defun ht-next-page ()
+ "Go to the next tutorial page."
+ (interactive)
+ (if (ht-goto-next-page)
+ (ht-display-page)
+ (beep)))
+
+(defun ht-goto-next-page ()
+ (let ((buff (current-buffer)))
+ (unwind-protect
+ (progn
+ (set-buffer *ht-file-buffer*)
+ (search-forward "\C-l" nil t))
+ (set-buffer buff))))
+
+(defun ht-prev-page ()
+ "Go to the previous tutorial page."
+ (interactive)
+ (if (ht-goto-prev-page)
+ (ht-display-page)
+ (beep)))
+
+(defun ht-goto-prev-page ()
+ (let ((buff (current-buffer)))
+ (unwind-protect
+ (progn
+ (set-buffer *ht-file-buffer*)
+ (search-backward "\C-l" nil t))
+ (set-buffer buff))))
+
+(defun ht-goto-page (arg)
+ "Go to the tutorial page specified as the argument."
+ (interactive "sGo to page: ")
+ (if (ht-searchfor-page (format "Page: %s " arg))
+ (ht-display-page)
+ (beep)))
+
+(defun ht-goto-section (arg)
+ "Go to the tutorial section specified as the argument."
+ (interactive "sGo to section: ")
+ (if (ht-searchfor-page (format "Section: %s " arg))
+ (ht-display-page)
+ (beep)))
+
+(defun ht-searchfor-page (search-string)
+ (let ((buff (current-buffer)))
+ (unwind-protect
+ (progn
+ (set-buffer *ht-file-buffer*)
+ (let ((point (point)))
+ (beginning-of-buffer)
+ (if (search-forward search-string nil t)
+ t
+ (progn
+ (goto-char point)
+ nil))))
+ (set-buffer buff))))
+
+(defun ht-restore-page ()
+ (interactive)
+ (let ((old-point (point)))
+ (ht-display-page)
+ (goto-char old-point)))
+
+(defun ht-display-page ()
+ (set-buffer *ht-file-buffer*)
+ (let* ((beg (progn
+ (if (search-backward "\C-l" nil t)
+ (forward-line 1)
+ (beginning-of-buffer))
+ (point)))
+ (end (progn
+ (if (search-forward "\C-l" nil t)
+ (beginning-of-line)
+ (end-of-buffer))
+ (point)))
+ (text (buffer-substring beg end)))
+ (set-buffer *ht-temp-buffer*)
+ (erase-buffer)
+ (insert text)
+ (beginning-of-buffer)))
+
+
+\f
+;;;======================================================================
+;;; Menu bar stuff
+;;;======================================================================
+
+;;; This only works in Emacs version 19, so it's in a separate file for now.
+
+(if (featurep 'menu-bar)
+ (load-library "haskell-menu"))
+
--- /dev/null
+This directory contains GNU Emacs support for editing Haskell files.
+We don't yet have a fancy editing mode, but haskell.el contains stuff
+for running Haskell as an inferior process from Emacs with key bindings
+for evaluating code from buffers, etc. Look at the comments in haskell.el
+for more information.
--- /dev/null
+;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff
+;;; Copyright Olin Shivers (1988).
+;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
+;;; notice appearing here to the effect that you may use this code any
+;;; way you like, as long as you don't charge money for it, remove this
+;;; notice, or hold me liable for its results.
+
+;;; The changelog is at the end of this file.
+
+;;; Please send me bug reports, bug fixes, and extensions, so that I can
+;;; merge them into the master source.
+;;; - Olin Shivers (shivers@cs.cmu.edu)
+
+;;; This hopefully generalises shell mode, lisp mode, tea mode, soar mode,...
+;;; This file defines a general command-interpreter-in-a-buffer package
+;;; (comint mode). The idea is that you can build specific process-in-a-buffer
+;;; modes on top of comint mode -- e.g., lisp, shell, scheme, T, soar, ....
+;;; This way, all these specific packages share a common base functionality,
+;;; and a common set of bindings, which makes them easier to use (and
+;;; saves code, implementation time, etc., etc.).
+
+;;; Several packages are already defined using comint mode:
+;;; - cmushell.el defines a shell-in-a-buffer mode.
+;;; - cmulisp.el defines a simple lisp-in-a-buffer mode.
+;;; Cmushell and cmulisp mode are similar to, and intended to replace,
+;;; their counterparts in the standard gnu emacs release (in shell.el).
+;;; These replacements are more featureful, robust, and uniform than the
+;;; released versions. The key bindings in lisp mode are also more compatible
+;;; with the bindings of Hemlock and Zwei (the Lisp Machine emacs).
+;;;
+;;; - The file cmuscheme.el defines a scheme-in-a-buffer mode.
+;;; - The file tea.el tunes scheme and inferior-scheme modes for T.
+;;; - The file soar.el tunes lisp and inferior-lisp modes for Soar.
+;;; - cmutex.el defines tex and latex modes that invoke tex, latex, bibtex,
+;;; previewers, and printers from within emacs.
+;;; - background.el allows csh-like job control inside emacs.
+;;; It is pretty easy to make new derived modes for other processes.
+
+;;; For documentation on the functionality provided by comint mode, and
+;;; the hooks available for customising it, see the comments below.
+;;; For further information on the standard derived modes (shell,
+;;; inferior-lisp, inferior-scheme, ...), see the relevant source files.
+
+;;; For hints on converting existing process modes (e.g., tex-mode,
+;;; background, dbx, gdb, kermit, prolog, telnet) to use comint-mode
+;;; instead of shell-mode, see the notes at the end of this file.
+
+(provide 'comint)
+(defconst comint-version "2.01")
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+;;; Brief Command Documentation:
+;;;============================================================================
+;;; Comint Mode Commands: (common to all derived modes, like cmushell & cmulisp
+;;; mode)
+;;;
+;;; m-p comint-previous-input Cycle backwards in input history
+;;; m-n comint-next-input Cycle forwards
+;;; m-s comint-previous-similar-input Previous similar input
+;;; c-c r comint-previous-input-matching Search backwards in input history
+;;; return comint-send-input
+;;; c-a comint-bol Beginning of line; skip prompt.
+;;; c-d comint-delchar-or-maybe-eof Delete char unless at end of buff.
+;;; c-c c-u comint-kill-input ^u
+;;; c-c c-w backward-kill-word ^w
+;;; c-c c-c comint-interrupt-subjob ^c
+;;; c-c c-z comint-stop-subjob ^z
+;;; c-c c-\ comint-quit-subjob ^\
+;;; c-c c-o comint-kill-output Delete last batch of process output
+;;; c-c c-r comint-show-output Show last batch of process output
+;;;
+;;; Not bound by default in comint-mode
+;;; send-invisible Read a line w/o echo, and send to proc
+;;; (These are bound in shell-mode)
+;;; comint-dynamic-complete Complete filename at point.
+;;; comint-dynamic-list-completions List completions in help buffer.
+;;; comint-replace-by-expanded-filename Expand and complete filename at point;
+;;; replace with expanded/completed name.
+;;; comint-kill-subjob No mercy.
+;;; comint-continue-subjob Send CONT signal to buffer's process
+;;; group. Useful if you accidentally
+;;; suspend your process (with C-c C-z).
+;;;
+;;; Bound for RMS -- I prefer the input history stuff, but you might like 'em.
+;;; m-P comint-msearch-input Search backwards for prompt
+;;; m-N comint-psearch-input Search forwards for prompt
+;;; C-cR comint-msearch-input-matching Search backwards for prompt & string
+
+;;; comint-mode-hook is the comint mode hook. Basically for your keybindings.
+;;; comint-load-hook is run after loading in this package.
+
+
+
+
+
+;;; Buffer Local Variables:
+;;;============================================================================
+;;; Comint mode buffer local variables:
+;;; comint-prompt-regexp - string comint-bol uses to match prompt.
+;;; comint-last-input-end - marker For comint-kill-output command
+;;; input-ring-size - integer For the input history
+;;; input-ring - ring mechanism
+;;; input-ring-index - marker ...
+;;; comint-last-input-match - string ...
+;;; comint-get-old-input - function Hooks for specific
+;;; comint-input-sentinel - function process-in-a-buffer
+;;; comint-input-filter - function modes.
+;;; comint-input-send - function
+;;; comint-eol-on-send - boolean
+
+(defvar comint-prompt-regexp "^"
+ "Regexp to recognise prompts in the inferior process.
+Defaults to \"^\", the null string at BOL.
+
+Good choices:
+ Canonical Lisp: \"^[^> ]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp)
+ Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\"
+ franz: \"^\\(->\\|<[0-9]*>:\\) *\"
+ kcl: \"^>+ *\"
+ shell: \"^[^#$%>]*[#$%>] *\"
+ T: \"^>+ *\"
+
+This is a good thing to set in mode hooks.")
+
+(defvar input-ring-size 30
+ "Size of input history ring.")
+
+;;; Here are the per-interpreter hooks.
+(defvar comint-get-old-input (function comint-get-old-input-default)
+ "Function that submits old text in comint mode.
+This function is called when return is typed while the point is in old text.
+It returns the text to be submitted as process input. The default is
+comint-get-old-input-default, which grabs the current line, and strips off
+leading text matching comint-prompt-regexp")
+
+(defvar comint-input-sentinel (function ignore)
+ "Called on each input submitted to comint mode process by comint-send-input.
+Thus it can, for instance, track cd/pushd/popd commands issued to the csh.")
+
+(defvar comint-input-filter
+ (function (lambda (str) (not (string-match "\\`\\s *\\'" str))))
+ "Predicate for filtering additions to input history.
+Only inputs answering true to this function are saved on the input
+history list. Default is to save anything that isn't all whitespace")
+
+(defvar comint-input-sender (function comint-simple-send)
+ "Function to actually send to PROCESS the STRING submitted by user.
+Usually this is just 'comint-simple-send, but if your mode needs to
+massage the input string, this is your hook. This is called from
+the user command comint-send-input. comint-simple-send just sends
+the string plus a newline.")
+
+(defvar comint-eol-on-send 'T
+ "If non-nil, then jump to the end of the line before sending input to process.
+See COMINT-SEND-INPUT")
+
+(defvar comint-mode-hook '()
+ "Called upon entry into comint-mode")
+
+(defvar comint-mode-map nil)
+
+(defun comint-mode ()
+ "Major mode for interacting with an inferior interpreter.
+Interpreter name is same as buffer name, sans the asterisks.
+Return at end of buffer sends line as input.
+Return not at end copies rest of line to end and sends it.
+Setting mode variable comint-eol-on-send means jump to the end of the line
+before submitting new input.
+
+This mode is typically customised to create inferior-lisp-mode,
+shell-mode, etc.. This can be done by setting the hooks
+comint-input-sentinel, comint-input-filter, comint-input-sender and
+comint-get-old-input to appropriate functions, and the variable
+comint-prompt-regexp to the appropriate regular expression.
+
+An input history is maintained of size input-ring-size, and
+can be accessed with the commands comint-next-input [\\[comint-next-input]] and
+comint-previous-input [\\[comint-previous-input]]. Commands not keybound by
+default are send-invisible, comint-dynamic-complete, and
+comint-list-dynamic-completions.
+
+If you accidentally suspend your process, use \\[comint-continue-subjob]
+to continue it.
+
+\\{comint-mode-map}
+
+Entry to this mode runs the hooks on comint-mode-hook"
+ (interactive)
+ (let ((old-ring (and (assq 'input-ring (buffer-local-variables))
+ (boundp 'input-ring)
+ input-ring))
+ (old-ptyp comint-ptyp)) ; preserve across local var kill. gross.
+ (kill-all-local-variables)
+ (setq major-mode 'comint-mode)
+ (setq mode-name "Comint")
+ (setq mode-line-process '(": %s"))
+ (use-local-map comint-mode-map)
+ (make-local-variable 'comint-last-input-end)
+ (setq comint-last-input-end (make-marker))
+ (make-local-variable 'comint-last-input-match)
+ (setq comint-last-input-match "")
+ (make-local-variable 'comint-prompt-regexp) ; Don't set; default
+ (make-local-variable 'input-ring-size) ; ...to global val.
+ (make-local-variable 'input-ring)
+ (make-local-variable 'input-ring-index)
+ (setq input-ring-index 0)
+ (make-local-variable 'comint-get-old-input)
+ (make-local-variable 'comint-input-sentinel)
+ (make-local-variable 'comint-input-filter)
+ (make-local-variable 'comint-input-sender)
+ (make-local-variable 'comint-eol-on-send)
+ (make-local-variable 'comint-ptyp)
+ (setq comint-ptyp old-ptyp)
+ (run-hooks 'comint-mode-hook)
+ ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook.
+ ;The test is so we don't lose history if we run comint-mode twice in
+ ;a buffer.
+ (setq input-ring (if (ring-p old-ring) old-ring
+ (make-ring input-ring-size)))))
+
+;;; The old-ptyp stuff above is because we have to preserve the value of
+;;; comint-ptyp across calls to comint-mode, in spite of the
+;;; kill-all-local-variables that it does. Blech. Hopefully, this will all
+;;; go away when a later release fixes the signalling bug.
+
+(if comint-mode-map
+ nil
+ (setq comint-mode-map (make-sparse-keymap))
+ (define-key comint-mode-map "\ep" 'comint-previous-input)
+ (define-key comint-mode-map "\en" 'comint-next-input)
+ (define-key comint-mode-map "\es" 'comint-previous-similar-input)
+ (define-key comint-mode-map "\C-m" 'comint-send-input)
+ (define-key comint-mode-map "\C-d" 'comint-delchar-or-maybe-eof)
+ (define-key comint-mode-map "\C-a" 'comint-bol)
+ (define-key comint-mode-map "\C-c\C-u" 'comint-kill-input)
+ (define-key comint-mode-map "\C-c\C-w" 'backward-kill-word)
+ (define-key comint-mode-map "\C-c\C-c" 'comint-interrupt-subjob)
+ (define-key comint-mode-map "\C-c\C-z" 'comint-stop-subjob)
+ (define-key comint-mode-map "\C-c\C-\\" 'comint-quit-subjob)
+ (define-key comint-mode-map "\C-c\C-o" 'comint-kill-output)
+ (define-key comint-mode-map "\C-cr" 'comint-previous-input-matching)
+ (define-key comint-mode-map "\C-c\C-r" 'comint-show-output)
+ ;;; Here's the prompt-search stuff I installed for RMS to try...
+ (define-key comint-mode-map "\eP" 'comint-msearch-input)
+ (define-key comint-mode-map "\eN" 'comint-psearch-input)
+ (define-key comint-mode-map "\C-cR" 'comint-msearch-input-matching))
+
+
+;;; This function is used to make a full copy of the comint mode map,
+;;; so that client modes won't interfere with each other. This function
+;;; isn't necessary in emacs 18.5x, but we keep it around for 18.4x versions.
+(defun full-copy-sparse-keymap (km)
+ "Recursively copy the sparse keymap KM"
+ (cond ((consp km)
+ (cons (full-copy-sparse-keymap (car km))
+ (full-copy-sparse-keymap (cdr km))))
+ (t km)))
+
+(defun comint-check-proc (buffer-name)
+ "True if there is a process associated w/buffer BUFFER-NAME, and
+it is alive (status RUN or STOP)."
+ (let ((proc (get-buffer-process buffer-name)))
+ (and proc (memq (process-status proc) '(run stop)))))
+
+;;; Note that this guy, unlike shell.el's make-shell, barfs if you pass it ()
+;;; for the second argument (program).
+(defun make-comint (name program &optional startfile &rest switches)
+ (let* ((buffer (get-buffer-create (concat "*" name "*")))
+ (proc (get-buffer-process buffer)))
+ ;; If no process, or nuked process, crank up a new one and put buffer in
+ ;; comint mode. Otherwise, leave buffer and existing process alone.
+ (cond ((or (not proc) (not (memq (process-status proc) '(run stop))))
+ (save-excursion
+ (set-buffer buffer)
+ (comint-mode)) ; Install local vars, mode, keymap, ...
+ (comint-exec buffer name program startfile switches)))
+ buffer))
+
+(defvar comint-ptyp t
+ "True if communications via pty; false if by pipe. Buffer local.
+This is to work around a bug in emacs process signalling.")
+
+(defun comint-exec (buffer name command startfile switches)
+ "Fires up a process in buffer for comint modes.
+Blasts any old process running in the buffer. Doesn't set the buffer mode.
+You can use this to cheaply run a series of processes in the same comint
+buffer."
+ (save-excursion
+ (set-buffer buffer)
+ (let ((proc (get-buffer-process buffer))) ; Blast any old process.
+ (if proc (delete-process proc)))
+ ;; Crank up a new process
+ (let ((proc (comint-exec-1 name buffer command switches)))
+ (make-local-variable 'comint-ptyp)
+ (setq comint-ptyp process-connection-type) ; T if pty, NIL if pipe.
+ ;; Jump to the end, and set the process mark.
+ (goto-char (point-max))
+ (set-marker (process-mark proc) (point)))
+ ;; Feed it the startfile.
+ (cond (startfile
+ ;;This is guaranteed to wait long enough
+ ;;but has bad results if the comint does not prompt at all
+ ;; (while (= size (buffer-size))
+ ;; (sleep-for 1))
+ ;;I hope 1 second is enough!
+ (sleep-for 1)
+ (goto-char (point-max))
+ (insert-file-contents startfile)
+ (setq startfile (buffer-substring (point) (point-max)))
+ (delete-region (point) (point-max))
+ (comint-send-string proc startfile)))
+ buffer))
+
+;;; This auxiliary function cranks up the process for comint-exec in
+;;; the appropriate environment. It is twice as long as it should be
+;;; because emacs has two distinct mechanisms for manipulating the
+;;; process environment, selected at compile time with the
+;;; MAINTAIN-ENVIRONMENT #define. In one case, process-environment
+;;; is bound; in the other it isn't.
+
+(defun comint-exec-1 (name buffer command switches)
+ (if (boundp 'process-environment) ; Not a completely reliable test.
+ (let ((process-environment
+ (comint-update-env process-environment
+ (list (format "TERMCAP=emacs:co#%d:tc=unknown"
+ (screen-width))
+ "TERM=emacs"
+ "EMACS=t"))))
+ (apply 'start-process name buffer command switches))
+
+ (let ((tcapv (getenv "TERMCAP"))
+ (termv (getenv "TERM"))
+ (emv (getenv "EMACS")))
+ (unwind-protect
+ (progn (setenv "TERMCAP" (format "emacs:co#%d:tc=unknown"
+ (screen-width)))
+ (setenv "TERM" "emacs")
+ (setenv "EMACS" "t")
+ (apply 'start-process name buffer command switches))
+ (setenv "TERMCAP" tcapv)
+ (setenv "TERM" termv)
+ (setenv "EMACS" emv)))))
+
+
+
+;; This is just (append new old-env) that compresses out shadowed entries.
+;; It's also pretty ugly, mostly due to elisp's horrible iteration structures.
+(defun comint-update-env (old-env new)
+ (let ((ans (reverse new))
+ (vars (mapcar (function (lambda (vv)
+ (and (string-match "^[^=]*=" vv)
+ (substring vv 0 (match-end 0)))))
+ new)))
+ (while old-env
+ (let* ((vv (car old-env)) ; vv is var=value
+ (var (and (string-match "^[^=]*=" vv)
+ (substring vv 0 (match-end 0)))))
+ (setq old-env (cdr old-env))
+ (cond ((not (and var (comint-mem var vars)))
+ (if var (setq var (cons var vars)))
+ (setq ans (cons vv ans))))))
+ (nreverse ans)))
+
+;;; This should be in emacs, but it isn't.
+(defun comint-mem (item list &optional elt=)
+ "Test to see if ITEM is equal to an item in LIST.
+Option comparison function ELT= defaults to equal."
+ (let ((elt= (or elt= (function equal)))
+ (done nil))
+ (while (and list (not done))
+ (if (funcall elt= item (car list))
+ (setq done list)
+ (setq list (cdr list))))
+ done))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+;;; Ring Code
+;;;============================================================================
+;;; This code defines a ring data structure. A ring is a
+;;; (hd-index tl-index . vector)
+;;; list. You can insert to, remove from, and rotate a ring. When the ring
+;;; fills up, insertions cause the oldest elts to be quietly dropped.
+;;;
+;;; HEAD = index of the newest item on the ring.
+;;; TAIL = index of the oldest item on the ring.
+;;;
+;;; These functions are used by the input history mechanism, but they can
+;;; be used for other purposes as well.
+
+(defun ring-p (x)
+ "T if X is a ring; NIL otherwise."
+ (and (consp x) (integerp (car x))
+ (consp (cdr x)) (integerp (car (cdr x)))
+ (vectorp (cdr (cdr x)))))
+
+(defun make-ring (size)
+ "Make a ring that can contain SIZE elts"
+ (cons 1 (cons 0 (make-vector (+ size 1) nil))))
+
+(defun ring-plus1 (index veclen)
+ "INDEX+1, with wraparound"
+ (let ((new-index (+ index 1)))
+ (if (= new-index veclen) 0 new-index)))
+
+(defun ring-minus1 (index veclen)
+ "INDEX-1, with wraparound"
+ (- (if (= 0 index) veclen index) 1))
+
+(defun ring-length (ring)
+ "Number of elts in the ring."
+ (let ((hd (car ring)) (tl (car (cdr ring))) (siz (length (cdr (cdr ring)))))
+ (let ((len (if (<= hd tl) (+ 1 (- tl hd)) (+ 1 tl (- siz hd)))))
+ (if (= len siz) 0 len))))
+
+(defun ring-empty-p (ring)
+ (= 0 (ring-length ring)))
+
+(defun ring-insert (ring item)
+ "Insert a new item onto the ring. If the ring is full, dump the oldest
+item to make room."
+ (let* ((vec (cdr (cdr ring))) (len (length vec))
+ (new-hd (ring-minus1 (car ring) len)))
+ (setcar ring new-hd)
+ (aset vec new-hd item)
+ (if (ring-empty-p ring) ;overflow -- dump one off the tail.
+ (setcar (cdr ring) (ring-minus1 (car (cdr ring)) len)))))
+
+(defun ring-remove (ring)
+ "Remove the oldest item retained on the ring."
+ (if (ring-empty-p ring) (error "Ring empty")
+ (let ((tl (car (cdr ring))) (vec (cdr (cdr ring))))
+ (set-car (cdr ring) (ring-minus1 tl (length vec)))
+ (aref vec tl))))
+
+;;; This isn't actually used in this package. I just threw it in in case
+;;; someone else wanted it. If you want rotating-ring behavior on your history
+;;; retrieval (analagous to kill ring behavior), this function is what you
+;;; need. I should write the yank-input and yank-pop-input-or-kill to go with
+;;; this, and not bind it to a key by default, so it would be available to
+;;; people who want to bind it to a key. But who would want it? Blech.
+(defun ring-rotate (ring n)
+ (if (not (= n 0))
+ (if (ring-empty-p ring) ;Is this the right error check?
+ (error "ring empty")
+ (let ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring))))
+ (let ((len (length vec)))
+ (while (> n 0)
+ (setq tl (ring-plus1 tl len))
+ (aset ring tl (aref ring hd))
+ (setq hd (ring-plus1 hd len))
+ (setq n (- n 1)))
+ (while (< n 0)
+ (setq hd (ring-minus1 hd len))
+ (aset vec hd (aref vec tl))
+ (setq tl (ring-minus1 tl len))
+ (setq n (- n 1))))
+ (set-car ring hd)
+ (set-car (cdr ring) tl)))))
+
+(defun comint-mod (n m)
+ "Returns N mod M. M is positive. Answer is guaranteed to be non-negative,
+and less than m."
+ (let ((n (% n m)))
+ (if (>= n 0) n
+ (+ n
+ (if (>= m 0) m (- m)))))) ; (abs m)
+
+(defun ring-ref (ring index)
+ (let ((numelts (ring-length ring)))
+ (if (= numelts 0) (error "indexed empty ring")
+ (let* ((hd (car ring)) (tl (car (cdr ring))) (vec (cdr (cdr ring)))
+ (index (comint-mod index numelts))
+ (vec-index (comint-mod (+ index hd)
+ (length vec))))
+ (aref vec vec-index)))))
+
+
+;;; Input history retrieval commands
+;;; M-p -- previous input M-n -- next input
+;;; C-c r -- previous input matching
+;;; ===========================================================================
+
+(defun comint-previous-input (arg)
+ "Cycle backwards through input history."
+ (interactive "*p")
+ (let ((len (ring-length input-ring)))
+ (cond ((<= len 0)
+ (message "Empty input ring")
+ (ding))
+ ((not (comint-after-pmark-p))
+ (message "Not after process mark")
+ (ding))
+ (t
+ (cond ((eq last-command 'comint-previous-input)
+ (delete-region (mark) (point)))
+ ((eq last-command 'comint-previous-similar-input)
+ (delete-region
+ (process-mark (get-buffer-process (current-buffer)))
+ (point)))
+ (t
+ (setq input-ring-index
+ (if (> arg 0) -1
+ (if (< arg 0) 1 0)))
+ (push-mark (point))))
+ (setq input-ring-index (comint-mod (+ input-ring-index arg) len))
+ (message "%d" (1+ input-ring-index))
+ (insert (ring-ref input-ring input-ring-index))
+ (setq this-command 'comint-previous-input)))))
+
+(defun comint-next-input (arg)
+ "Cycle forwards through input history."
+ (interactive "*p")
+ (comint-previous-input (- arg)))
+
+(defvar comint-last-input-match ""
+ "Last string searched for by comint input history search, for defaulting.
+Buffer local variable.")
+
+(defun comint-previous-input-matching (str)
+ "Searches backwards through input history for substring match."
+ (interactive (let* ((last-command last-command) ; preserve around r-f-m
+ (s (read-from-minibuffer
+ (format "Command substring (default %s): "
+ comint-last-input-match))))
+ (list (if (string= s "") comint-last-input-match s))))
+; (interactive "sCommand substring: ")
+ (setq comint-last-input-match str) ; update default
+ (if (not (eq last-command 'comint-previous-input))
+ (setq input-ring-index -1))
+ (let ((str (regexp-quote str))
+ (len (ring-length input-ring))
+ (n (+ input-ring-index 1)))
+ (while (and (< n len) (not (string-match str (ring-ref input-ring n))))
+ (setq n (+ n 1)))
+ (cond ((< n len)
+ (comint-previous-input (- n input-ring-index)))
+ (t (if (eq last-command 'comint-previous-input)
+ (setq this-command 'comint-previous-input))
+ (message "Not found.")
+ (ding)))))
+
+
+;;; These next three commands are alternatives to the input history commands --
+;;; comint-next-input, comint-previous-input and
+;;; comint-previous-input-matching. They search through the process buffer
+;;; text looking for occurrences of the prompt. RMS likes them better;
+;;; I don't. Bound to M-P, M-N, and C-c R (uppercase P, N, and R) for
+;;; now. Try'em out. Go with what you like...
+
+;;; comint-msearch-input-matching prompts for a string, not a regexp.
+;;; This could be considered to be the wrong thing. I decided to keep it
+;;; simple, and not make the user worry about regexps. This, of course,
+;;; limits functionality.
+
+(defun comint-psearch-input ()
+ "Search forwards for next occurrence of prompt and skip to end of line.
+\(prompt is anything matching regexp comint-prompt-regexp)"
+ (interactive)
+ (if (re-search-forward comint-prompt-regexp (point-max) t)
+ (end-of-line)
+ (error "No occurrence of prompt found")))
+
+(defun comint-msearch-input ()
+ "Search backwards for previous occurrence of prompt and skip to end of line.
+Search starts from beginning of current line."
+ (interactive)
+ (let ((p (save-excursion
+ (beginning-of-line)
+ (cond ((re-search-backward comint-prompt-regexp (point-min) t)
+ (end-of-line)
+ (point))
+ (t nil)))))
+ (if p (goto-char p)
+ (error "No occurrence of prompt found"))))
+
+(defun comint-msearch-input-matching (str)
+ "Search backwards for occurrence of prompt followed by STRING.
+STRING is prompted for, and is NOT a regular expression."
+ (interactive (let ((s (read-from-minibuffer
+ (format "Command (default %s): "
+ comint-last-input-match))))
+ (list (if (string= s "") comint-last-input-match s))))
+; (interactive "sCommand: ")
+ (setq comint-last-input-match str) ; update default
+ (let* ((r (concat comint-prompt-regexp (regexp-quote str)))
+ (p (save-excursion
+ (beginning-of-line)
+ (cond ((re-search-backward r (point-min) t)
+ (end-of-line)
+ (point))
+ (t nil)))))
+ (if p (goto-char p)
+ (error "No match"))))
+
+;;;
+;;; Similar input -- contributed by ccm and highly winning.
+;;;
+;;; Reenter input, removing back to the last insert point if it exists.
+;;;
+(defvar comint-last-similar-string ""
+ "The string last used in a similar string search.")
+(defun comint-previous-similar-input (arg)
+ "Reenters the last input that matches the string typed so far. If repeated
+successively older inputs are reentered. If arg is 1, it will go back
+in the history, if -1 it will go forward."
+ (interactive "p")
+ (if (not (comint-after-pmark-p))
+ (error "Not after process mark"))
+ (if (not (eq last-command 'comint-previous-similar-input))
+ (setq input-ring-index -1
+ comint-last-similar-string
+ (buffer-substring
+ (process-mark (get-buffer-process (current-buffer)))
+ (point))))
+ (let* ((size (length comint-last-similar-string))
+ (len (ring-length input-ring))
+ (n (+ input-ring-index arg))
+ entry)
+ (while (and (< n len)
+ (or (< (length (setq entry (ring-ref input-ring n))) size)
+ (not (equal comint-last-similar-string
+ (substring entry 0 size)))))
+ (setq n (+ n arg)))
+ (cond ((< n len)
+ (setq input-ring-index n)
+ (if (eq last-command 'comint-previous-similar-input)
+ (delete-region (mark) (point)) ; repeat
+ (push-mark (point))) ; 1st time
+ (insert (substring entry size)))
+ (t (message "Not found.") (ding) (sit-for 1)))
+ (message "%d" (1+ input-ring-index))))
+
+
+
+
+
+
+
+
+
+(defun comint-send-input ()
+ "Send input to process. After the process output mark, sends all text
+from the process mark to point as input to the process. Before the
+process output mark, calls value of variable comint-get-old-input to retrieve
+old input, copies it to the end of the buffer, and sends it. A terminal
+newline is also inserted into the buffer and sent to the process. In either
+case, value of variable comint-input-sentinel is called on the input before
+sending it. The input is entered into the input history ring, if value of
+variable comint-input-filter returns non-nil when called on the input.
+
+If variable comint-eol-on-send is non-nil, then point is moved to the end of
+line before sending the input.
+
+comint-get-old-input, comint-input-sentinel, and comint-input-filter are chosen
+according to the command interpreter running in the buffer. E.g.,
+If the interpreter is the csh,
+ comint-get-old-input is the default: take the current line, discard any
+ initial string matching regexp comint-prompt-regexp.
+ comint-input-sentinel monitors input for \"cd\", \"pushd\", and \"popd\"
+ commands. When it sees one, it cd's the buffer.
+ comint-input-filter is the default: returns T if the input isn't all white
+ space.
+
+If the comint is Lucid Common Lisp,
+ comint-get-old-input snarfs the sexp ending at point.
+ comint-input-sentinel does nothing.
+ comint-input-filter returns NIL if the input matches input-filter-regexp,
+ which matches (1) all whitespace (2) :a, :c, etc.
+
+Similarly for Soar, Scheme, etc.."
+ (interactive)
+ ;; Note that the input string does not include its terminal newline.
+ (let ((proc (get-buffer-process (current-buffer))))
+ (if (not proc) (error "Current buffer has no process")
+ (let* ((pmark (process-mark proc))
+ (pmark-val (marker-position pmark))
+ (input (if (>= (point) pmark-val)
+ (progn (if comint-eol-on-send (end-of-line))
+ (buffer-substring pmark (point)))
+ (let ((copy (funcall comint-get-old-input)))
+ (goto-char pmark)
+ (insert copy)
+ copy))))
+ (insert ?\n)
+ (if (funcall comint-input-filter input) (ring-insert input-ring input))
+ (funcall comint-input-sentinel input)
+ (funcall comint-input-sender proc input)
+ (set-marker (process-mark proc) (point))
+ (set-marker comint-last-input-end (point))))))
+
+(defun comint-get-old-input-default ()
+ "Default for comint-get-old-input: take the current line, and discard
+any initial text matching comint-prompt-regexp."
+ (save-excursion
+ (beginning-of-line)
+ (comint-skip-prompt)
+ (let ((beg (point)))
+ (end-of-line)
+ (buffer-substring beg (point)))))
+
+(defun comint-skip-prompt ()
+ "Skip past the text matching regexp comint-prompt-regexp.
+If this takes us past the end of the current line, don't skip at all."
+ (let ((eol (save-excursion (end-of-line) (point))))
+ (if (and (looking-at comint-prompt-regexp)
+ (<= (match-end 0) eol))
+ (goto-char (match-end 0)))))
+
+
+(defun comint-after-pmark-p ()
+ "Is point after the process output marker?"
+ ;; Since output could come into the buffer after we looked at the point
+ ;; but before we looked at the process marker's value, we explicitly
+ ;; serialise. This is just because I don't know whether or not emacs
+ ;; services input during execution of lisp commands.
+ (let ((proc-pos (marker-position
+ (process-mark (get-buffer-process (current-buffer))))))
+ (<= proc-pos (point))))
+
+(defun comint-simple-send (proc string)
+ "Default function for sending to PROC input STRING.
+This just sends STRING plus a newline. To override this,
+set the hook COMINT-INPUT-SENDER."
+ (comint-send-string proc string)
+ (comint-send-string proc "\n"))
+
+(defun comint-bol (arg)
+ "Goes to the beginning of line, then skips past the prompt, if any.
+If a prefix argument is given (\\[universal-argument]), then no prompt skip
+-- go straight to column 0.
+
+The prompt skip is done by skipping text matching the regular expression
+comint-prompt-regexp, a buffer local variable.
+
+If you don't like this command, reset c-a to beginning-of-line
+in your hook, comint-mode-hook."
+ (interactive "P")
+ (beginning-of-line)
+ (if (null arg) (comint-skip-prompt)))
+
+;;; These two functions are for entering text you don't want echoed or
+;;; saved -- typically passwords to ftp, telnet, or somesuch.
+;;; Just enter m-x send-invisible and type in your line.
+
+(defun comint-read-noecho (prompt)
+ "Prompt the user with argument PROMPT. Read a single line of text
+without echoing, and return it. Note that the keystrokes comprising
+the text can still be recovered (temporarily) with \\[view-lossage]. This
+may be a security bug for some applications."
+ (let ((echo-keystrokes 0)
+ (answ "")
+ tem)
+ (if (and (stringp prompt) (not (string= (message prompt) "")))
+ (message prompt))
+ (while (not(or (= (setq tem (read-char)) ?\^m)
+ (= tem ?\n)))
+ (setq answ (concat answ (char-to-string tem))))
+ (message "")
+ answ))
+
+(defun send-invisible (str)
+ "Read a string without echoing, and send it to the process running
+in the current buffer. A new-line is additionally sent. String is not
+saved on comint input history list.
+Security bug: your string can still be temporarily recovered with
+\\[view-lossage]."
+; (interactive (list (comint-read-noecho "Enter non-echoed text")))
+ (interactive "P") ; Defeat snooping via C-x esc
+ (let ((proc (get-buffer-process (current-buffer))))
+ (if (not proc) (error "Current buffer has no process")
+ (comint-send-string proc
+ (if (stringp str) str
+ (comint-read-noecho "Enter non-echoed text")))
+ (comint-send-string proc "\n"))))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+;;; Low-level process communication
+
+(defvar comint-input-chunk-size 512
+ "*Long inputs send to comint processes are broken up into chunks of this size.
+If your process is choking on big inputs, try lowering the value.")
+
+(defun comint-send-string (proc str)
+ "Send PROCESS the contents of STRING as input.
+This is equivalent to process-send-string, except that long input strings
+are broken up into chunks of size comint-input-chunk-size. Processes
+are given a chance to output between chunks. This can help prevent processes
+from hanging when you send them long inputs on some OS's."
+ (let* ((len (length str))
+ (i (min len comint-input-chunk-size)))
+ (process-send-string proc (substring str 0 i))
+ (while (< i len)
+ (let ((next-i (+ i comint-input-chunk-size)))
+ (accept-process-output)
+ (process-send-string proc (substring str i (min len next-i)))
+ (setq i next-i)))))
+
+(defun comint-send-region (proc start end)
+ "Sends to PROC the region delimited by START and END.
+This is a replacement for process-send-region that tries to keep
+your process from hanging on long inputs. See comint-send-string."
+ (comint-send-string proc (buffer-substring start end)))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+;;; Random input hackage
+
+(defun comint-kill-output ()
+ "Kill all output from interpreter since last input."
+ (interactive)
+ (let ((pmark (process-mark (get-buffer-process (current-buffer)))))
+ (kill-region comint-last-input-end pmark)
+ (goto-char pmark)
+ (insert "*** output flushed ***\n")
+ (set-marker pmark (point))))
+
+(defun comint-show-output ()
+ "Display start of this batch of interpreter output at top of window.
+Also put cursor there."
+ (interactive)
+ (goto-char comint-last-input-end)
+ (backward-char)
+ (beginning-of-line)
+ (set-window-start (selected-window) (point))
+ (end-of-line))
+
+(defun comint-interrupt-subjob ()
+ "Interrupt the current subjob."
+ (interactive)
+ (interrupt-process nil comint-ptyp))
+
+(defun comint-kill-subjob ()
+ "Send kill signal to the current subjob."
+ (interactive)
+ (kill-process nil comint-ptyp))
+
+(defun comint-quit-subjob ()
+ "Send quit signal to the current subjob."
+ (interactive)
+ (quit-process nil comint-ptyp))
+
+(defun comint-stop-subjob ()
+ "Stop the current subjob.
+WARNING: if there is no current subjob, you can end up suspending
+the top-level process running in the buffer. If you accidentally do
+this, use \\[comint-continue-subjob] to resume the process. (This
+is not a problem with most shells, since they ignore this signal.)"
+ (interactive)
+ (stop-process nil comint-ptyp))
+
+(defun comint-continue-subjob ()
+ "Send CONT signal to process buffer's process group.
+Useful if you accidentally suspend the top-level process."
+ (interactive)
+ (continue-process nil comint-ptyp))
+
+(defun comint-kill-input ()
+ "Kill all text from last stuff output by interpreter to point."
+ (interactive)
+ (let* ((pmark (process-mark (get-buffer-process (current-buffer))))
+ (p-pos (marker-position pmark)))
+ (if (> (point) p-pos)
+ (kill-region pmark (point)))))
+
+(defun comint-delchar-or-maybe-eof (arg)
+ "Delete ARG characters forward, or send an EOF to process if at end of buffer."
+ (interactive "p")
+ (if (eobp)
+ (process-send-eof)
+ (delete-char arg)))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+;;; Support for source-file processing commands.
+;;;============================================================================
+;;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have
+;;; commands that process files of source text (e.g. loading or compiling
+;;; files). So the corresponding process-in-a-buffer modes have commands
+;;; for doing this (e.g., lisp-load-file). The functions below are useful
+;;; for defining these commands.
+;;;
+;;; Alas, these guys don't do exactly the right thing for Lisp, Scheme
+;;; and Soar, in that they don't know anything about file extensions.
+;;; So the compile/load interface gets the wrong default occasionally.
+;;; The load-file/compile-file default mechanism could be smarter -- it
+;;; doesn't know about the relationship between filename extensions and
+;;; whether the file is source or executable. If you compile foo.lisp
+;;; with compile-file, then the next load-file should use foo.bin for
+;;; the default, not foo.lisp. This is tricky to do right, particularly
+;;; because the extension for executable files varies so much (.o, .bin,
+;;; .lbin, .mo, .vo, .ao, ...).
+
+
+;;; COMINT-SOURCE-DEFAULT -- determines defaults for source-file processing
+;;; commands.
+;;;
+;;; COMINT-CHECK-SOURCE -- if FNAME is in a modified buffer, asks you if you
+;;; want to save the buffer before issuing any process requests to the command
+;;; interpreter.
+;;;
+;;; COMINT-GET-SOURCE -- used by the source-file processing commands to prompt
+;;; for the file to process.
+
+;;; (COMINT-SOURCE-DEFAULT previous-dir/file source-modes)
+;;;============================================================================
+;;; This function computes the defaults for the load-file and compile-file
+;;; commands for tea, soar, cmulisp, and cmuscheme modes.
+;;;
+;;; - PREVIOUS-DIR/FILE is a pair (directory . filename) from the last
+;;; source-file processing command. NIL if there hasn't been one yet.
+;;; - SOURCE-MODES is a list used to determine what buffers contain source
+;;; files: if the major mode of the buffer is in SOURCE-MODES, it's source.
+;;; Typically, (lisp-mode) or (scheme-mode).
+;;;
+;;; If the command is given while the cursor is inside a string, *and*
+;;; the string is an existing filename, *and* the filename is not a directory,
+;;; then the string is taken as default. This allows you to just position
+;;; your cursor over a string that's a filename and have it taken as default.
+;;;
+;;; If the command is given in a file buffer whose major mode is in
+;;; SOURCE-MODES, then the the filename is the default file, and the
+;;; file's directory is the default directory.
+;;;
+;;; If the buffer isn't a source file buffer (e.g., it's the process buffer),
+;;; then the default directory & file are what was used in the last source-file
+;;; processing command (i.e., PREVIOUS-DIR/FILE). If this is the first time
+;;; the command has been run (PREVIOUS-DIR/FILE is nil), the default directory
+;;; is the cwd, with no default file. (\"no default file\" = nil)
+;;;
+;;; SOURCE-REGEXP is typically going to be something like (tea-mode)
+;;; for T programs, (lisp-mode) for Lisp programs, (soar-mode lisp-mode)
+;;; for Soar programs, etc.
+;;;
+;;; The function returns a pair: (default-directory . default-file).
+
+(defun comint-source-default (previous-dir/file source-modes)
+ (cond ((and buffer-file-name (memq major-mode source-modes))
+ (cons (file-name-directory buffer-file-name)
+ (file-name-nondirectory buffer-file-name)))
+ (previous-dir/file)
+ (t
+ (cons default-directory nil))))
+
+
+;;; (COMINT-CHECK-SOURCE fname)
+;;;============================================================================
+;;; Prior to loading or compiling (or otherwise processing) a file (in the CMU
+;;; process-in-a-buffer modes), this function can be called on the filename.
+;;; If the file is loaded into a buffer, and the buffer is modified, the user
+;;; is queried to see if he wants to save the buffer before proceeding with
+;;; the load or compile.
+
+(defun comint-check-source (fname)
+ (let ((buff (get-file-buffer fname)))
+ (if (and buff
+ (buffer-modified-p buff)
+ (y-or-n-p (format "Save buffer %s first? "
+ (buffer-name buff))))
+ ;; save BUFF.
+ (let ((old-buffer (current-buffer)))
+ (set-buffer buff)
+ (save-buffer)
+ (set-buffer old-buffer)))))
+
+
+;;; (COMINT-GET-SOURCE prompt prev-dir/file source-modes mustmatch-p)
+;;;============================================================================
+;;; COMINT-GET-SOURCE is used to prompt for filenames in command-interpreter
+;;; commands that process source files (like loading or compiling a file).
+;;; It prompts for the filename, provides a default, if there is one,
+;;; and returns the result filename.
+;;;
+;;; See COMINT-SOURCE-DEFAULT for more on determining defaults.
+;;;
+;;; PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair
+;;; from the last source processing command. SOURCE-MODES is a list of major
+;;; modes used to determine what file buffers contain source files. (These
+;;; two arguments are used for determining defaults). If MUSTMATCH-P is true,
+;;; then the filename reader will only accept a file that exists.
+;;;
+;;; A typical use:
+;;; (interactive (comint-get-source "Compile file: " prev-lisp-dir/file
+;;; '(lisp-mode) t))
+
+;;; This is pretty stupid about strings. It decides we're in a string
+;;; if there's a quote on both sides of point on the current line.
+(defun comint-extract-string ()
+ "Returns string around point that starts the current line or nil."
+ (save-excursion
+ (let* ((point (point))
+ (bol (progn (beginning-of-line) (point)))
+ (eol (progn (end-of-line) (point)))
+ (start (progn (goto-char point)
+ (and (search-backward "\"" bol t)
+ (1+ (point)))))
+ (end (progn (goto-char point)
+ (and (search-forward "\"" eol t)
+ (1- (point))))))
+ (and start end
+ (buffer-substring start end)))))
+
+(defun comint-get-source (prompt prev-dir/file source-modes mustmatch-p)
+ (let* ((def (comint-source-default prev-dir/file source-modes))
+ (stringfile (comint-extract-string))
+ (sfile-p (and stringfile
+ (file-exists-p stringfile)
+ (not (file-directory-p stringfile))))
+ (defdir (if sfile-p (file-name-directory stringfile)
+ (car def)))
+ (deffile (if sfile-p (file-name-nondirectory stringfile)
+ (cdr def)))
+ (ans (read-file-name (if deffile (format "%s(default %s) "
+ prompt deffile)
+ prompt)
+ defdir
+ (concat defdir deffile)
+ mustmatch-p)))
+ (list (expand-file-name (substitute-in-file-name ans)))))
+
+;;; I am somewhat divided on this string-default feature. It seems
+;;; to violate the principle-of-least-astonishment, in that it makes
+;;; the default harder to predict, so you actually have to look and see
+;;; what the default really is before choosing it. This can trip you up.
+;;; On the other hand, it can be useful, I guess. I would appreciate feedback
+;;; on this.
+;;; -Olin
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+;;; Simple process query facility.
+;;; ===========================================================================
+;;; This function is for commands that want to send a query to the process
+;;; and show the response to the user. For example, a command to get the
+;;; arglist for a Common Lisp function might send a "(arglist 'foo)" query
+;;; to an inferior Common Lisp process.
+;;;
+;;; This simple facility just sends strings to the inferior process and pops
+;;; up a window for the process buffer so you can see what the process
+;;; responds with. We don't do anything fancy like try to intercept what the
+;;; process responds with and put it in a pop-up window or on the message
+;;; line. We just display the buffer. Low tech. Simple. Works good.
+
+;;; Send to the inferior process PROC the string STR. Pop-up but do not select
+;;; a window for the inferior process so that its response can be seen.
+(defun comint-proc-query (proc str)
+ (let* ((proc-buf (process-buffer proc))
+ (proc-mark (process-mark proc)))
+ (display-buffer proc-buf)
+ (set-buffer proc-buf) ; but it's not the selected *window*
+ (let ((proc-win (get-buffer-window proc-buf))
+ (proc-pt (marker-position proc-mark)))
+ (comint-send-string proc str) ; send the query
+ (accept-process-output proc) ; wait for some output
+ ;; Try to position the proc window so you can see the answer.
+ ;; This is bogus code. If you delete the (sit-for 0), it breaks.
+ ;; I don't know why. Wizards invited to improve it.
+ (if (not (pos-visible-in-window-p proc-pt proc-win))
+ (let ((opoint (window-point proc-win)))
+ (set-window-point proc-win proc-mark) (sit-for 0)
+ (if (not (pos-visible-in-window-p opoint proc-win))
+ (push-mark opoint)
+ (set-window-point proc-win opoint)))))))
+
+
+
+
+
+
+
+
+
+
+
+;;; Filename completion in a buffer
+;;; ===========================================================================
+;;; Useful completion functions, courtesy of the Ergo group.
+;;; M-<Tab> will complete the filename at the cursor as much as possible
+;;; M-? will display a list of completions in the help buffer.
+
+;;; Three commands:
+;;; comint-dynamic-complete Complete filename at point.
+;;; comint-dynamic-list-completions List completions in help buffer.
+;;; comint-replace-by-expanded-filename Expand and complete filename at point;
+;;; replace with expanded/completed name.
+
+;;; These are not installed in the comint-mode keymap. But they are
+;;; available for people who want them. Shell-mode installs them:
+;;; (define-key cmushell-mode-map "\M-\t" 'comint-dynamic-complete)
+;;; (define-key cmushell-mode-map "\M-?" 'comint-dynamic-list-completions)))
+;;;
+;;; Commands like this are fine things to put in load hooks if you
+;;; want them present in specific modes. Example:
+;;; (setq cmushell-load-hook
+;;; '((lambda () (define-key lisp-mode-map "\M-\t"
+;;; 'comint-replace-by-expanded-filename))))
+;;;
+
+
+(defun comint-match-partial-pathname ()
+ "Returns the string of an existing filename or causes an error."
+ (if (save-excursion (backward-char 1) (looking-at "\\s ")) ""
+ (save-excursion
+ (re-search-backward "[^~/A-Za-z0-9---_.$#,]+")
+ (re-search-forward "[~/A-Za-z0-9---_.$#,]+")
+ (substitute-in-file-name
+ (buffer-substring (match-beginning 0) (match-end 0))))))
+
+
+(defun comint-replace-by-expanded-filename ()
+"Replace the filename at point with an expanded, canonicalised, and
+completed replacement.
+\"Expanded\" means environment variables (e.g., $HOME) and ~'s are
+replaced with the corresponding directories. \"Canonicalised\" means ..
+and \. are removed, and the filename is made absolute instead of relative.
+See functions expand-file-name and substitute-in-file-name. See also
+comint-dynamic-complete."
+ (interactive)
+ (let* ((pathname (comint-match-partial-pathname))
+ (pathdir (file-name-directory pathname))
+ (pathnondir (file-name-nondirectory pathname))
+ (completion (file-name-completion pathnondir
+ (or pathdir default-directory))))
+ (cond ((null completion)
+ (message "No completions of %s." pathname)
+ (ding))
+ ((eql completion t)
+ (message "Unique completion."))
+ (t ; this means a string was returned.
+ (delete-region (match-beginning 0) (match-end 0))
+ (insert (expand-file-name (concat pathdir completion)))))))
+
+
+(defun comint-dynamic-complete ()
+ "Dynamically complete the filename at point.
+This function is similar to comint-replace-by-expanded-filename, except
+that it won't change parts of the filename already entered in the buffer;
+it just adds completion characters to the end of the filename."
+ (interactive)
+ (let* ((pathname (comint-match-partial-pathname))
+ (pathdir (file-name-directory pathname))
+ (pathnondir (file-name-nondirectory pathname))
+ (completion (file-name-completion pathnondir
+ (or pathdir default-directory))))
+ (cond ((null completion)
+ (message "No completions of %s." pathname)
+ (ding))
+ ((eql completion t)
+ (message "Unique completion."))
+ (t ; this means a string was returned.
+ (goto-char (match-end 0))
+ (insert (substring completion (length pathnondir)))))))
+
+(defun comint-dynamic-list-completions ()
+ "List in help buffer all possible completions of the filename at point."
+ (interactive)
+ (let* ((pathname (comint-match-partial-pathname))
+ (pathdir (file-name-directory pathname))
+ (pathnondir (file-name-nondirectory pathname))
+ (completions
+ (file-name-all-completions pathnondir
+ (or pathdir default-directory))))
+ (cond ((null completions)
+ (message "No completions of %s." pathname)
+ (ding))
+ (t
+ (let ((conf (current-window-configuration)))
+ (with-output-to-temp-buffer "*Help*"
+ (display-completion-list completions))
+ (sit-for 0)
+ (message "Hit space to flush.")
+ (let ((ch (read-char)))
+ (if (= ch ?\ )
+ (set-window-configuration conf)
+ (setq unread-command-char ch))))))))
+
+; Ergo bindings
+; (global-set-key "\M-\t" 'comint-replace-by-expanded-filename)
+; (global-set-key "\M-?" 'comint-dynamic-list-completions)
+; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete)
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+;;; Converting process modes to use comint mode
+;;; ===========================================================================
+;;; Several gnu packages (tex-mode, background, dbx, gdb, kermit, prolog,
+;;; telnet are some) use the shell package as clients. Most of them would
+;;; be better off using the comint package, but they predate it.
+;;;
+;;; Altering these packages to use comint mode should greatly
+;;; improve their functionality, and is fairly easy.
+;;;
+;;; Renaming variables
+;;; Most of the work is renaming variables and functions. These are the common
+;;; ones:
+;;; Local variables:
+;;; last-input-end comint-last-input-end
+;;; last-input-start <unnecessary>
+;;; shell-prompt-pattern comint-prompt-regexp
+;;; shell-set-directory-error-hook <no equivalent>
+;;; Miscellaneous:
+;;; shell-set-directory <unnecessary>
+;;; shell-mode-map comint-mode-map
+;;; Commands:
+;;; shell-send-input comint-send-input
+;;; shell-send-eof comint-delchar-or-maybe-eof
+;;; kill-shell-input comint-kill-input
+;;; interrupt-shell-subjob comint-interrupt-subjob
+;;; stop-shell-subjob comint-stop-subjob
+;;; quit-shell-subjob comint-quit-subjob
+;;; kill-shell-subjob comint-kill-subjob
+;;; kill-output-from-shell comint-kill-output
+;;; show-output-from-shell comint-show-output
+;;; copy-last-shell-input Use comint-previous-input/comint-next-input
+;;;
+;;; LAST-INPUT-START is no longer necessary because inputs are stored on the
+;;; input history ring. SHELL-SET-DIRECTORY is gone, its functionality taken
+;;; over by SHELL-DIRECTORY-TRACKER, the shell mode's comint-input-sentinel.
+;;; Comint mode does not provide functionality equivalent to
+;;; shell-set-directory-error-hook; it is gone.
+;;;
+;;; If you are implementing some process-in-a-buffer mode, called foo-mode, do
+;;; *not* create the comint-mode local variables in your foo-mode function.
+;;; This is not modular. Instead, call comint-mode, and let *it* create the
+;;; necessary comint-specific local variables. Then create the
+;;; foo-mode-specific local variables in foo-mode. Set the buffer's keymap to
+;;; be foo-mode-map, and its mode to be foo-mode. Set the comint-mode hooks
+;;; (comint-prompt-regexp, comint-input-filter, comint-input-sentinel,
+;;; comint-get-old-input) that need to be different from the defaults. Call
+;;; foo-mode-hook, and you're done. Don't run the comint-mode hook yourself;
+;;; comint-mode will take care of it. The following example, from cmushell.el,
+;;; is typical:
+;;;
+;;; (defun shell-mode ()
+;;; (interactive)
+;;; (comint-mode)
+;;; (setq comint-prompt-regexp shell-prompt-pattern)
+;;; (setq major-mode 'shell-mode)
+;;; (setq mode-name "Shell")
+;;; (cond ((not shell-mode-map)
+;;; (setq shell-mode-map (full-copy-sparse-keymap comint-mode-map))
+;;; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete)
+;;; (define-key shell-mode-map "\M-?"
+;;; 'comint-dynamic-list-completions)))
+;;; (use-local-map shell-mode-map)
+;;; (make-local-variable 'shell-directory-stack)
+;;; (setq shell-directory-stack nil)
+;;; (setq comint-input-sentinel 'shell-directory-tracker)
+;;; (run-hooks 'shell-mode-hook))
+;;;
+;;;
+;;; Note that make-comint is different from make-shell in that it
+;;; doesn't have a default program argument. If you give make-shell
+;;; a program name of NIL, it cleverly chooses one of explicit-shell-name,
+;;; $ESHELL, $SHELL, or /bin/sh. If you give make-comint a program argument
+;;; of NIL, it barfs. Adjust your code accordingly...
+;;;
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+;;; Do the user's customisation...
+
+(defvar comint-load-hook nil
+ "This hook is run when comint is loaded in.
+This is a good place to put keybindings.")
+
+(run-hooks 'comint-load-hook)
+
+;;; Change log:
+;;; 9/12/89
+;;; - Souped up the filename expansion procedures.
+;;; Doc strings are much clearer and more detailed.
+;;; Fixed a bug where doing a filename completion when the point
+;;; was in the middle of the filename instead of at the end would lose.
+;;;
+;;; 2/17/90
+;;; - Souped up the command history stuff so that text inserted
+;;; by comint-previous-input-matching is removed by following
+;;; command history recalls. comint-next/previous-input-matching
+;;; is now much more smoothly integrated w/the command history stuff.
+;;; - Added comint-eol-on-send flag and comint-input-sender hook.
+;;; Comint-input-sender based on code contributed by Jeff Peck
+;;; (peck@sun.com).
+;;;
+;;; 3/13/90 ccm@cmu.cs.edu
+;;; - Added comint-previous-similar-input for looking up similar inputs.
+;;; - Added comint-send-and-get-output to allow snarfing input from
+;;; buffer.
+;;; - Added the ability to pick up a source file by positioning over
+;;; a string in comint-get-source.
+;;; - Added add-hook to make it a little easier for the user to use
+;;; multiple hooks.
+;;;
+;;; 5/22/90 shivers
+;;; - Moved Chris' multiplexed ipc stuff to comint-ipc.el.
+;;; - Altered Chris' comint-get-source string feature. The string
+;;; is only offered as a default if it names an existing file.
+;;; - Changed comint-exec to directly crank up the process, instead
+;;; of calling the env program. This made background.el happy.
+;;; - Added new buffer-local var comint-ptyp. The problem is that
+;;; the signalling functions don't work as advertised. If you are
+;;; communicating via pipes, the CURRENT-GROUP arg is supposed to
+;;; be ignored, but, unfortunately it seems to be the case that you
+;;; must pass a NIL for this arg in the pipe case. COMINT-PTYP
+;;; is a flag that tells whether the process is communicating
+;;; via pipes or a pty. The comint signalling functions use it
+;;; to determine the necessary CURRENT-GROUP arg value. The bug
+;;; has been reported to the Gnu folks.
+;;; - comint-dynamic-complete flushes the help window if you hit space
+;;; after you execute it.
+;;; - Added functions comint-send-string, comint-send-region and var
+;;; comint-input-chunk-size. comint-send-string tries to prevent processes
+;;; from hanging when you send them long strings by breaking them into
+;;; chunks and allowing process output between chunks. I got the idea from
+;;; Eero Simoncelli's Common Lisp package. Note that using
+;;; comint-send-string means that the process buffer's contents can change
+;;; during a call! If you depend on process output only happening between
+;;; toplevel commands, this could be a problem. In such a case, use
+;;; process-send-string instead. If this is a problem for people, I'd like
+;;; to hear about it.
+;;; - Added comint-proc-query as a simple mechanism for commands that
+;;; want to query an inferior process and display its response. For a
+;;; typical use, see lisp-show-arglist in cmulisp.el.
+;;; - Added constant comint-version, which is now "2.01".
+;;;
+;;; 6/14/90 shivers
+;;; - Had comint-update-env defined twice. Removed extra copy. Also
+;;; renamed mem to be comint-mem, for modularity. The duplication
+;;; was reported by Michael Meissner.
+;;; 6/16/90 shivers
+;;; - Emacs has two different mechanisms for maintaining the process
+;;; environment, determined at compile time by the MAINTAIN-ENVIRONMENT
+;;; #define. One uses the process-environment global variable, and
+;;; one uses a getenv/setenv interface. comint-exec assumed the
+;;; process-environment interface; it has been generalised (with
+;;; comint-exec-1) to handle both cases. Pretty bogus. We could,
+;;; of course, skip all this and just use the etc/env program to
+;;; handle the environment tweaking, but that obscures process
+;;; queries that other modules (like background.el) depend on. etc/env
+;;; is also fairly bogus. This bug, and some of the fix code was
+;;; reported by Dan Pierson.
+;;;
+;;; 9/5/90 shivers
+;;; - Changed make-variable-buffer-local's to make-local-variable's.
+;;; This leaves non-comint-mode buffers alone. Stephane Payrard
+;;; reported the sloppy useage.
+;;; - You can now go from comint-previous-similar-input to
+;;; comint-previous-input with no problem.
+
+
--- /dev/null
+;;; haskell-menu.el -- support for Haskell menubar functions
+;;;
+;;; author : Sandra Loosemore
+;;; date : 15 Jun 1994
+;;;
+
+
+;;; Add an entry to the main menu bar
+
+(defvar menu-bar-haskell-menu (make-sparse-keymap "Haskell"))
+(define-key haskell-mode-map [menu-bar haskell]
+ (cons "Haskell" menu-bar-haskell-menu))
+(define-key inferior-haskell-mode-map [menu-bar haskell]
+ (cons "Haskell" menu-bar-haskell-menu))
+(define-key ht-mode-map [menu-bar haskell]
+ (cons "Haskell" menu-bar-haskell-menu))
+
+
+;;; Define the functions. They get listed on the menu in the reverse
+;;; order that they're defined.
+
+(define-key menu-bar-haskell-menu [haskell-tutorial]
+ '("Tutorial" . haskell-tutorial))
+(define-key menu-bar-haskell-menu [haskell-optimizers]
+ '("Optimizers..." . haskell-optimizers))
+(define-key menu-bar-haskell-menu [haskell-printers]
+ '("Printers..." . haskell-printers))
+(define-key menu-bar-haskell-menu [haskell-get-pad]
+ '("Scratch Pad" . haskell-get-pad))
+(define-key menu-bar-haskell-menu [haskell-compile]
+ '("Compile File..." . haskell-compile))
+(define-key menu-bar-haskell-menu [haskell-run-file]
+ '("Run File..." . haskell-run-file))
+(define-key menu-bar-haskell-menu [haskell-load]
+ '("Load File..." . haskell-load))
+(define-key menu-bar-haskell-menu [haskell-report-type]
+ '("Type Check Expression..." . haskell-report-type))
+(define-key menu-bar-haskell-menu [haskell-run]
+ '("Run Dialogue..." . haskell-run))
+(define-key menu-bar-haskell-menu [haskell-eval]
+ '("Eval Expression..." . haskell-eval))
+
+(provide 'haskell-menu)
--- /dev/null
+;;; ==================================================================
+;;; File: haskell.el ;;;
+;;; ;;;
+;;; Author: A. Satish Pai ;;;
+;;; Maria M. Gutierrez ;;;
+;;; Dan Rabin (Jul-1991) ;;;
+;;; ==================================================================
+
+;;; Description: Haskell mode for GNU Emacs.
+
+;;; Related files: comint.el
+
+;;; Contents:
+
+;;; Update Log
+
+;;; Known bugs / problems
+;;; - the haskell editing mode (indentation, etc) is still missing.
+;;; - the handling for errors from haskell needs to be rethought.
+;;; - general cleanup of code.
+
+
+;;; Errors generated
+
+;;; ==================================================================
+;;; Haskell mode for editing files, and an Inferior Haskell mode to
+;;; run a Haskell process. This file contains stuff snarfed and
+;;; modified from tea.el, scheme.el, etc. This file may be freely
+;;; modified; however, if you have any bug-corrections or useful
+;;; improvements, I'd appreciate it if you sent me the mods so that
+;;; I can merge them into the version I maintain.
+;;;
+;;; The inferior Haskell mode requires comint.el.
+;;;
+;;; You might want to add this to your .emacs to go automagically
+;;; into Haskell mode while finding .hs files.
+;;;
+;;; (setq auto-mode-alist
+;;; (cons '("\\.hs$" . haskell-mode)
+;;; auto-mode-alist)_)
+;;;
+;;; To use this file, set up your .emacs to autoload this file for
+;;; haskell-mode. For example:
+;;;
+;;; (autoload 'haskell-mode "$HASKELL/emacs-tools/haskell.elc"
+;;; "Load Haskell mode" t)
+;;;
+;;; (autoload 'run-mode "$HASKELL/emacs-tools/haskell.elc"
+;;; "Load Haskell mode" t)
+;;;
+;;; [Note: The path name given above is Yale specific!! Modify as
+;;; required.]
+;;; ================================================================
+
+;;; Announce your existence to the world at large.
+
+(provide 'haskell)
+
+
+;;; Load these other files.
+
+(require 'comint) ; Olin Shivers' comint mode is the substratum
+
+
+
+\f
+;;; ================================================================
+;;; Declare a bunch of variables.
+;;; ================================================================
+
+
+;;; User settable (via M-x set-variable and M-x edit-options)
+
+(defvar haskell-program-name (getenv "HASKELLPROG")
+ "*Program invoked by the haskell command.")
+
+(defvar haskell-auto-create-process t
+ "*If not nil, create a Haskell process automatically when required to evaluate or compile Haskell code.")
+
+(defvar haskell-auto-switch-input t
+ "*If not nil, jump to *haskell* buffer automatically on input request.")
+
+(defvar haskell-ask-before-saving t
+ "*If not nil, ask before saving random haskell-mode buffers.")
+
+(defvar haskell-initial-printers '("interactive")
+ "*Printers to set when starting a new Haskell process.")
+
+
+;;; Pad/buffer Initialization variables
+
+(defvar *haskell-buffer* "*haskell*"
+ "Name of the haskell process buffer")
+
+(defvar haskell-main-pad "\*Main-pad\*"
+ "Scratch pad associated with module Main")
+
+(defvar haskell-main-module "Main")
+
+
+(defvar *last-loaded* nil)
+(defvar *last-module* haskell-main-module)
+(defvar *last-pad* haskell-main-pad)
+
+
+;;; These are used for haskell-tutorial mode.
+
+(defvar *ht-source-file* "$HASKELL/progs/tutorial/tutorial.lhs")
+(defvar *ht-temp-buffer* nil)
+(defvar *ht-file-buffer* "Haskell-Tutorial-Master")
+
+
+\f
+;;; ================================================================
+;;; Haskell editing mode stuff
+;;; ================================================================
+
+;;; Leave this place alone...
+;;; The definitions below have been pared down to the bare
+;;; minimum; they will be restored later.
+;;;
+;;; -Satish 2/5.
+
+;;; Keymap for Haskell mode
+(defvar haskell-mode-map (make-sparse-keymap)
+ "Keymap used for haskell-mode")
+
+(defun haskell-establish-key-bindings (keymap)
+ (define-key keymap "\C-ce" 'haskell-eval)
+ (define-key keymap "\C-cr" 'haskell-run)
+ (define-key keymap "\C-ct" 'haskell-report-type)
+ (define-key keymap "\C-cm" 'haskell-run-main)
+ (define-key keymap "\C-c\C-r" 'haskell-run-file)
+ (define-key keymap "\C-cp" 'haskell-get-pad)
+ (define-key keymap "\C-c\C-o" 'haskell-optimizers)
+ (define-key keymap "\C-c\C-p" 'haskell-printers)
+ (define-key keymap "\C-cc" 'haskell-compile)
+ (define-key keymap "\C-cl" 'haskell-load)
+ (define-key keymap "\C-ch" 'haskell-switch)
+ (define-key keymap "\C-c\C-k" 'haskell-kill)
+ (define-key keymap "\C-c:" 'haskell-command)
+ (define-key keymap "\C-cq" 'haskell-exit)
+ (define-key keymap "\C-ci" 'haskell-interrupt)
+ (define-key keymap "\C-cu" 'haskell-edit-unit))
+
+
+(haskell-establish-key-bindings haskell-mode-map)
+
+
+(defvar haskell-mode-syntax-table nil
+ "Syntax table used for haskell-mode")
+
+(if haskell-mode-syntax-table
+ nil
+ (setq haskell-mode-syntax-table (standard-syntax-table)))
+
+;;; Command for invoking the Haskell mode
+(defun haskell-mode nil
+ "Major mode for editing Haskell code to run in Emacs
+The following commands are available:
+\\{haskell-mode-map}
+
+A Haskell process can be fired up with \"M-x haskell\".
+
+Customization: Entry to this mode runs the hooks that are the value of variable
+haskell-mode-hook.
+
+Windows:
+
+There are 3 types of windows associated with Haskell mode. They are:
+ *haskell*: which is the process window.
+ Pad: which are buffers available for each module. It is here
+ where you want to test things before preserving them in a
+ file. Pads are always associated with a module.
+ When issuing a command:
+ The pad and its associated module are sent to the Haskell
+ process prior to the execution of the command.
+ .hs: These are the files where Haskell programs live. They
+ have .hs as extension.
+ When issuing a command:
+ The file is sent to the Haskell process prior to the
+ execution of the command.
+
+Commands:
+
+Each command behaves differently according to the type of the window in which
+the cursor is positioned when the command is issued .
+
+haskell-eval: \\[haskell-eval]
+ Always promts user for a Haskell expression to be evaluated. If in a
+ .hs file buffer, then the cursor tells which module is the current
+ module and the pad for that module (if any) gets loaded as well.
+
+haskell-run: \\[haskell-run]
+ Always queries for a variable of type Dialogue to be evaluated.
+
+haskell-run-main: \\[haskell-run-main]
+ Run Dialogue named main in the current module.
+
+haskell-report-type: \\[haskell-report-type]
+ Like haskell-eval, but prints the type of the expression without
+ evaluating it.
+
+haskell-mode: \\[haskell-mode]
+ Puts the current buffer in haskell mode.
+
+haskell-compile: \\[haskell-compile]
+ Compiles file in current buffer.
+
+haskell-load: \\[haskell-load]
+ Loads file in current buffer.
+
+haskell-run-file: \\[haskell-run-file]
+ Runs file in the current buffer.
+
+haskell-pad: \\[haskell-pad]
+ Creates a scratch pad for the current module.
+
+haskell-optimizers: \\[haskell-optimizers]
+ Shows the list of available optimizers. Commands for turning them on/off.
+
+haskell-printers: \\[haskell-printers]
+ Shows the list of available printers. Commands for turning them on/off.
+
+haskell-command: \\[haskell-command]
+ Prompts for a command to be sent to the command interface. You don't
+ need to put the : before the command.
+
+haskell-quit: \\[haskell-quit]
+ Terminates the haskell process.
+
+haskell-switch: \\[haskell-switch]
+ Switches to the inferior Haskell buffer (*haskell*) and positions the
+ cursor at the end of the buffer.
+
+haskell-kill: \\[haskell-kill]
+ Kill the current contents of the *haskell* buffer.
+
+haskell-interrupt: \\[haskell-interrupt]
+ Interrupts haskell process and resets it.
+
+haskell-edit-unit: \\[haskell-edit-unit]
+ Edit the .hu file for the unit containing this file.
+"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map haskell-mode-map)
+ (setq major-mode 'haskell-mode)
+ (setq mode-name "Haskell")
+ (make-local-variable 'indent-line-function)
+ (setq indent-line-function 'indent-relative-maybe)
+ ;(setq local-abbrev-table haskell-mode-abbrev-table)
+ (set-syntax-table haskell-mode-syntax-table)
+ ;(setq tab-stop-list haskell-tab-stop-list) ;; save old list??
+ (run-hooks 'haskell-mode-hook))
+
+
+\f
+;;;================================================================
+;;; Inferior Haskell stuff
+;;;================================================================
+
+
+(defvar inferior-haskell-mode-map (full-copy-sparse-keymap comint-mode-map))
+
+(haskell-establish-key-bindings inferior-haskell-mode-map)
+(define-key inferior-haskell-mode-map "\C-m" 'haskell-send-input)
+
+(defvar haskell-source-modes '(haskell-mode)
+ "*Used to determine if a buffer contains Haskell source code.
+If it's loaded into a buffer that is in one of these major modes,
+it's considered a Haskell source file.")
+
+(defvar haskell-prompt-pattern "^[A-Z]\\([A-Z]\\|[a-z]\\|[0-9]\\)*>\\s-*"
+ "Regular expression capturing the Haskell system prompt.")
+
+(defvar haskell-prompt-ring ()
+ "Keeps track of input to haskell process from the minibuffer")
+
+(defun inferior-haskell-mode-variables ()
+ nil)
+
+
+;;; INFERIOR-HASKELL-MODE (adapted from comint.el)
+
+(defun inferior-haskell-mode ()
+ "Major mode for interacting with an inferior Haskell process.
+
+The following commands are available:
+\\{inferior-haskell-mode-map}
+
+A Haskell process can be fired up with \"M-x haskell\".
+
+Customization: Entry to this mode runs the hooks on comint-mode-hook and
+inferior-haskell-mode-hook (in that order).
+
+You can send text to the inferior Haskell process from other buffers containing
+Haskell source.
+
+
+Windows:
+
+There are 3 types of windows in the inferior-haskell-mode. They are:
+ *haskell*: which is the process window.
+ Pad: which are buffers available for each module. It is here
+ where you want to test things before preserving them in a
+ file. Pads are always associated with a module.
+ When issuing a command:
+ The pad and its associated module are sent to the Haskell
+ process prior to the execution of the command.
+ .hs: These are the files where Haskell programs live. They
+ have .hs as extension.
+ When issuing a command:
+ The file is sent to the Haskell process prior to the
+ execution of the command.
+
+Commands:
+
+Each command behaves differently according to the type of the window in which
+the cursor is positioned when the command is issued.
+
+haskell-eval: \\[haskell-eval]
+ Always promts user for a Haskell expression to be evaluated. If in a
+ .hs file, then the cursor tells which module is the current module and
+ the pad for that module (if any) gets loaded as well.
+
+haskell-run: \\[haskell-run]
+ Always queries for a variable of type Dialogue to be evaluated.
+
+haskell-run-main: \\[haskell-run-main]
+ Run Dialogue named main.
+
+haskell-report-type: \\[haskell-report-type]
+ Like haskell-eval, but prints the type of the expression without
+ evaluating it.
+
+haskell-mode: \\[haskell-mode]
+ Puts the current buffer in haskell mode.
+
+haskell-compile: \\[haskell-compile]
+ Compiles file in current buffer.
+
+haskell-load: \\[haskell-load]
+ Loads file in current buffer.
+
+haskell-run-file: \\[haskell-run-file]
+ Runs file in the current buffer.
+
+haskell-pad: \\[haskell-pad]
+ Creates a scratch pad for the current module.
+
+haskell-optimizers: \\[haskell-optimizers]
+ Shows the list of available optimizers. Commands for turning them on/off.
+
+haskell-printers: \\[haskell-printers]
+ Shows the list of available printers. Commands for turning them on/off.
+
+haskell-command: \\[haskell-command]
+ Prompts for a command to be sent to the command interface. You don't
+ need to put the : before the command.
+
+haskell-quit: \\[haskell-quit]
+ Terminates the haskell process.
+
+haskell-switch: \\[haskell-switch]
+ Switches to the inferior Haskell buffer (*haskell*) and positions the
+ cursor at the end of the buffer.
+
+haskell-kill: \\[haskell-kill]
+ Kill the current contents of the *haskell* buffer.
+
+haskell-interrupt: \\[haskell-interrupt]
+ Interrupts haskell process and resets it.
+
+haskell-edit-unit: \\[haskell-edit-unit]
+ Edit the .hu file for the unit containing this file.
+
+The usual comint functions are also available. In particular, the
+following are all available:
+
+comint-bol: Beginning of line, but skip prompt. Bound to C-a by default.
+comint-delchar-or-maybe-eof: Delete char, unless at end of buffer, in
+ which case send EOF to process. Bound to C-d by default.
+
+Note however, that the default keymap bindings provided shadow some of
+the default comint mode bindings, so that you may want to bind them
+to your choice of keys.
+
+Comint mode's dynamic completion of filenames in the buffer is available.
+(Q.v. comint-dynamic-complete, comint-dynamic-list-completions.)
+
+If you accidentally suspend your process, use \\[comint-continue-subjob]
+to continue it."
+
+ (interactive)
+ (comint-mode)
+ (setq comint-prompt-regexp haskell-prompt-pattern)
+ ;; Customise in inferior-haskell-mode-hook
+ (inferior-haskell-mode-variables)
+ (setq major-mode 'inferior-haskell-mode)
+ (setq mode-name "Inferior Haskell")
+ (setq mode-line-process '(": %s : busy"))
+ (use-local-map inferior-haskell-mode-map)
+ (setq comint-input-filter 'haskell-input-filter)
+ (setq comint-input-sentinel 'ignore)
+ (setq comint-get-old-input 'haskell-get-old-input)
+ (run-hooks 'inferior-haskell-mode-hook)
+ ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook.
+ ;The test is so we don't lose history if we run comint-mode twice in
+ ;a buffer.
+ (setq haskell-prompt-ring (make-ring input-ring-size)))
+
+
+(defun haskell-input-filter (str)
+ "Don't save whitespace."
+ (not (string-match "\\s *" str)))
+
+
+\f
+;;; ==================================================================
+;;; Random utilities
+;;; ==================================================================
+
+
+;;; This keeps track of the status of the haskell process.
+;;; Values are:
+;;; busy -- The process is busy.
+;;; ready -- The process is ready for a command.
+;;; input -- The process is waiting for input.
+;;; debug -- The process is in the debugger.
+
+(defvar *haskell-status* 'busy
+ "Status of the haskell process")
+
+(defun set-haskell-status (value)
+ (setq *haskell-status* value)
+ (haskell-update-mode-line))
+
+(defun get-haskell-status ()
+ *haskell-status*)
+
+(defun haskell-update-mode-line ()
+ (save-excursion
+ (set-buffer *haskell-buffer*)
+ (cond ((eq *haskell-status* 'ready)
+ (setq mode-line-process '(": %s: ready")))
+ ((eq *haskell-status* 'input)
+ (setq mode-line-process '(": %s: input")))
+ ((eq *haskell-status* 'busy)
+ (setq mode-line-process '(": %s: busy")))
+ ((eq *haskell-status* 'debug)
+ (setq mode-line-process '(": %s: debug")))
+ (t
+ (haskell-mode-error "Confused about status of haskell process!")))
+ ;; Yes, this is the officially sanctioned technique for forcing
+ ;; a redisplay of the mode line.
+ (set-buffer-modified-p (buffer-modified-p))))
+
+
+(defun haskell-send-to-process (string)
+ (process-send-string "haskell" string)
+ (process-send-string "haskell" "\n"))
+
+
+\f
+;;; ==================================================================
+;;; Handle input in haskell process buffer; history commands.
+;;; ==================================================================
+
+(defun haskell-get-old-input ()
+ "Get old input text from Haskell process buffer."
+ (save-excursion
+ (if (re-search-forward haskell-prompt-pattern (point-max) 'move)
+ (goto-char (match-beginning 0)))
+ (cond ((re-search-backward haskell-prompt-pattern (point-min) t)
+ (comint-skip-prompt)
+ (let ((temp (point)))
+ (end-of-line)
+ (buffer-substring temp (point)))))))
+
+
+(defun haskell-send-input ()
+ "Send input to Haskell while in the process buffer"
+ (interactive)
+ (if (eq (get-haskell-status) 'debug)
+ (comint-send-input)
+ (haskell-send-input-aux)))
+
+(defun haskell-send-input-aux ()
+ ;; Note that the input string does not include its terminal newline.
+ (let ((proc (get-buffer-process (current-buffer))))
+ (if (not proc)
+ (haskell-mode-error "Current buffer has no process!")
+ (let* ((pmark (process-mark proc))
+ (pmark-val (marker-position pmark))
+ (input (if (>= (point) pmark-val)
+ (buffer-substring pmark (point))
+ (let ((copy (funcall comint-get-old-input)))
+ (goto-char pmark)
+ (insert copy)
+ copy))))
+ (insert ?\n)
+ (if (funcall comint-input-filter input)
+ (ring-insert input-ring input))
+ (funcall comint-input-sentinel input)
+ (set-marker (process-mark proc) (point))
+ (set-marker comint-last-input-end (point))
+ (haskell-send-to-process input)))))
+
+
+\f
+;;; ==================================================================
+;;; Minibuffer input stuff
+;;; ==================================================================
+
+;;; Haskell input history retrieval commands (taken from comint.el)
+;;; M-p -- previous input M-n -- next input
+
+(defvar haskell-minibuffer-local-map nil
+ "Local map for minibuffer when in Haskell")
+
+(if haskell-minibuffer-local-map
+ nil
+ (progn
+ (setq haskell-minibuffer-local-map
+ (full-copy-sparse-keymap minibuffer-local-map))
+ ;; Haskell commands
+ (define-key haskell-minibuffer-local-map "\ep" 'haskell-previous-input)
+ (define-key haskell-minibuffer-local-map "\en" 'haskell-next-input)
+ ))
+
+(defun haskell-previous-input (arg)
+ "Cycle backwards through input history."
+ (interactive "*p")
+ (let ((len (ring-length haskell-prompt-ring)))
+ (cond ((<= len 0)
+ (message "Empty input ring.")
+ (ding))
+ (t
+ (cond ((eq last-command 'haskell-previous-input)
+ (delete-region (mark) (point))
+ (set-mark (point)))
+ (t
+ (setq input-ring-index
+ (if (> arg 0) -1
+ (if (< arg 0) 1 0)))
+ (push-mark (point))))
+ (setq input-ring-index (comint-mod (+ input-ring-index arg) len))
+ (insert (ring-ref haskell-prompt-ring input-ring-index))
+ (setq this-command 'haskell-previous-input))
+ )))
+
+(defun haskell-next-input (arg)
+ "Cycle forwards through input history."
+ (interactive "*p")
+ (haskell-previous-input (- arg)))
+
+(defvar haskell-last-input-match ""
+ "Last string searched for by Haskell input history search, for defaulting.
+Buffer local variable.")
+
+(defun haskell-previous-input-matching (str)
+ "Searches backwards through input history for substring match"
+ (interactive (let ((s (read-from-minibuffer
+ (format "Command substring (default %s): "
+ haskell-last-input-match))))
+ (list (if (string= s "") haskell-last-input-match s))))
+ (setq haskell-last-input-match str) ; update default
+ (let ((str (regexp-quote str))
+ (len (ring-length haskell-prompt-ring))
+ (n 0))
+ (while (and (<= n len)
+ (not (string-match str (ring-ref haskell-prompt-ring n))))
+ (setq n (+ n 1)))
+ (cond ((<= n len) (haskell-previous-input (+ n 1)))
+ (t (haskell-mode-error "Not found.")))))
+
+
+;;; Actually read an expression from the minibuffer using the new keymap.
+
+(defun haskell-get-expression (prompt)
+ (let ((exp (read-from-minibuffer prompt nil haskell-minibuffer-local-map)))
+ (ring-insert haskell-prompt-ring exp)
+ exp))
+
+
+\f
+;;; ==================================================================
+;;; Handle output from Haskell process
+;;; ==================================================================
+
+;;; The haskell process produces output with embedded control codes.
+;;; These control codes are used to keep track of what kind of input
+;;; the haskell process is expecting. Ordinary output is just displayed.
+;;;
+;;; This is kind of complicated because control sequences can be broken
+;;; across multiple batches of text received from the haskell process.
+;;; If the string ends in the middle of a control sequence, save it up
+;;; for the next call.
+
+(defvar *haskell-saved-output* nil)
+
+;;; On the Next, there is some kind of race condition that causes stuff
+;;; sent to the Haskell subprocess before it has really started to be lost.
+;;; The point of this variable is to force the Emacs side to wait until
+;;; Haskell has started and printed out its banner before sending it
+;;; anything. See start-haskell below.
+
+(defvar *haskell-process-alive* nil)
+
+(defun haskell-output-filter (process str)
+ "Filter for output from Yale Haskell command interface"
+ ;; *** debug
+ ;;(let ((buffer (get-buffer-create "haskell-output")))
+ ;; (save-excursion
+ ;; (set-buffer buffer)
+ ;; (insert str)))
+ (setq *haskell-process-alive* t)
+ (let ((next 0)
+ (start 0)
+ (data (match-data)))
+ (unwind-protect
+ (progn
+ ;; If there was saved output from last time, glue it in front of the
+ ;; newly received input.
+ (if *haskell-saved-output*
+ (progn
+ (setq str (concat *haskell-saved-output* str))
+ (setq *haskell-saved-output* nil)))
+ ;; Loop, looking for complete command sequences.
+ ;; Set next to point to the first one.
+ ;; start points to first character to be processed.
+ (while (setq next
+ (string-match *haskell-message-match-regexp*
+ str start))
+ ;; Display any intervening ordinary text.
+ (if (not (eq next start))
+ (haskell-display-output (substring str start next)))
+ ;; Now dispatch on the particular command sequence found.
+ ;; Handler functions are called with the string and start index
+ ;; as arguments, and should return the index of the "next"
+ ;; character.
+ (let ((end (match-end 0)))
+ (haskell-handle-message str next)
+ (setq start end)))
+ ;; Look to see whether the string ends with an incomplete
+ ;; command sequence.
+ ;; If so, save the tail of the string for next time.
+ (if (and (setq next
+ (string-match *haskell-message-prefix-regexp* str start))
+ (eq (match-end 0) (length str)))
+ (setq *haskell-saved-output* (substring str next))
+ (setq next (length str)))
+ ;; Display any leftover ordinary text.
+ (if (not (eq next start))
+ (haskell-display-output (substring str start next))))
+ (store-match-data data))))
+
+(defvar *haskell-message-match-regexp*
+ "EMACS:.*\n")
+
+(defvar *haskell-message-prefix-regexp*
+ "E\\(M\\(A\\(C\\(S\\(:.*\\)?\\)?\\)?\\)?\\)?")
+
+(defvar *haskell-message-dispatch*
+ '(("EMACS:debug\n" . haskell-got-debug)
+ ("EMACS:busy\n" . haskell-got-busy)
+ ("EMACS:input\n" . haskell-got-input)
+ ("EMACS:ready\n" . haskell-got-ready)
+ ("EMACS:printers .*\n" . haskell-got-printers)
+ ("EMACS:optimizers .*\n" . haskell-got-optimizers)
+ ("EMACS:message .*\n" . haskell-got-message)
+ ("EMACS:error\n" . haskell-got-error)
+ ))
+
+(defun haskell-handle-message (str idx)
+ (let ((list *haskell-message-dispatch*)
+ (fn nil))
+ (while (and list (null fn))
+ (if (eq (string-match (car (car list)) str idx) idx)
+ (setq fn (cdr (car list)))
+ (setq list (cdr list))))
+ (if (null fn)
+ (haskell-mode-error "Garbled message from Haskell!")
+ (let ((end (match-end 0)))
+ (funcall fn str idx end)
+ end))))
+
+
+(defun haskell-message-data (string start end)
+ (let ((real-start (+ (string-match " " string start) 1))
+ (real-end (- end 1)))
+ (substring string real-start real-end)))
+
+(defun haskell-got-debug (string start end)
+ (beep)
+ (message "In the debugger!")
+ (set-haskell-status 'debug))
+
+(defun haskell-got-busy (string start end)
+ (set-haskell-status 'busy))
+
+(defun haskell-got-input (string start end)
+ (if haskell-auto-switch-input
+ (progn
+ (haskell-switch)
+ (beep)))
+ (set-haskell-status 'input)
+ (message "Waiting for input..."))
+
+(defun haskell-got-ready (string start end)
+ (set-haskell-status 'ready))
+
+(defun haskell-got-printers (string start end)
+ (haskell-printers-update (haskell-message-data string start end)))
+
+(defun haskell-got-optimizers (string start end)
+ (haskell-optimizers-update (haskell-message-data string start end)))
+
+(defun haskell-got-message (string start end)
+ (message "%s" (haskell-message-data string start end)))
+
+(defun haskell-got-error (string start end)
+ (beep)
+ (message "Haskell error."))
+
+
+;;; Displays output at end of given buffer.
+;;; This function only ensures that the output is visible, without
+;;; selecting the buffer in which it is displayed.
+;;; Note that just using display-buffer instead of all this rigamarole
+;;; won't work; you need to temporarily select the window containing
+;;; the *haskell-buffer*, or else the display won't be scrolled to show
+;;; the new output.
+;;; *** This should really position the window in the buffer so that
+;;; *** the point is on the last line of the window.
+
+(defun haskell-display-output (str)
+ (let ((window (selected-window)))
+ (unwind-protect
+ (progn
+ (pop-to-buffer *haskell-buffer*)
+ (haskell-display-output-aux str))
+ (select-window window))))
+
+(defun haskell-display-output-aux (str)
+ (haskell-move-marker)
+ (insert str)
+ (haskell-move-marker))
+
+
+\f
+;;; ==================================================================
+;;; Interactive commands
+;;; ==================================================================
+
+
+;;; HASKELL
+;;; -------
+;;;
+;;; This is the function that fires up the inferior haskell process.
+
+(defun haskell ()
+ "Run an inferior Haskell process with input and output via buffer *haskell*.
+Takes the program name from the variable haskell-program-name.
+Runs the hooks from inferior-haskell-mode-hook
+(after the comint-mode-hook is run).
+\(Type \\[describe-mode] in the process buffer for a list of commands.)"
+ (interactive)
+ (if (not (haskell-process-exists-p))
+ (start-haskell)))
+
+(defun start-haskell ()
+ (message "Starting haskell subprocess...")
+ ;; Kill old haskell process. Normally this routine is only called
+ ;; after checking haskell-process-exists-p, but things can get
+ ;; screwed up if you rename the *haskell* buffer while leaving the
+ ;; old process running. This forces it to get rid of the old process
+ ;; and start a new one.
+ (if (get-process "haskell")
+ (delete-process "haskell"))
+ (let ((haskell-buffer
+ (apply 'make-comint
+ "haskell"
+ (or haskell-program-name
+ (haskell-mode-error "Haskell-program-name undefined!"))
+ nil
+ nil)))
+ (save-excursion
+ (set-buffer haskell-buffer)
+ (inferior-haskell-mode))
+ (haskell-session-init)
+ ;; Wait for process to get started before sending it anything
+ ;; to avoid race condition on NeXT.
+ (setq *haskell-process-alive* nil)
+ (while (not *haskell-process-alive*)
+ (sleep-for 1))
+ (haskell-send-to-process ":(use-emacs-interface)")
+ (haskell-printers-set haskell-initial-printers nil)
+ (display-buffer haskell-buffer))
+ (message "Starting haskell subprocess... Done."))
+
+
+(defun haskell-process-exists-p ()
+ (let ((haskell-buffer (get-buffer *haskell-buffer*)))
+ (and haskell-buffer (comint-check-proc haskell-buffer))))
+
+
+
+;;; Initialize things on the emacs side, and tell haskell that it's
+;;; talking to emacs.
+
+(defun haskell-session-init ()
+ (set-haskell-status 'busy)
+ (setq *last-loaded* nil)
+ (setq *last-module* haskell-main-module)
+ (setq *last-pad* haskell-main-pad)
+ (setq *haskell-saved-output* nil)
+ (haskell-create-main-pad)
+ (set-process-filter (get-process "haskell") 'haskell-output-filter)
+ )
+
+
+(defun haskell-create-main-pad ()
+ (let ((buffer (get-buffer-create haskell-main-pad)))
+ (save-excursion
+ (set-buffer buffer)
+ (haskell-mode))
+ (haskell-record-pad-mapping
+ haskell-main-pad haskell-main-module nil)
+ buffer))
+
+
+;;; Called from evaluation and compilation commands to start up a Haskell
+;;; process if none is already in progress.
+
+(defun haskell-maybe-create-process ()
+ (cond ((haskell-process-exists-p)
+ t)
+ (haskell-auto-create-process
+ (start-haskell))
+ (t
+ (haskell-mode-error "No Haskell process!"))))
+
+
+
+;;; HASKELL-GET-PAD
+;;; ------------------------------------------------------------------
+
+;;; This always puts the pad buffer in the "other" window.
+;;; Having it wipe out the .hs file window is clearly the wrong
+;;; behavior.
+
+(defun haskell-get-pad ()
+ "Creates a new scratch pad for the current module.
+Signals an error if the current buffer is not a .hs file."
+ (interactive)
+ (let ((fname (buffer-file-name)))
+ (if fname
+ (do-get-pad fname (current-buffer))
+ (haskell-mode-error "Not in a .hs buffer!"))))
+
+
+(defun do-get-pad (fname buff)
+ (let* ((mname (or (haskell-get-modname buff)
+ (read-no-blanks-input "Scratch pad for module? " nil)))
+ (pname (haskell-lookup-pad mname fname))
+ (pbuff nil))
+ ;; Generate the base name of the pad buffer, then create the
+ ;; buffer. The actual name of the pad buffer may be something
+ ;; else because of name collisions.
+ (if (not pname)
+ (progn
+ (setq pname (format "*%s-pad*" mname))
+ (setq pbuff (generate-new-buffer pname))
+ (setq pname (buffer-name pbuff))
+ (haskell-record-pad-mapping pname mname fname)
+ )
+ (setq pbuff (get-buffer pname)))
+ ;; Make sure the pad buffer is in haskell mode.
+ (pop-to-buffer pbuff)
+ (haskell-mode)))
+
+
+
+;;; HASKELL-SWITCH
+;;; ------------------------------------------------------------------
+
+(defun haskell-switch ()
+ "Switches to \*haskell\* buffer."
+ (interactive)
+ (haskell-maybe-create-process)
+ (pop-to-buffer *haskell-buffer*)
+ (push-mark)
+ (goto-char (point-max)))
+
+
+
+;;; HASKELL-KILL
+;;; ------------------------------------------------------------------
+
+(defun haskell-kill ()
+ "Kill contents of *haskell* buffer. \\[haskell-kill]"
+ (interactive)
+ (save-excursion
+ (set-buffer *haskell-buffer*)
+ (beginning-of-buffer)
+ (let ((mark (point)))
+ (end-of-buffer)
+ (kill-region mark (point)))))
+
+
+
+;;; HASKELL-COMMAND
+;;; ------------------------------------------------------------------
+
+(defun haskell-command (str)
+ "Format STRING as a haskell command and send it to haskell process. \\[haskell-command]"
+ (interactive "sHaskell command: ")
+ (haskell-send-to-process (format ":%s" str)))
+
+
+;;; HASKELL-EVAL and HASKELL-RUN
+;;; ------------------------------------------------------------------
+
+(defun haskell-eval ()
+ "Evaluate expression in current module. \\[haskell-eval]"
+ (interactive)
+ (haskell-maybe-create-process)
+ (haskell-eval-aux (haskell-get-expression "Haskell expression: ")
+ "emacs-eval"))
+
+(defun haskell-run ()
+ "Run Haskell Dialogue in current module"
+ (interactive)
+ (haskell-maybe-create-process)
+ (haskell-eval-aux (haskell-get-expression "Haskell dialogue: ")
+ "emacs-run"))
+
+(defun haskell-run-main ()
+ "Run Dialogue named main in current module"
+ (interactive)
+ (haskell-maybe-create-process)
+ (haskell-eval-aux "main" "emacs-run"))
+
+(defun haskell-report-type ()
+ "Print the type of the expression."
+ (interactive)
+ (haskell-maybe-create-process)
+ (haskell-eval-aux (haskell-get-expression "Haskell expression: ")
+ "emacs-report-type"))
+
+(defun haskell-eval-aux (exp fn)
+ (cond ((equal *haskell-buffer* (buffer-name))
+ ;; In the *haskell* buffer.
+ (let* ((pname *last-pad*)
+ (mname *last-module*)
+ (fname *last-loaded*))
+ (haskell-eval-aux-aux exp pname mname fname fn)))
+ ((buffer-file-name)
+ ;; In a .hs file.
+ (let* ((fname (buffer-file-name))
+ (mname (haskell-get-modname (current-buffer)))
+ (pname (haskell-lookup-pad mname fname)))
+ (haskell-eval-aux-aux exp pname mname fname fn)))
+ (t
+ ;; In a pad.
+ (let* ((pname (buffer-name (current-buffer)))
+ (mname (haskell-get-module-from-pad pname))
+ (fname (haskell-get-file-from-pad pname)))
+ (haskell-eval-aux-aux exp pname mname fname fn)))
+ ))
+
+(defun haskell-eval-aux-aux (exp pname mname fname fn)
+ (haskell-save-modified-source-files fname)
+ (haskell-send-to-process (format ":(%s" fn))
+ (haskell-send-to-process
+ (prin1-to-string exp))
+ (haskell-send-to-process
+ (prin1-to-string (or pname fname "interactive")))
+ (haskell-send-to-process
+ (prin1-to-string
+ (if (and pname (get-buffer pname))
+ (save-excursion
+ (set-buffer pname)
+ (buffer-string))
+ "")))
+ (haskell-send-to-process
+ (format "'|%s|" mname))
+ (haskell-send-to-process
+ (if fname
+ (prin1-to-string (haskell-maybe-get-unit-file-name fname))
+ "'#f"))
+ (haskell-send-to-process ")")
+ (setq *last-pad* pname)
+ (setq *last-module* mname)
+ (setq *last-loaded* fname))
+
+
+
+;;; HASKELL-RUN-FILE, HASKELL-LOAD, HASKELL-COMPILE
+;;; ------------------------------------------------------------------
+
+(defun haskell-run-file ()
+ "Runs Dialogue named main in current file."
+ (interactive)
+ (haskell-maybe-create-process)
+ (let ((fname (haskell-get-file-to-operate-on)))
+ (haskell-save-modified-source-files fname)
+ (haskell-send-to-process ":(emacs-run-file")
+ (haskell-send-to-process (prin1-to-string fname))
+ (haskell-send-to-process ")")))
+
+(defun haskell-load ()
+ "Load current file."
+ (interactive)
+ (haskell-maybe-create-process)
+ (let ((fname (haskell-get-file-to-operate-on)))
+ (haskell-save-modified-source-files fname)
+ (haskell-send-to-process ":(emacs-load-file")
+ (haskell-send-to-process (prin1-to-string fname))
+ (haskell-send-to-process ")")))
+
+(defun haskell-compile ()
+ "Compile current file."
+ (interactive)
+ (haskell-maybe-create-process)
+ (let ((fname (haskell-get-file-to-operate-on)))
+ (haskell-save-modified-source-files fname)
+ (haskell-send-to-process ":(emacs-compile-file")
+ (haskell-send-to-process (prin1-to-string fname))
+ (haskell-send-to-process ")")))
+
+
+(defun haskell-get-file-to-operate-on ()
+ (cond ((equal *haskell-buffer* (buffer-name))
+ ;; When called from the haskell process buffer, prompt for a file.
+ (call-interactively 'haskell-get-file/prompt))
+ ((buffer-file-name)
+ ;; When called from a .hs file buffer, use the unit file
+ ;; associated with it, if there is one.
+ (haskell-maybe-get-unit-file-name (buffer-file-name)))
+ (t
+ ;; When called from a pad, use the file that the module the
+ ;; pad belongs to lives in.
+ (haskell-maybe-get-unit-file-name
+ (haskell-get-file-from-pad (buffer-name (current-buffer)))))))
+
+(defun haskell-get-file/prompt (filename)
+ (interactive "fHaskell file: ")
+ (haskell-run-file-aux filename))
+
+
+
+;;; HASKELL-EXIT
+;;; ------------------------------------------------------------------
+
+(defun haskell-exit ()
+ "Quit the haskell process."
+ (interactive)
+ (cond ((not (haskell-process-exists-p))
+ (message "No process currently running."))
+ ((y-or-n-p "Do you really want to quit Haskell? ")
+ (haskell-send-to-process ":quit")
+ ;; If we were running the tutorial, mark the temp buffer as unmodified
+ ;; so we don't get asked about saving it later.
+ (if (and *ht-temp-buffer*
+ (get-buffer *ht-temp-buffer*))
+ (save-excursion
+ (set-buffer *ht-temp-buffer*)
+ (set-buffer-modified-p nil)))
+ ;; Try to remove the haskell output buffer from the screen.
+ (bury-buffer *haskell-buffer*)
+ (replace-buffer-in-windows *haskell-buffer*))
+ (t
+ nil)))
+
+
+;;; HASKELL-INTERRUPT
+;;; ------------------------------------------------------------------
+
+(defun haskell-interrupt ()
+ "Interrupt the haskell process."
+ (interactive)
+ (if (haskell-process-exists-p)
+ (haskell-send-to-process "\C-c")))
+
+
+
+;;; HASKELL-EDIT-UNIT
+;;; ------------------------------------------------------------------
+
+(defun haskell-edit-unit ()
+ "Edit the .hu file."
+ (interactive)
+ (let ((fname (buffer-file-name)))
+ (if fname
+ (let ((find-file-not-found-hooks (list 'haskell-new-unit))
+ (file-not-found nil)
+ (units-fname (haskell-get-unit-file-name fname)))
+ (find-file-other-window units-fname)
+ ;; If creating a new file, initialize it to contain the name
+ ;; of the haskell source file.
+ (if file-not-found
+ (save-excursion
+ (insert
+ (if (string= (file-name-directory fname)
+ (file-name-directory units-fname))
+ (file-name-nondirectory fname)
+ fname)
+ "\n"))))
+ (haskell-mode-error "Not in a .hs buffer!"))))
+
+(defun haskell-new-unit ()
+ (setq file-not-found t))
+
+
+;;; Look for a comment like "-- unit:" at top of file.
+;;; If not found, assume unit file has same name as the buffer but
+;;; a .hu extension.
+
+(defun haskell-get-unit-file-name (fname)
+ (or (haskell-get-unit-file-name-from-file fname)
+ (concat (haskell-strip-file-extension fname) ".hu")))
+
+(defun haskell-maybe-get-unit-file-name (fname)
+ (or (haskell-get-unit-file-name-from-file fname)
+ (haskell-strip-file-extension fname)))
+
+(defun haskell-get-unit-file-name-from-file (fname)
+ (let ((buffer (get-file-buffer fname)))
+ (if buffer
+ (save-excursion
+ (beginning-of-buffer)
+ (if (re-search-forward "-- unit:[ \t]*" (point-max) t)
+ (let ((beg (match-end 0)))
+ (end-of-line)
+ (buffer-substring beg (point)))
+ nil))
+ nil)))
+
+
+
+\f
+;;; ==================================================================
+;;; Support for printers/optimizers menus
+;;; ==================================================================
+
+;;; This code was adapted from the standard buff-menu.el code.
+
+(defvar haskell-menu-mode-map nil "")
+
+(if (not haskell-menu-mode-map)
+ (progn
+ (setq haskell-menu-mode-map (make-keymap))
+ (suppress-keymap haskell-menu-mode-map t)
+ (define-key haskell-menu-mode-map "m" 'hm-mark)
+ (define-key haskell-menu-mode-map "u" 'hm-unmark)
+ (define-key haskell-menu-mode-map "x" 'hm-exit)
+ (define-key haskell-menu-mode-map "q" 'hm-exit)
+ (define-key haskell-menu-mode-map " " 'next-line)
+ (define-key haskell-menu-mode-map "\177" 'hm-backup-unmark)
+ (define-key haskell-menu-mode-map "?" 'describe-mode)))
+
+;; Printers Menu mode is suitable only for specially formatted data.
+
+(put 'haskell-menu-mode 'mode-class 'special)
+
+(defun haskell-menu-mode ()
+ "Major mode for editing Haskell flags.
+Each line describes a flag.
+Letters do not insert themselves; instead, they are commands.
+m -- mark flag (turn it on)
+u -- unmark flag (turn it off)
+x -- exit; tell the Haskell process to update the flags, then leave menu.
+q -- exit; same as x.
+Precisely,\\{haskell-menu-mode-map}"
+ (kill-all-local-variables)
+ (use-local-map haskell-menu-mode-map)
+ (setq truncate-lines t)
+ (setq buffer-read-only t)
+ (setq major-mode 'haskell-menu-mode)
+ (setq mode-name "Haskell Flags Menu")
+ ;; These are all initialized elsewhere
+ (make-local-variable 'hm-current-flags)
+ (make-local-variable 'hm-request-fn)
+ (make-local-variable 'hm-update-fn)
+ (run-hooks 'haskell-menu-mode-hook))
+
+
+(defun haskell-menu (help-file buffer request-fn update-fn)
+ (haskell-maybe-create-process)
+ (if (get-buffer buffer)
+ (progn
+ (pop-to-buffer buffer)
+ (goto-char (point-min)))
+ (progn
+ (pop-to-buffer buffer)
+ (insert-file-contents help-file)
+ (haskell-menu-mode)
+ (setq hm-request-fn request-fn)
+ (setq hm-update-fn update-fn)
+ ))
+ (hm-mark-current)
+ (message "m = mark; u = unmark; x = execute; q = quit; ? = more help."))
+
+
+
+;;; A line that starts with *hm-marked* is a menu item turned on.
+;;; A line that starts with *hm-unmarked* is turned off.
+;;; A line that starts with anything else is just random text and is
+;;; ignored by commands that deal with menu items.
+
+(defvar *hm-marked* " on")
+(defvar *hm-unmarked* " ")
+(defvar *hm-marked-regexp* " on \\w")
+(defvar *hm-unmarked-regexp* " \\w")
+
+(defun hm-mark ()
+ "Mark flag to be turned on."
+ (interactive)
+ (beginning-of-line)
+ (cond ((looking-at *hm-marked-regexp*)
+ (forward-line 1))
+ ((looking-at *hm-unmarked-regexp*)
+ (let ((buffer-read-only nil))
+ (delete-char (length *hm-unmarked*))
+ (insert *hm-marked*)
+ (forward-line 1)))
+ (t
+ (forward-line 1))))
+
+(defun hm-unmark ()
+ "Unmark flag."
+ (interactive)
+ (beginning-of-line)
+ (cond ((looking-at *hm-unmarked-regexp*)
+ (forward-line 1))
+ ((looking-at *hm-marked-regexp*)
+ (let ((buffer-read-only nil))
+ (delete-char (length *hm-marked*))
+ (insert *hm-unmarked*)
+ (forward-line 1)))
+ (t
+ (forward-line 1))))
+
+(defun hm-backup-unmark ()
+ "Move up and unmark."
+ (interactive)
+ (forward-line -1)
+ (hm-unmark)
+ (forward-line -1))
+
+
+;;; Actually make the changes.
+
+(defun hm-exit ()
+ "Update flags, then leave menu."
+ (interactive)
+ (hm-execute)
+ (hm-quit))
+
+(defun hm-execute ()
+ "Tell haskell process to tweak flags."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((flags-on nil)
+ (flags-off nil))
+ (while (not (eq (point) (point-max)))
+ (cond ((looking-at *hm-unmarked-regexp*)
+ (setq flags-off (cons (hm-flag) flags-off)))
+ ((looking-at *hm-marked-regexp*)
+ (setq flags-on (cons (hm-flag) flags-on)))
+ (t
+ nil))
+ (forward-line 1))
+ (funcall hm-update-fn flags-on flags-off))))
+
+
+(defun hm-quit ()
+ (interactive)
+ "Make the menu go away."
+ (bury-buffer (current-buffer))
+ (replace-buffer-in-windows (current-buffer)))
+
+(defun hm-flag ()
+ (save-excursion
+ (beginning-of-line)
+ (forward-char 6)
+ (let ((beg (point)))
+ ;; End of flag name marked by tab or two spaces.
+ (re-search-forward "\t\\| ")
+ (buffer-substring beg (match-beginning 0)))))
+
+
+;;; Update the menu to mark only those items currently turned on.
+
+(defun hm-mark-current ()
+ (funcall hm-request-fn)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eq (point) (point-max)))
+ (cond ((and (looking-at *hm-unmarked-regexp*)
+ (hm-item-currently-on-p (hm-flag)))
+ (hm-mark))
+ ((and (looking-at *hm-marked-regexp*)
+ (not (hm-item-currently-on-p (hm-flag))))
+ (hm-unmark))
+ (t
+ (forward-line 1))))))
+
+
+;;; See if a menu item is turned on.
+
+(defun hm-item-currently-on-p (item)
+ (member-string= item hm-current-flags))
+
+(defun member-string= (item list)
+ (cond ((null list)
+ nil)
+ ((string= item (car list))
+ list)
+ (t
+ (member-string= item (cdr list)))))
+
+
+
+;;; Make the menu for printers.
+
+(defvar *haskell-printers-help*
+ (concat (getenv "HASKELL") "/emacs-tools/printer-help.txt")
+ "Help file for printers.")
+
+(defvar *haskell-printers-buffer* "*Haskell printers*")
+
+(defun haskell-printers ()
+ "Set printers interactively."
+ (interactive)
+ (haskell-menu
+ *haskell-printers-help*
+ *haskell-printers-buffer*
+ 'haskell-printers-inquire
+ 'haskell-printers-set))
+
+(defun haskell-printers-inquire ()
+ (setq hm-current-flags t)
+ (haskell-send-to-process ":(emacs-send-printers)")
+ (while (eq hm-current-flags t)
+ (sleep-for 1)))
+
+(defun haskell-printers-update (data)
+ (setq hm-current-flags (read data)))
+
+(defun haskell-printers-set (flags-on flags-off)
+ (haskell-send-to-process ":(emacs-set-printers '")
+ (haskell-send-to-process (prin1-to-string flags-on))
+ (haskell-send-to-process ")"))
+
+
+;;; Equivalent stuff for the optimizers menu
+
+(defvar *haskell-optimizers-help*
+ (concat (getenv "HASKELL") "/emacs-tools/optimizer-help.txt")
+ "Help file for optimizers.")
+
+(defvar *haskell-optimizers-buffer* "*Haskell optimizers*")
+
+(defun haskell-optimizers ()
+ "Set optimizers interactively."
+ (interactive)
+ (haskell-menu
+ *haskell-optimizers-help*
+ *haskell-optimizers-buffer*
+ 'haskell-optimizers-inquire
+ 'haskell-optimizers-set))
+
+(defun haskell-optimizers-inquire ()
+ (setq hm-current-flags t)
+ (haskell-send-to-process ":(emacs-send-optimizers)")
+ (while (eq hm-current-flags t)
+ (sleep-for 1)))
+
+(defun haskell-optimizers-update (data)
+ (setq hm-current-flags (read data)))
+
+(defun haskell-optimizers-set (flags-on flags-off)
+ (haskell-send-to-process ":(emacs-set-optimizers '")
+ (haskell-send-to-process (prin1-to-string flags-on))
+ (haskell-send-to-process ")"))
+
+
+\f
+;;; ==================================================================
+;;; Random utilities
+;;; ==================================================================
+
+
+;;; Keep track of the association between pads, modules, and files.
+;;; The global variable is a list of (pad-buffer-name module-name file-name)
+;;; lists.
+
+(defvar *haskell-pad-mappings* ()
+ "Associates pads with their corresponding module and file.")
+
+(defun haskell-record-pad-mapping (pname mname fname)
+ (setq *haskell-pad-mappings*
+ (cons (list pname mname fname) *haskell-pad-mappings*)))
+
+(defun haskell-get-module-from-pad (pname)
+ (car (cdr (assoc pname *haskell-pad-mappings*))))
+
+(defun haskell-get-file-from-pad (pname)
+ (car (cdr (cdr (assoc pname *haskell-pad-mappings*)))))
+
+(defun haskell-lookup-pad (mname fname)
+ (let ((pname (haskell-lookup-pad-aux mname fname *haskell-pad-mappings*)))
+ (if (and pname (get-buffer pname))
+ pname
+ nil)))
+
+(defun haskell-lookup-pad-aux (mname fname list)
+ (cond ((null list)
+ nil)
+ ((and (equal mname (car (cdr (car list))))
+ (equal fname (car (cdr (cdr (car list))))))
+ (car (car list)))
+ (t
+ (haskell-lookup-pad-aux mname fname (cdr list)))))
+
+
+
+;;; Save any modified .hs and .hu files.
+;;; Yes, the two set-buffer calls really seem to be necessary. It seems
+;;; that y-or-n-p makes emacs forget we had temporarily selected some
+;;; other buffer, and if you just do save-buffer directly it will end
+;;; up trying to save the current buffer instead. The built-in
+;;; save-some-buffers function has this problem....
+
+(defun haskell-save-modified-source-files (filename)
+ (let ((buffers (buffer-list))
+ (found-any nil))
+ (while buffers
+ (let ((buffer (car buffers)))
+ (if (and (buffer-modified-p buffer)
+ (save-excursion
+ (set-buffer buffer)
+ (and buffer-file-name
+ (haskell-source-file-p buffer-file-name)
+ (setq found-any t)
+ (or (null haskell-ask-before-saving)
+ (and filename (string= buffer-file-name filename))
+ (y-or-n-p
+ (format "Save file %s? " buffer-file-name))))))
+ (save-excursion
+ (set-buffer buffer)
+ (save-buffer))))
+ (setq buffers (cdr buffers)))
+ (if found-any
+ (message "")
+ (message "(No files need saving)"))))
+
+(defun haskell-source-file-p (filename)
+ (or (string-match "\\.hs$" filename)
+ (string-match "\\.lhs$" filename)
+ (string-match "\\.hi$" filename)
+ (string-match "\\.hu$" filename)))
+
+
+
+;;; Buffer utilities
+
+(defun haskell-move-marker ()
+ "Moves the marker and point to the end of buffer"
+ (set-marker comint-last-input-end (point-max))
+ (set-marker (process-mark (get-process "haskell")) (point-max))
+ (goto-char (point-max)))
+
+
+
+;;; Extract the name of the module the point is in, from the given buffer.
+
+(defvar *haskell-re-module-hs* "^module\\s *")
+(defvar *haskell-re-module-lhs* "^>\\s *module\\s *")
+(defvar *haskell-re-modname* "[A-Z]\\([a-z]\\|[A-Z]\\|[0-9]\\|'\\|_\\)*")
+
+(defun haskell-get-modname (buff)
+ "Get module name in BUFFER that point is in."
+ (save-excursion
+ (set-buffer buff)
+ (let ((regexp (if (haskell-lhs-filename-p (buffer-file-name))
+ *haskell-re-module-lhs*
+ *haskell-re-module-hs*)))
+ (if (or (looking-at regexp)
+ (re-search-backward regexp (point-min) t)
+ (re-search-forward regexp (point-max) t))
+ (progn
+ (goto-char (match-end 0))
+ (if (looking-at *haskell-re-modname*)
+ (buffer-substring (match-beginning 0) (match-end 0))
+ (haskell-mode-error "Module name not found!!")))
+ "Main"))))
+
+
+;;; Strip file extensions.
+;;; Only strip off extensions we know about; e.g.
+;;; "foo.hs" -> "foo" but "foo.bar" -> "foo.bar".
+
+(defvar *haskell-filename-regexp* "\\(.*\\)\\.\\(hs\\|lhs\\)$")
+
+(defun haskell-strip-file-extension (filename)
+ "Strip off the extension from a filename."
+ (if (string-match *haskell-filename-regexp* filename)
+ (substring filename (match-beginning 1) (match-end 1))
+ filename))
+
+
+;;; Is this a .lhs filename?
+
+(defun haskell-lhs-filename-p (filename)
+ (string-match ".*\\.lhs$" filename))
+
+
+;;; Haskell mode error
+
+(defun haskell-mode-error (msg)
+ "Show MSG in message line as an error from the haskell mode."
+ (error (concat "Haskell mode: " msg)))
+
+
+\f
+;;; ==================================================================
+;;; User customization
+;;; ==================================================================
+
+(defvar haskell-load-hook nil
+ "This hook is run when haskell is loaded in.
+This is a good place to put key bindings."
+ )
+
+(run-hooks 'haskell-load-hook)
+
+
+
+\f
+;;;======================================================================
+;;; Tutorial mode setup
+;;;======================================================================
+
+;;; Set up additional key bindings for tutorial mode.
+
+(defvar ht-mode-map (make-sparse-keymap))
+
+(haskell-establish-key-bindings ht-mode-map)
+(define-key ht-mode-map "\C-c\C-f" 'ht-next-page)
+(define-key ht-mode-map "\C-c\C-b" 'ht-prev-page)
+(define-key ht-mode-map "\C-c\C-l" 'ht-restore-page)
+(define-key ht-mode-map "\C-c?" 'describe-mode)
+
+(defun haskell-tutorial-mode ()
+ "Major mode for running the Haskell tutorial.
+You can use these commands:
+\\{ht-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map ht-mode-map)
+ (setq major-mode 'haskell-tutorial-mode)
+ (setq mode-name "Haskell Tutorial")
+ (set-syntax-table haskell-mode-syntax-table)
+ (run-hooks 'haskell-mode-hook))
+
+
+(defun haskell-tutorial ()
+ "Run the haskell tutorial."
+ (interactive)
+ (ht-load-tutorial)
+ (ht-make-buffer)
+ (ht-display-page)
+ (haskell-maybe-create-process)
+ (haskell-send-to-process ":(emacs-set-printers '(interactive))")
+ )
+
+
+;;; Load the tutorial file into a read-only buffer. Do not display this
+;;; buffer.
+
+(defun ht-load-tutorial ()
+ (let ((buffer (get-buffer *ht-file-buffer*)))
+ (if buffer
+ (save-excursion
+ (set-buffer buffer)
+ (beginning-of-buffer))
+ (save-excursion
+ (set-buffer (setq buffer (get-buffer-create *ht-file-buffer*)))
+ (let ((fname (substitute-in-file-name *ht-source-file*)))
+ (if (file-readable-p fname)
+ (ht-load-tutorial-aux fname)
+ (call-interactively 'ht-load-tutorial-aux)))))))
+
+(defun ht-load-tutorial-aux (filename)
+ (interactive "fTutorial file: ")
+ (insert-file filename)
+ (set-buffer-modified-p nil)
+ (setq buffer-read-only t)
+ (beginning-of-buffer))
+
+
+;;; Create a buffer to use for messing about with each page of the tutorial.
+;;; Put the buffer into haskell-tutorial-mode.
+
+(defun ht-make-buffer ()
+ (find-file (concat "/tmp/" (make-temp-name "ht") ".lhs"))
+ (setq *ht-temp-buffer* (buffer-name))
+ (haskell-tutorial-mode))
+
+
+;;; Commands for loading text into the tutorial pad buffer
+
+(defun ht-next-page ()
+ "Go to the next tutorial page."
+ (interactive)
+ (if (ht-goto-next-page)
+ (ht-display-page)
+ (beep)))
+
+(defun ht-goto-next-page ()
+ (let ((buff (current-buffer)))
+ (unwind-protect
+ (progn
+ (set-buffer *ht-file-buffer*)
+ (search-forward "\C-l" nil t))
+ (set-buffer buff))))
+
+(defun ht-prev-page ()
+ "Go to the previous tutorial page."
+ (interactive)
+ (if (ht-goto-prev-page)
+ (ht-display-page)
+ (beep)))
+
+(defun ht-goto-prev-page ()
+ (let ((buff (current-buffer)))
+ (unwind-protect
+ (progn
+ (set-buffer *ht-file-buffer*)
+ (search-backward "\C-l" nil t))
+ (set-buffer buff))))
+
+(defun ht-goto-page (arg)
+ "Go to the tutorial page specified as the argument."
+ (interactive "sGo to page: ")
+ (if (ht-searchfor-page (format "Page: %s " arg))
+ (ht-display-page)
+ (beep)))
+
+(defun ht-goto-section (arg)
+ "Go to the tutorial section specified as the argument."
+ (interactive "sGo to section: ")
+ (if (ht-searchfor-page (format "Section: %s " arg))
+ (ht-display-page)
+ (beep)))
+
+(defun ht-searchfor-page (search-string)
+ (let ((buff (current-buffer)))
+ (unwind-protect
+ (progn
+ (set-buffer *ht-file-buffer*)
+ (let ((point (point)))
+ (beginning-of-buffer)
+ (if (search-forward search-string nil t)
+ t
+ (progn
+ (goto-char point)
+ nil))))
+ (set-buffer buff))))
+
+(defun ht-restore-page ()
+ (interactive)
+ (let ((old-point (point)))
+ (ht-display-page)
+ (goto-char old-point)))
+
+(defun ht-display-page ()
+ (set-buffer *ht-file-buffer*)
+ (let* ((beg (progn
+ (if (search-backward "\C-l" nil t)
+ (forward-line 1)
+ (beginning-of-buffer))
+ (point)))
+ (end (progn
+ (if (search-forward "\C-l" nil t)
+ (beginning-of-line)
+ (end-of-buffer))
+ (point)))
+ (text (buffer-substring beg end)))
+ (set-buffer *ht-temp-buffer*)
+ (erase-buffer)
+ (insert text)
+ (beginning-of-buffer)))
+
+
+\f
+;;;======================================================================
+;;; Menu bar stuff
+;;;======================================================================
+
+;;; This only works in Emacs version 19, so it's in a separate file for now.
+
+(if (featurep 'menu-bar)
+ (load-library "haskell-menu"))
--- /dev/null
+Optimizer switches
+ inline Aggressively inline functions
+ constant Hoist constant expressions to top-level
+ foldr Perform foldr/build deforestation
+ lisp Tell the Lisp compiler to work hard to produce best code
+ delays Try to make delays out-of-line for more compact code
--- /dev/null
+General messages
+ compiling Printed when the compilation system starts a compilation
+ loading Printed when a previously compiled unit is loaded
+ reading Prints the name of the file being parsed
+ pad Enables printing within scratch pads
+ interactive Print verbose messages in command loop
+ prompt Print prompt in command loop
+Timings
+ time Prints the time that it takes to execute a computation
+ phase-time Prints the time of each phase of compilation
+Compiler passes
+ parse Prints the program recreated from ast
+ import Lists all symbols imported and exported for each module
+ scope Print the program after scoping and precedence parsing
+ depend Prints entire program in nested let's
+ type Prints signatures during inference
+ cfn Prints entire program after context free normalization
+ depend2 Like depend
+ flic Prints entire program as flic code
+ optimize Prints entire program as optimized flic code
+ optimize-extra Prints extra verbose information during optimization
+ strictness Print strictness of all functions and variables
+ codegen Prints generated Lisp code
+ codegen-flic Prints generated Lisp code and associated flic code
+ dumper Prints the code in the interface
+ dump-stat Prints statistics for the interface file
#define NATIVEGEN_SRCS_LHS /*none*/
#else
#define __omit_ncg_maybe /*none*/
+#if i386_TARGET_ARCH
+#define __machdep_nativegen_lhs \
+nativeGen/I386Desc.lhs \
+nativeGen/I386Code.lhs \
+nativeGen/I386Gen.lhs
+#define __ghci_machdep_nativegen_lhs \
+nativeGen/I386Code.lhs
+#endif
#if sparc_TARGET_ARCH
#define __machdep_nativegen_lhs \
nativeGen/SparcDesc.lhs \
nativeGen/SparcGen.lhs
#define __ghci_machdep_nativegen_lhs \
nativeGen/SparcCode.lhs
-#else
+#endif
+#if alpha_TARGET_ARCH
#define __machdep_nativegen_lhs \
nativeGen/AlphaDesc.lhs \
nativeGen/AlphaCode.lhs \
compile(main/CmdLineOpts,lhs,-K2m)
compile_rec(main/Errors,lhs,)
-compile_rec(main/ErrsTc,lhs,-H20m)
+compile_rec(main/ErrsTc,lhs,-H20m if_ghc26(-monly-4-regs))
compile_rec(main/ErrsRn,lhs,)
compile_rec(main/ErrUtils,lhs,)
compile(main/Main,lhs,-H16m if_ghc(-fvia-C -fno-update-analysis)) /* ToDo: update */
compile(nativeGen/StixInteger,lhs,-H20m)
compile(nativeGen/StixMacro,lhs,-I$(NATIVEGEN_DIR))
compile(nativeGen/StixPrim,lhs,-H16m)
-#if sparc_TARGET_ARCH
+# if i386_TARGET_ARCH
+compile_rec(nativeGen/I386Desc,lhs,)
+compile(nativeGen/I386Code,lhs,-H20m -I$(NATIVEGEN_DIR) if_ghc(-monly-4-regs))
+compile(nativeGen/I386Gen,lhs,-H20m)
+# endif
+# if sparc_TARGET_ARCH
compile_rec(nativeGen/SparcDesc,lhs,)
compile(nativeGen/SparcCode,lhs,-H20m -I$(NATIVEGEN_DIR))
compile(nativeGen/SparcGen,lhs,-H20m)
-#else
+# endif
+# if alpha_TARGET_ARCH
compile_rec(nativeGen/AlphaDesc,lhs,)
compile(nativeGen/AlphaCode,lhs,-H24m -K2m -I$(NATIVEGEN_DIR))
-compile(nativeGen/AlphaGen,lhs,-H24m)
-#endif
+compile(nativeGen/AlphaGen,lhs,-H24m -K2m)
+# endif
#endif
compile_rec(prelude/AbsPrel,lhs,-H16m -K2m if_ghc(-fno-omit-reexported-instances -fno-update-analysis))
compile_rec(prelude/PrelFuns,lhs,)
compile(prelude/PrelVals,lhs,)
compile_rec(prelude/PrimKind,lhs,-I$(COMPINFO_DIR))
-compile_rec(prelude/PrimOps,lhs,-H16m -K2m)
+compile_rec(prelude/PrimOps,lhs,-H16m -K3m)
compile(prelude/TysPrim,lhs,)
compile(prelude/TysWiredIn,lhs,)
/* accumulate similar info about the sizes of object files */
count_bytes ::
./count_bytes $(ALLSRCS_LHS) $(ALLSRCS_HS)
-
-/* run the "resolve_ifaces" script (assuming you know what you are doing) */
-resolve_ifaces ::
- ./resolve_ifaces $(ALLINTS)
import PrimOps(PrimOp)
import SplitUniq(SplitUniqSupply)
import Unique(Unique)
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
-data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
+data AbstractC
+data CAddrMode
+data PrimKind
+data SplitUniqSupply
amodeCanSurviveGC :: CAddrMode -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
getAmodeKind :: CAddrMode -> PrimKind
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
kindFromMagicId :: MagicId -> PrimKind
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mixedPtrLocn :: CAddrMode -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mixedTypeLocn :: CAddrMode -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkAbsCStmtList :: AbstractC -> [AbstractC]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: AbstractC) (u1 :: AbstractC) -> _!_ _ORIG_ AbsCSyn AbsCStmts [] [u0, u1] _N_ #-}
mkAbstractCs :: [AbstractC] -> AbstractC
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: [AbstractC]) -> case u0 of { _ALG_ (:) (u1 :: AbstractC) (u2 :: [AbstractC]) -> _APP_ _TYAPP_ _ORIG_ PreludeList foldr1 { AbstractC } [ _ORIG_ AbsCFuns mkAbsCStmts, u0 ]; _NIL_ -> _!_ _ORIG_ AbsCSyn AbsCNop [] []; _NO_DEFLT_ } _N_ #-}
mkAlgAltsCSwitch :: CAddrMode -> [(Int, AbstractC)] -> AbstractC -> AbstractC
- {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _N_ _N_ _N_ #-}
nonemptyAbsC :: AbstractC -> Labda AbstractC
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
kindFromMagicId Hp = PtrKind
kindFromMagicId HpLim = PtrKind
kindFromMagicId LivenessReg = IntKind
-kindFromMagicId ActivityReg = IntKind
+--kindFromMagicId ActivityReg = IntKind -- UNUSED
kindFromMagicId StdUpdRetVecReg = PtrKind
kindFromMagicId StkStubReg = PtrKind
kindFromMagicId CurCostCentre = CostCentreKind
returnFlt (mkAbsCStmts inline_s1 inline_s2,
mkAbsCStmts top_s1 top_s2)
-flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast upd descr)
+flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast upd descr liveness)
= flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) ->
flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) ->
flatAmode upd `thenFlt` \ (upd_lbl, upd_tops) ->
returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, upd_tops,
- CClosureInfoAndCode cl_info slow_heres fast_heres upd_lbl descr]
+ CClosureInfoAndCode cl_info slow_heres fast_heres upd_lbl descr liveness]
)
where
flat_maybe :: Maybe AbstractC -> FlatM (Maybe AbstractC, AbstractC)
import BasicLit(BasicLit(..), mkMachInt, mkMachWord)
import CLabelInfo(CLabel)
import CharSeq(CSeq)
-import Class(Class)
-import ClosureInfo(ClosureInfo, LambdaFormInfo, StandardFormInfo)
+import ClosureInfo(ClosureInfo, LambdaFormInfo)
import CmdLineOpts(GlobalSwitch, SimplifierSwitch)
-import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC)
+import CostCentre(CostCentre)
import HeapOffs(HeapOffset, HpRelOffset(..), SpARelOffset(..), SpBRelOffset(..), VirtualHeapOffset(..), VirtualSpAOffset(..), VirtualSpBOffset(..), addOff, fixedHdrSize, intOff, intOffsetIntoGoods, isZeroOff, maxOff, possiblyEqualHeapOffset, pprHeapOffset, subOff, totHdrSize, varHdrSize, zeroOff)
-import Id(ConTag(..), Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(ConTag(..), Id)
import Maybes(Labda)
-import NameTypes(FullName)
import Outputable(ExportFlag, NamedThing(..), Outputable(..))
import PprAbsC(dumpRealC, writeRealC)
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
+import Pretty(PprStyle, Pretty(..), PrettyRep)
import PrimKind(PrimKind(..))
import PrimOps(PrimOp)
-import SMRep(SMRep, SMSpecRepKind, SMUpdateKind)
+import SMRep(SMRep)
import SplitUniq(SplitUniqSupply)
import SrcLoc(SrcLoc)
import Stdio(_FILE)
-import StgSyn(StgAtom, StgBinding, StgCaseAlternatives, StgExpr, UpdateFlag)
+import StgSyn(StgAtom, StgExpr, UpdateFlag)
import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
import UniType(UniType)
import UniqFM(UniqFM)
import UniqSet(UniqSet(..))
import Unpretty(Unpretty(..))
class NamedThing a where
getExportFlag :: a -> ExportFlag
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-}
isLocallyDefined :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-}
getOrigName :: a -> (_PackedString, _PackedString)
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-}
getOccurrenceName :: a -> _PackedString
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-}
getInformingModules :: a -> [_PackedString]
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-}
getSrcLoc :: a -> SrcLoc
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-}
getTheUnique :: a -> Unique
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-}
hasType :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-}
getType :: a -> UniType
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-}
fromPreludeCore :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-}
class Outputable a where
ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_
- {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-}
-data AbstractC = AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker
+data AbstractC = AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] Int | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker
data BasicLit = MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer)
data CAddrMode = CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool
data CExprMacro = INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG
data CLabel
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
+data CSeq
data CStmtMacro = ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG
-data ClosureInfo {-# GHC_PRAGMA MkClosureInfo Id LambdaFormInfo SMRep #-}
-data LambdaFormInfo {-# GHC_PRAGMA LFReEntrant Bool Int Bool | LFCon Id Bool | LFTuple Id Bool | LFThunk Bool Bool Bool StandardFormInfo | LFArgument | LFImported | LFLetNoEscape Int (UniqFM Id) | LFBlackHole | LFIndirection #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data SimplifierSwitch {-# GHC_PRAGMA SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings #-}
-data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-}
+data ClosureInfo
+data LambdaFormInfo
+data GlobalSwitch
+data SimplifierSwitch
+data CostCentre
data HeapOffset
type HpRelOffset = HeapOffset
data MagicId = BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg
type VirtualSpAOffset = Int
type VirtualSpBOffset = Int
type ConTag = Int
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data Id
+data Labda a
+data ExportFlag
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
+data PrettyRep
data PrimKind = PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
-data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-}
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data StgAtom a {-# GHC_PRAGMA StgVarAtom a | StgLitAtom BasicLit #-}
-data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-}
-data UpdateFlag {-# GHC_PRAGMA ReEntrant | Updatable | SingleEntry #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data PrimOp
+data SMRep
+data SplitUniqSupply
+data SrcLoc
+data StgAtom a
+data StgExpr a b
+data UpdateFlag
+data TyCon
+data UniType
+data UniqFM a
type UniqSet a = UniqFM a
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Unique
type Unpretty = CSeq
amodeCanSurviveGC :: CAddrMode -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
getAmodeKind :: CAddrMode -> PrimKind
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
kindFromMagicId :: MagicId -> PrimKind
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mixedPtrLocn :: CAddrMode -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mixedTypeLocn :: CAddrMode -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkAbsCStmtList :: AbstractC -> [AbstractC]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: AbstractC) (u1 :: AbstractC) -> _!_ _ORIG_ AbsCSyn AbsCStmts [] [u0, u1] _N_ #-}
mkAbstractCs :: [AbstractC] -> AbstractC
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: [AbstractC]) -> case u0 of { _ALG_ (:) (u1 :: AbstractC) (u2 :: [AbstractC]) -> _APP_ _TYAPP_ _ORIG_ PreludeList foldr1 { AbstractC } [ _ORIG_ AbsCFuns mkAbsCStmts, u0 ]; _NIL_ -> _!_ _ORIG_ AbsCSyn AbsCNop [] []; _NO_DEFLT_ } _N_ #-}
mkAlgAltsCSwitch :: CAddrMode -> [(Int, AbstractC)] -> AbstractC -> AbstractC
- {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _N_ _N_ _N_ #-}
nonemptyAbsC :: AbstractC -> Labda AbstractC
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
mkMachInt :: Integer -> BasicLit
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkMachWord :: Integer -> BasicLit
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
addOff :: HeapOffset -> HeapOffset -> HeapOffset
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
fixedHdrSize :: HeapOffset
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
dumpRealC :: (GlobalSwitch -> Bool) -> AbstractC -> [Char]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
infoptr :: MagicId
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intOff :: Int -> HeapOffset
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
intOffsetIntoGoods :: HeapOffset -> Labda Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isVolatileReg :: MagicId -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: MagicId) -> _!_ True [] [] _N_ #-}
isZeroOff :: HeapOffset -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
maxOff :: HeapOffset -> HeapOffset -> HeapOffset
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
mkCCostCentre :: CostCentre -> CAddrMode
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkIntCLit :: Int -> CAddrMode
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
node :: MagicId
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
possiblyEqualHeapOffset :: HeapOffset -> HeapOffset -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
pprHeapOffset :: PprStyle -> HeapOffset -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
subOff :: HeapOffset -> HeapOffset -> HeapOffset
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
totHdrSize :: SMRep -> HeapOffset
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
varHdrSize :: SMRep -> HeapOffset
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
zeroOff :: HeapOffset
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
writeRealC :: (GlobalSwitch -> Bool) -> _FILE -> AbstractC -> _State _RealWorld -> ((), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _S_ "LU(P)LL" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Eq MagicId
- {-# GHC_PRAGMA _M_ AbsCSyn {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(MagicId -> MagicId -> Bool), (MagicId -> MagicId -> Bool)] [_CONSTM_ Eq (==) (MagicId), _CONSTM_ Eq (/=) (MagicId)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Eq BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool)] [_CONSTM_ Eq (==) (BasicLit), _CONSTM_ Eq (/=) (BasicLit)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq CLabel
- {-# GHC_PRAGMA _M_ CLabelInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool)] [_CONSTM_ Eq (==) (CLabel), _CONSTM_ Eq (/=) (CLabel)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq GlobalSwitch
- {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool)] [_CONSTM_ Eq (==) (GlobalSwitch), _CONSTM_ Eq (/=) (GlobalSwitch)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Eq SimplifierSwitch
- {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool)] [_CONSTM_ Eq (==) (SimplifierSwitch), _CONSTM_ Eq (/=) (SimplifierSwitch)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Eq Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool)] [_CONSTM_ Eq (==) (PrimKind), _CONSTM_ Eq (/=) (PrimKind)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Eq PrimOp
- {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimOp -> PrimOp -> Bool), (PrimOp -> PrimOp -> Bool)] [_CONSTM_ Eq (==) (PrimOp), _CONSTM_ Eq (/=) (PrimOp)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: PrimOp) (u1 :: PrimOp) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u0 ] of { _PRIM_ (u2 :: Int#) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u1 ] of { _PRIM_ (u3 :: Int#) -> _#_ eqInt# [] [u2, u3] } } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Eq Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Ord BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq BasicLit}}, (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> _CMP_TAG)] [_DFUN_ Eq (BasicLit), _CONSTM_ Ord (<) (BasicLit), _CONSTM_ Ord (<=) (BasicLit), _CONSTM_ Ord (>=) (BasicLit), _CONSTM_ Ord (>) (BasicLit), _CONSTM_ Ord max (BasicLit), _CONSTM_ Ord min (BasicLit), _CONSTM_ Ord _tagCmp (BasicLit)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord CLabel
- {-# GHC_PRAGMA _M_ CLabelInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq CLabel}}, (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> CLabel), (CLabel -> CLabel -> CLabel), (CLabel -> CLabel -> _CMP_TAG)] [_DFUN_ Eq (CLabel), _CONSTM_ Ord (<) (CLabel), _CONSTM_ Ord (<=) (CLabel), _CONSTM_ Ord (>=) (CLabel), _CONSTM_ Ord (>) (CLabel), _CONSTM_ Ord max (CLabel), _CONSTM_ Ord min (CLabel), _CONSTM_ Ord _tagCmp (CLabel)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord GlobalSwitch
- {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq GlobalSwitch}}, (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> _CMP_TAG)] [_DFUN_ Eq (GlobalSwitch), _CONSTM_ Ord (<) (GlobalSwitch), _CONSTM_ Ord (<=) (GlobalSwitch), _CONSTM_ Ord (>=) (GlobalSwitch), _CONSTM_ Ord (>) (GlobalSwitch), _CONSTM_ Ord max (GlobalSwitch), _CONSTM_ Ord min (GlobalSwitch), _CONSTM_ Ord _tagCmp (GlobalSwitch)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Ord SimplifierSwitch
- {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq SimplifierSwitch}}, (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> SimplifierSwitch), (SimplifierSwitch -> SimplifierSwitch -> SimplifierSwitch), (SimplifierSwitch -> SimplifierSwitch -> _CMP_TAG)] [_DFUN_ Eq (SimplifierSwitch), _CONSTM_ Ord (<) (SimplifierSwitch), _CONSTM_ Ord (<=) (SimplifierSwitch), _CONSTM_ Ord (>=) (SimplifierSwitch), _CONSTM_ Ord (>) (SimplifierSwitch), _CONSTM_ Ord max (SimplifierSwitch), _CONSTM_ Ord min (SimplifierSwitch), _CONSTM_ Ord _tagCmp (SimplifierSwitch)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Ord Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq PrimKind}}, (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> _CMP_TAG)] [_DFUN_ Eq (PrimKind), _CONSTM_ Ord (<) (PrimKind), _CONSTM_ Ord (<=) (PrimKind), _CONSTM_ Ord (>=) (PrimKind), _CONSTM_ Ord (>) (PrimKind), _CONSTM_ Ord max (PrimKind), _CONSTM_ Ord min (PrimKind), _CONSTM_ Ord _tagCmp (PrimKind)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Ord Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_,
- getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance (Outputable a, Outputable b) => Outputable (a, b)
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-}
instance Outputable BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BasicLit) _N_
- ppr = _A_ 0 _U_ 2122 _N_ _N_ _N_ _N_ #-}
instance Outputable Bool
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_
- ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance Outputable PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (PrimKind) _N_
- ppr = _A_ 2 _U_ 0120 _N_ _S_ "AL" {_A_ 1 _U_ 120 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable PrimOp
- {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ #-}
instance Outputable a => Outputable (StgAtom a)
- {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _F_ _IF_ARGS_ 1 3 XXC 8 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: StgAtom u0) -> case u3 of { _ALG_ _ORIG_ StgSyn StgVarAtom (u4 :: u0) -> _APP_ u1 [ u2, u4 ]; _ORIG_ StgSyn StgLitAtom (u5 :: BasicLit) -> _APP_ _CONSTM_ Outputable ppr (BasicLit) [ u2, u5 ]; _NO_DEFLT_ } _N_ #-}
instance (Outputable a, Outputable b, Ord b) => Outputable (StgExpr a b)
- {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable [a]
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Text CExprMacro
- {-# GHC_PRAGMA _M_ AbsCSyn {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(CExprMacro, [Char])]), (Int -> CExprMacro -> [Char] -> [Char]), ([Char] -> [([CExprMacro], [Char])]), ([CExprMacro] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (CExprMacro), _CONSTM_ Text showsPrec (CExprMacro), _CONSTM_ Text readList (CExprMacro), _CONSTM_ Text showList (CExprMacro)] _N_
- readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(CExprMacro, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text CStmtMacro
- {-# GHC_PRAGMA _M_ AbsCSyn {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(CStmtMacro, [Char])]), (Int -> CStmtMacro -> [Char] -> [Char]), ([Char] -> [([CStmtMacro], [Char])]), ([CStmtMacro] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (CStmtMacro), _CONSTM_ Text showsPrec (CStmtMacro), _CONSTM_ Text readList (CStmtMacro), _CONSTM_ Text showList (CStmtMacro)] _N_
- readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(CStmtMacro, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_
- readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_,
- showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
-- ClosureInfo, because the latter refers to the *right* hand
-- side of a defn, whereas the "description" refers to *left*
-- hand side
+ Int -- Liveness info; this is here because it is
+ -- easy to produce w/in the CgMonad; hard
+ -- thereafter. (WDP 95/11)
| CRetVector -- Return vector with "holes"
-- (Nothings) for the default
| LivenessReg -- (parallel only) used when we need to record explicitly
-- what registers are live
- | ActivityReg -- mentioned only in nativeGen
+ | ActivityReg -- mentioned only in nativeGen (UNUSED)
| StdUpdRetVecReg -- mentioned only in nativeGen
| StkStubReg -- register holding STK_STUB_closure (for stubbing dead stack slots)
tagOf_MagicId Hp = ILIT(8)
tagOf_MagicId HpLim = ILIT(9)
tagOf_MagicId LivenessReg = ILIT(10)
-tagOf_MagicId ActivityReg = ILIT(11)
+--tagOf_MagicId ActivityReg = ILIT(11) -- UNUSED
tagOf_MagicId StdUpdRetVecReg = ILIT(12)
tagOf_MagicId StkStubReg = ILIT(13)
tagOf_MagicId CurCostCentre = ILIT(14)
data CostRes = Cost (Int, Int, Int, Int, Int)
data Side = Lhs | Rhs
addrModeCosts :: CAddrMode -> Side -> CostRes
- {-# GHC_PRAGMA _A_ 2 _U_ 00 _N_ _S_ "AA" {_A_ 0 _N_ _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: CAddrMode) (u1 :: Side) -> _ORIG_ Costs nullCosts _N_ #-}
costs :: AbstractC -> CostRes
- {-# GHC_PRAGMA _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: AbstractC) -> _ORIG_ Costs nullCosts _N_ #-}
nullCosts :: CostRes
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
instance Eq CostRes
- {-# GHC_PRAGMA _M_ Costs {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(CostRes -> CostRes -> Bool), (CostRes -> CostRes -> Bool)] [_CONSTM_ Eq (==) (CostRes), _CONSTM_ Eq (/=) (CostRes)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: CostRes) (u1 :: CostRes) -> _APP_ _TYAPP_ patError# { (CostRes -> CostRes -> Bool) } [ _NOREP_S_ "%DPreludeCore.Eq.(==)\"", u0, u1 ] _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Num CostRes
- {-# GHC_PRAGMA _M_ Costs {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [{{Eq CostRes}}, {{Text CostRes}}, (CostRes -> CostRes -> CostRes), (CostRes -> CostRes -> CostRes), (CostRes -> CostRes -> CostRes), (CostRes -> CostRes), (CostRes -> CostRes), (CostRes -> CostRes), (Integer -> CostRes), (Int -> CostRes)] [_DFUN_ Eq (CostRes), _DFUN_ Text (CostRes), _CONSTM_ Num (+) (CostRes), _CONSTM_ Num (-) (CostRes), _CONSTM_ Num (*) (CostRes), _CONSTM_ Num negate (CostRes), _CONSTM_ Num abs (CostRes), _CONSTM_ Num signum (CostRes), _CONSTM_ Num fromInteger (CostRes), _CONSTM_ Num fromInt (CostRes)] _N_
- (+) = _A_ 2 _U_ 00 _N_ _S_ "AA" {_A_ 0 _N_ _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: CostRes) (u1 :: CostRes) -> _ORIG_ Costs nullCosts _N_,
- (-) = _A_ 2 _U_ 00 _N_ _S_ "AA" {_A_ 0 _N_ _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: CostRes) (u1 :: CostRes) -> _ORIG_ Costs nullCosts _N_,
- (*) = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: CostRes) (u1 :: CostRes) -> _APP_ _TYAPP_ patError# { (CostRes -> CostRes -> CostRes) } [ _NOREP_S_ "%DPreludeCore.Num.(*)\"", u0, u1 ] _N_,
- negate = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: CostRes) -> _APP_ _TYAPP_ patError# { (CostRes -> CostRes) } [ _NOREP_S_ "%DPreludeCore.Num.negate\"", u0 ] _N_,
- abs = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: CostRes) -> _APP_ _TYAPP_ patError# { (CostRes -> CostRes) } [ _NOREP_S_ "%DPreludeCore.Num.abs\"", u0 ] _N_,
- signum = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: CostRes) -> _APP_ _TYAPP_ patError# { (CostRes -> CostRes) } [ _NOREP_S_ "%DPreludeCore.Num.signum\"", u0 ] _N_,
- fromInteger = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Integer) -> _APP_ _TYAPP_ patError# { (Integer -> CostRes) } [ _NOREP_S_ "%DPreludeCore.Num.fromInteger\"", u0 ] _N_,
- fromInt = _A_ 1 _U_ 1 _N_ _S_ _!_ _N_ _N_ #-}
instance Text CostRes
- {-# GHC_PRAGMA _M_ Costs {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(CostRes, [Char])]), (Int -> CostRes -> [Char] -> [Char]), ([Char] -> [([CostRes], [Char])]), ([CostRes] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (CostRes), _CONSTM_ Text showsPrec (CostRes), _CONSTM_ Text readList (CostRes), _CONSTM_ Text showList (CostRes)] _N_
- readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(CostRes, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 3 _U_ 222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: CostRes) (u2 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> CostRes -> [Char] -> [Char]) } [ _NOREP_S_ "%DPreludeCore.Text.showsPrec\"", u0, u1, u2 ] _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
CStaticClosure _ _ _ _ -> nullCosts
- CClosureInfoAndCode _ _ _ _ _ -> nullCosts
+ CClosureInfoAndCode _ _ _ _ _ _ -> nullCosts
CRetVector _ _ _ -> nullCosts
primOpCosts IntMulOp = Cost (3, 1, 0, 0, 0) + umul_costs
primOpCosts IntQuotOp = Cost (3, 1, 0, 0, 0) + div_costs
-primOpCosts IntDivOp = Cost (3, 1, 0, 0, 0) -- div dclosure already costed
primOpCosts IntRemOp = Cost (3, 1, 0, 0, 0) + rem_costs
primOpCosts IntNegOp = Cost (1, 1, 0, 0, 0) -- translates into 1 sub
primOpCosts IntAbsOp = Cost (0, 1, 0, 0, 0) -- abs closure already costed
-- but these take more than that; see special cases in primOpCosts
-- I counted the generated ass. instructions for these -> checked
| IntMulOp | IntQuotOp
- | IntDivOp | IntRemOp | IntNegOp | IntAbsOp
+ | IntRemOp | IntNegOp | IntAbsOp
-- Rest is unchecked so far -- HWL
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface HeapOffs where
import CharSeq(CSeq)
+import MachDesc(Target)
import Maybes(Labda)
import Pretty(PprStyle)
import SMRep(SMRep)
type VirtualSpAOffset = Int
type VirtualSpBOffset = Int
addOff :: HeapOffset -> HeapOffset -> HeapOffset
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
fixedHdrSize :: HeapOffset
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+hpRelToInt :: Target -> HeapOffset -> Int
intOff :: Int -> HeapOffset
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
intOffsetIntoGoods :: HeapOffset -> Labda Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isZeroOff :: HeapOffset -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
maxOff :: HeapOffset -> HeapOffset -> HeapOffset
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
possiblyEqualHeapOffset :: HeapOffset -> HeapOffset -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
pprHeapOffset :: PprStyle -> HeapOffset -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
subOff :: HeapOffset -> HeapOffset -> HeapOffset
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
totHdrSize :: SMRep -> HeapOffset
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
varHdrSize :: SMRep -> HeapOffset
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
zeroOff :: HeapOffset
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
import PrimOps(PrimOp)
import Stdio(_FILE)
import Unique(Unique)
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
-data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-}
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data AbstractC
+data CAddrMode
+data MagicId
+data CSeq
+data PprStyle
dumpRealC :: (GlobalSwitch -> Bool) -> AbstractC -> [Char]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
+pprAmode :: PprStyle -> CAddrMode -> CSeq
writeRealC :: (GlobalSwitch -> Bool) -> _FILE -> AbstractC -> _State _RealWorld -> ((), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _S_ "LU(P)LL" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
};
-}
-pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr) _
+pprAbsC sty stmt@(CClosureInfoAndCode cl_info slow maybe_fast upd cl_descr liveness) _
= uppAboves [
uppBesides [
pp_info_rep,
then uppBeside (pprCLabel sty (closureLabelFromCI cl_info)) uppComma
else uppNil,
- pprCLabel sty slow_lbl, uppComma,
- pprAmode sty upd, uppComma,
- uppInt (dataConLiveness cl_info), uppComma,
+ pprCLabel sty slow_lbl, uppComma,
+ pprAmode sty upd, uppComma,
+ uppInt liveness, uppComma,
- pp_tag, uppComma,
- pp_size, uppComma,
- pp_ptr_wds, uppComma,
+ pp_tag, uppComma,
+ pp_size, uppComma,
+ pp_ptr_wds, uppComma,
ppLocalness info_lbl, uppComma,
ppLocalnessMacro True{-function-} slow_lbl, uppComma,
uppPStr SLIT("CALLER_SAVE_SpB"),
uppPStr SLIT("CALLER_SAVE_SuB"),
uppPStr SLIT("CALLER_SAVE_Ret"),
- uppPStr SLIT("CALLER_SAVE_Activity"),
+-- uppPStr SLIT("CALLER_SAVE_Activity"),
uppPStr SLIT("CALLER_SAVE_Hp"),
uppPStr SLIT("CALLER_SAVE_HpLim") ]
uppPStr SLIT("CALLER_RESTORE_SpB"),
uppPStr SLIT("CALLER_RESTORE_SuB"),
uppPStr SLIT("CALLER_RESTORE_Ret"),
- uppPStr SLIT("CALLER_RESTORE_Activity"),
+-- uppPStr SLIT("CALLER_RESTORE_Activity"),
uppPStr SLIT("CALLER_RESTORE_Hp"),
uppPStr SLIT("CALLER_RESTORE_HpLim"),
uppPStr SLIT("CALLER_RESTORE_StdUpdRetVec"),
pprMagicId sty Hp = uppPStr SLIT("Hp")
pprMagicId sty HpLim = uppPStr SLIT("HpLim")
pprMagicId sty LivenessReg = uppPStr SLIT("LivenessReg")
-pprMagicId sty ActivityReg = uppPStr SLIT("ActivityReg")
+--UNUSED pprMagicId sty ActivityReg = uppPStr SLIT("ActivityReg")
pprMagicId sty StdUpdRetVecReg = uppPStr SLIT("StdUpdRetVecReg")
pprMagicId sty StkStubReg = uppPStr SLIT("StkStubReg")
pprMagicId sty CurCostCentre = uppPStr SLIT("CCC")
-- ToDo: strictly speaking, should chk "cost_centre" amode
= ppr_decls_Amodes amodes
-ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl closure_descr)
+ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast upd_lbl _ _)
= ppr_decls_Amodes [entry_lbl, upd_lbl] `thenTE` \ p1 ->
ppr_decls_AbsC slow `thenTE` \ p2 ->
(case maybe_fast of
import AbsSynFuns(cmpInstanceTypes, collectBinders, collectMonoBinders, collectMonoBindersAndLocs, collectPatBinders, collectQualBinders, collectTopLevelBinders, collectTypedBinders, collectTypedPatBinders, extractMonoTyNames, getNonPrelOuterTyCon, mkDictApp, mkDictLam, mkTyApp, mkTyLam)
import Bag(Bag)
import BasicLit(BasicLit)
-import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
+import BinderInfo(BinderInfo)
import CharSeq(CSeq)
-import Class(Class, ClassOp, cmpClass)
+import Class(Class, ClassOp)
import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
+import CoreSyn(CoreAtom, CoreExpr)
import FiniteMap(FiniteMap)
import HsBinds(Bind(..), Binds(..), MonoBinds(..), ProtoNameBind(..), ProtoNameBinds(..), ProtoNameClassOpSig(..), ProtoNameMonoBinds(..), ProtoNameSig(..), RenamedBind(..), RenamedBinds(..), RenamedClassOpSig(..), RenamedMonoBinds(..), RenamedSig(..), Sig(..), TypecheckedBind(..), TypecheckedBinds(..), TypecheckedMonoBinds(..), nullBinds, nullMonoBinds)
import HsCore(UfCostCentre, UfId, UnfoldingCoreAlts, UnfoldingCoreAtom, UnfoldingCoreBinding, UnfoldingCoreExpr, UnfoldingPrimOp)
import HsPat(InPat(..), ProtoNamePat(..), RenamedPat(..), TypecheckedPat(..), irrefutablePat, isConPat, isLitPat, patsAreAllCons, patsAreAllLits, typeOfPat, unfailablePat, unfailablePats)
import HsPragmas(ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas, ImpStrictness, ImpUnfolding, InstancePragmas, ProtoNameClassOpPragmas(..), ProtoNameClassPragmas(..), ProtoNameDataPragmas(..), ProtoNameGenPragmas(..), ProtoNameInstancePragmas(..), RenamedClassOpPragmas(..), RenamedClassPragmas(..), RenamedDataPragmas(..), RenamedGenPragmas(..), RenamedInstancePragmas(..), TypePragmas)
import HsTypes(ClassAssertion(..), Context(..), MonoType(..), PolyType(..), ProtoNameContext(..), ProtoNameMonoType(..), ProtoNamePolyType(..), RenamedContext(..), RenamedMonoType(..), RenamedPolyType(..), cmpPolyType, eqMonoType, pprContext)
-import Id(DictVar(..), Id, IdDetails)
+import Id(DictVar(..), Id)
import IdEnv(IdEnv(..))
-import IdInfo(ArgUsage, ArgUsageInfo, ArityInfo, DeforestInfo, Demand, DemandInfo, FBConsum, FBProd, FBType, FBTypeInfo, IdInfo, OptIdInfo(..), SpecEnv, SpecInfo, StrictnessInfo, UpdateInfo)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import InstEnv(InstTemplate)
+import IdInfo(ArgUsage, ArgUsageInfo, ArityInfo, DeforestInfo, Demand, DemandInfo, FBConsum, FBProd, FBType, FBTypeInfo, IdInfo, OptIdInfo(..), SpecEnv, StrictnessInfo, UpdateInfo)
+import Inst(Inst)
import Maybes(Labda)
import Name(Name(..))
-import NameTypes(FullName, Provenance, ShortName)
+import NameTypes(FullName, ShortName)
import Outputable(ExportFlag, NamedThing(..), Outputable(..))
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
import PrimKind(PrimKind)
-import PrimOps(PrimOp, pprPrimOp)
+import PrimOps(PrimOp)
import ProtoName(ProtoName)
import RenameAuxFuns(PreludeNameFun(..))
-import SimplEnv(UnfoldingDetails, UnfoldingGuidance)
+import SimplEnv(UnfoldingGuidance)
import SrcLoc(SrcLoc)
-import TyCon(Arity(..), TyCon, cmpTyCon)
-import TyVar(TyVar, TyVarTemplate, cmpTyVar)
-import UniType(TauType(..), UniType, cmpUniType)
+import TyCon(Arity(..), TyCon)
+import TyVar(TyVar)
+import UniType(TauType(..), UniType)
import UniqFM(UniqFM)
import Unique(Unique)
class OptIdInfo a where
noInfo :: a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) -> _APP_ _TYAPP_ patError# { u0 } [ _NOREP_S_ "%DIdInfo.OptIdInfo.noInfo\"" ] _N_ #-}
getInfo :: IdInfo -> a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.getInfo\"", u2 ] _N_ #-}
addInfo :: IdInfo -> a -> IdInfo
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) (u3 :: u0) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0 -> IdInfo) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.addInfo\"", u2, u3 ] _N_ #-}
ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 6 _U_ 022222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 6 XXXXXX 7 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: PprStyle) (u3 :: Id -> Id) (u4 :: u0) (u5 :: Int) (u6 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.ppInfo\"", u2, u3, u4, u5, u6 ] _N_ #-}
class NamedThing a where
getExportFlag :: a -> ExportFlag
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-}
isLocallyDefined :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-}
getOrigName :: a -> (_PackedString, _PackedString)
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-}
getOccurrenceName :: a -> _PackedString
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-}
getInformingModules :: a -> [_PackedString]
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-}
getSrcLoc :: a -> SrcLoc
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-}
getTheUnique :: a -> Unique
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-}
hasType :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-}
getType :: a -> UniType
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-}
fromPreludeCore :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-}
class Outputable a where
ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_
- {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-}
-data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-}
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
-data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-}
-data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
+data Bag a
+data BasicLit
+data BinderInfo
+data Class
+data ClassOp
+data CoreAtom a
+data CoreExpr a b
+data FiniteMap a b
data Bind a b = EmptyBind | NonRecBind (MonoBinds a b) | RecBind (MonoBinds a b)
data Binds a b = EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b)
data MonoBinds a b = EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc
type TypecheckedBind = Bind Id TypecheckedPat
type TypecheckedBinds = Binds Id TypecheckedPat
type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
-data UfCostCentre a {-# GHC_PRAGMA UfPreludeDictsCC Bool | UfAllDictsCC _PackedString _PackedString Bool | UfUserCC _PackedString _PackedString _PackedString Bool Bool | UfAutoCC (UfId a) _PackedString _PackedString Bool Bool | UfDictCC (UfId a) _PackedString _PackedString Bool Bool #-}
-data UnfoldingCoreAtom a {-# GHC_PRAGMA UfCoVarAtom (UfId a) | UfCoLitAtom BasicLit #-}
-data UnfoldingCoreExpr a {-# GHC_PRAGMA UfCoVar (UfId a) | UfCoLit BasicLit | UfCoCon a [PolyType a] [UnfoldingCoreAtom a] | UfCoPrim (UnfoldingPrimOp a) [PolyType a] [UnfoldingCoreAtom a] | UfCoLam [(a, PolyType a)] (UnfoldingCoreExpr a) | UfCoTyLam a (UnfoldingCoreExpr a) | UfCoApp (UnfoldingCoreExpr a) (UnfoldingCoreAtom a) | UfCoTyApp (UnfoldingCoreExpr a) (PolyType a) | UfCoCase (UnfoldingCoreExpr a) (UnfoldingCoreAlts a) | UfCoLet (UnfoldingCoreBinding a) (UnfoldingCoreExpr a) | UfCoSCC (UfCostCentre a) (UnfoldingCoreExpr a) #-}
-data UnfoldingPrimOp a {-# GHC_PRAGMA UfCCallOp _PackedString Bool Bool [PolyType a] (PolyType a) | UfOtherOp PrimOp #-}
+data UfCostCentre a
+data UnfoldingCoreAtom a
+data UnfoldingCoreExpr a
+data UnfoldingPrimOp a
data ClassDecl a b = ClassDecl [(a, a)] a a [Sig a] (MonoBinds a b) (ClassPragmas a) SrcLoc
data ConDecl a = ConDecl a [MonoType a] SrcLoc
data DataTypeSig a = AbstractTypeSig a SrcLoc | SpecDataSig a (MonoType a) SrcLoc
type ProtoNamePat = InPat ProtoName
type RenamedPat = InPat Name
data TypecheckedPat = WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat)
-data ClassOpPragmas a {-# GHC_PRAGMA NoClassOpPragmas | ClassOpPragmas (GenPragmas a) (GenPragmas a) #-}
-data ClassPragmas a {-# GHC_PRAGMA NoClassPragmas | SuperDictPragmas [GenPragmas a] #-}
-data DataPragmas a {-# GHC_PRAGMA DataPragmas [ConDecl a] [[Labda (MonoType a)]] #-}
-data GenPragmas a {-# GHC_PRAGMA NoGenPragmas | GenPragmas (Labda Int) (Labda UpdateInfo) DeforestInfo (ImpStrictness a) (ImpUnfolding a) [([Labda (MonoType a)], Int, GenPragmas a)] #-}
-data InstancePragmas a {-# GHC_PRAGMA NoInstancePragmas | SimpleInstancePragma (GenPragmas a) | ConstantInstancePragma (GenPragmas a) [(a, GenPragmas a)] | SpecialisedInstancePragma (GenPragmas a) [([Labda (MonoType a)], Int, InstancePragmas a)] #-}
+data ClassOpPragmas a
+data ClassPragmas a
+data DataPragmas a
+data GenPragmas a
+data InstancePragmas a
type ProtoNameClassOpPragmas = ClassOpPragmas ProtoName
type ProtoNameClassPragmas = ClassPragmas ProtoName
type ProtoNameDataPragmas = DataPragmas ProtoName
type RenamedDataPragmas = DataPragmas Name
type RenamedGenPragmas = GenPragmas Name
type RenamedInstancePragmas = InstancePragmas Name
-data TypePragmas {-# GHC_PRAGMA NoTypePragmas | AbstractTySynonym #-}
+data TypePragmas
type ClassAssertion a = (a, a)
type Context a = [(a, a)]
data MonoType a = MonoTyVar a | MonoTyCon a [MonoType a] | FunMonoTy (MonoType a) (MonoType a) | ListMonoTy (MonoType a) | TupleMonoTy [PolyType a] | MonoTyVarTemplate a | MonoDict a (MonoType a)
type RenamedMonoType = MonoType Name
type RenamedPolyType = PolyType Name
type DictVar = Id
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
type IdEnv a = UniqFM a
-data ArgUsage {-# GHC_PRAGMA ArgUsage Int | UnknownArgUsage #-}
-data ArgUsageInfo {-# GHC_PRAGMA NoArgUsageInfo | SomeArgUsageInfo [ArgUsage] #-}
-data ArityInfo {-# GHC_PRAGMA UnknownArity | ArityExactly Int #-}
-data DeforestInfo {-# GHC_PRAGMA Don'tDeforest | DoDeforest #-}
-data Demand {-# GHC_PRAGMA WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum #-}
-data DemandInfo {-# GHC_PRAGMA UnknownDemand | DemandedAsPer Demand #-}
-data FBConsum {-# GHC_PRAGMA FBGoodConsum | FBBadConsum #-}
-data FBProd {-# GHC_PRAGMA FBGoodProd | FBBadProd #-}
-data FBType {-# GHC_PRAGMA FBType [FBConsum] FBProd #-}
-data FBTypeInfo {-# GHC_PRAGMA NoFBTypeInfo | SomeFBTypeInfo FBType #-}
-data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-}
-data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
+data ArgUsage
+data ArgUsageInfo
+data ArityInfo
+data DeforestInfo
+data Demand
+data DemandInfo
+data FBConsum
+data FBProd
+data FBType
+data FBTypeInfo
+data IdInfo
+data Inst
+data Labda a
data Name = Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString
-data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-}
-data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-}
+data FullName
+data ExportFlag
data Module a b = Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
+data PrettyRep
+data PrimKind
+data PrimOp
+data ProtoName
type PreludeNameFun = _PackedString -> Labda Name
type Arity = Int
type ProtoNameModule = Module ProtoName (InPat ProtoName)
type RenamedModule = Module Name (InPat Name)
-data SpecEnv {-# GHC_PRAGMA SpecEnv [SpecInfo] #-}
-data StrictnessInfo {-# GHC_PRAGMA NoStrictnessInfo | BottomGuaranteed | StrictnessInfo [Demand] (Labda Id) #-}
-data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
+data SpecEnv
+data StrictnessInfo
+data ShortName
+data SrcLoc
+data TyCon
+data TyVar
type TauType = UniType
type TypecheckedModule = Module Id TypecheckedPat
-data UpdateInfo {-# GHC_PRAGMA NoUpdateInfo | SomeUpdateInfo [Int] #-}
-data UnfoldingGuidance {-# GHC_PRAGMA UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data UpdateInfo
+data UnfoldingGuidance
+data UniType
+data UniqFM a
+data Unique
cmpInstanceTypes :: MonoType ProtoName -> MonoType ProtoName -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
collectBinders :: Bind a (InPat a) -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectMonoBinders :: MonoBinds a (InPat a) -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectMonoBindersAndLocs :: MonoBinds a (InPat a) -> [(a, SrcLoc)]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectPatBinders :: InPat a -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectQualBinders :: [Qual Name (InPat Name)] -> [Name]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectTopLevelBinders :: Binds a (InPat a) -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectTypedBinders :: Bind Id TypecheckedPat -> [Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectTypedPatBinders :: TypecheckedPat -> [Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
extractMonoTyNames :: (a -> a -> Bool) -> MonoType a -> [a]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
getNonPrelOuterTyCon :: MonoType ProtoName -> Labda ProtoName
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: MonoType ProtoName) -> case u0 of { _ALG_ _ORIG_ HsTypes MonoTyCon (u1 :: ProtoName) (u2 :: [MonoType ProtoName]) -> _!_ _ORIG_ Maybes Ni [ProtoName] [u1]; (u3 :: MonoType ProtoName) -> _!_ _ORIG_ Maybes Hamna [ProtoName] [] } _N_ #-}
mkDictApp :: Expr Id TypecheckedPat -> [Id] -> Expr Id TypecheckedPat
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _IF_ARGS_ 0 2 XC 6 \ (u0 :: Expr Id TypecheckedPat) (u1 :: [Id]) -> case u1 of { _ALG_ (:) (u2 :: Id) (u3 :: [Id]) -> _!_ _ORIG_ HsExpr DictApp [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u0; _NO_DEFLT_ } _N_ #-}
mkDictLam :: [Id] -> Expr Id TypecheckedPat -> Expr Id TypecheckedPat
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: [Id]) (u1 :: Expr Id TypecheckedPat) -> case u0 of { _ALG_ (:) (u2 :: Id) (u3 :: [Id]) -> _!_ _ORIG_ HsExpr DictLam [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-}
mkTyApp :: Expr Id TypecheckedPat -> [UniType] -> Expr Id TypecheckedPat
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _IF_ARGS_ 0 2 XC 6 \ (u0 :: Expr Id TypecheckedPat) (u1 :: [UniType]) -> case u1 of { _ALG_ (:) (u2 :: UniType) (u3 :: [UniType]) -> _!_ _ORIG_ HsExpr TyApp [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u0; _NO_DEFLT_ } _N_ #-}
mkTyLam :: [TyVar] -> Expr Id TypecheckedPat -> Expr Id TypecheckedPat
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: [TyVar]) (u1 :: Expr Id TypecheckedPat) -> case u0 of { _ALG_ (:) (u2 :: TyVar) (u3 :: [TyVar]) -> _!_ _ORIG_ HsExpr TyLam [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-}
-cmpClass :: Class -> Class -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
nullBinds :: Binds a b -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
nullMonoBinds :: MonoBinds a b -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
eqConDecls :: [ConDecl ProtoName] -> [ConDecl ProtoName] -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
getIEStrings :: [IE] -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getRawIEStrings :: [IE] -> ([(_PackedString, ExportFlag)], [_PackedString])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
negLiteral :: Literal -> Literal
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
irrefutablePat :: TypecheckedPat -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isConPat :: TypecheckedPat -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isLitPat :: TypecheckedPat -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
patsAreAllCons :: [TypecheckedPat] -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
patsAreAllLits :: [TypecheckedPat] -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
typeOfPat :: TypecheckedPat -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
unfailablePat :: TypecheckedPat -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
unfailablePats :: [TypecheckedPat] -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
cmpPolyType :: (a -> a -> Int#) -> PolyType a -> PolyType a -> Int#
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
eqMonoType :: MonoType ProtoName -> MonoType ProtoName -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
pprContext :: Outputable a => PprStyle -> [(a, a)] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22122 _N_ _S_ "LLS" _N_ _N_ #-}
-pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-}
-cmpTyCon :: TyCon -> TyCon -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-cmpTyVar :: TyVar -> TyVar -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-cmpUniType :: Bool -> UniType -> UniType -> Int#
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
instance Eq BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool)] [_CONSTM_ Eq (==) (BasicLit), _CONSTM_ Eq (/=) (BasicLit)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Class -> Class -> Bool), (Class -> Class -> Bool)] [_CONSTM_ Eq (==) (Class), _CONSTM_ Eq (/=) (Class)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ eqInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Eq (/=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Eq ClassOp
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool)] [_CONSTM_ Eq (==) (ClassOp), _CONSTM_ Eq (/=) (ClassOp)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Eq Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq Demand
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Demand -> Demand -> Bool), (Demand -> Demand -> Bool)] [_CONSTM_ Eq (==) (Demand), _CONSTM_ Eq (/=) (Demand)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq FBConsum
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(FBConsum -> FBConsum -> Bool), (FBConsum -> FBConsum -> Bool)] [_CONSTM_ Eq (==) (FBConsum), _CONSTM_ Eq (/=) (FBConsum)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Eq FBProd
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(FBProd -> FBProd -> Bool), (FBProd -> FBProd -> Bool)] [_CONSTM_ Eq (==) (FBProd), _CONSTM_ Eq (/=) (FBProd)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Eq FBType
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(FBType -> FBType -> Bool), (FBType -> FBType -> Bool)] [_CONSTM_ Eq (==) (FBType), _CONSTM_ Eq (/=) (FBType)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(LL)U(LL)" {_A_ 4 _U_ 2121 _N_ _N_ _N_ _N_} _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(LL)U(LL)" {_A_ 4 _U_ 2121 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Eq UpdateInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool)] [_CONSTM_ Eq (==) (UpdateInfo), _CONSTM_ Eq (/=) (UpdateInfo)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq Name
- {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Name -> Name -> Bool), (Name -> Name -> Bool)] [_CONSTM_ Eq (==) (Name), _CONSTM_ Eq (/=) (Name)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Name) (u1 :: Name) -> case _APP_ _ORIG_ Name cmpName [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Name) (u1 :: Name) -> case _APP_ _ORIG_ Name cmpName [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool)] [_CONSTM_ Eq (==) (PrimKind), _CONSTM_ Eq (/=) (PrimKind)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Eq PrimOp
- {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimOp -> PrimOp -> Bool), (PrimOp -> PrimOp -> Bool)] [_CONSTM_ Eq (==) (PrimOp), _CONSTM_ Eq (/=) (PrimOp)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: PrimOp) (u1 :: PrimOp) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u0 ] of { _PRIM_ (u2 :: Int#) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u1 ] of { _PRIM_ (u3 :: Int#) -> _#_ eqInt# [] [u2, u3] } } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Eq TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool)] [_CONSTM_ Eq (==) (TyCon), _CONSTM_ Eq (/=) (TyCon)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool)] [_CONSTM_ Eq (==) (TyVar), _CONSTM_ Eq (/=) (TyVar)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance OptIdInfo ArgUsageInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [ArgUsageInfo, (IdInfo -> ArgUsageInfo), (IdInfo -> ArgUsageInfo -> IdInfo), (PprStyle -> (Id -> Id) -> ArgUsageInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (ArgUsageInfo), _CONSTM_ OptIdInfo getInfo (ArgUsageInfo), _CONSTM_ OptIdInfo addInfo (ArgUsageInfo), _CONSTM_ OptIdInfo ppInfo (ArgUsageInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoArgUsageInfo [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ArgUsageInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u8; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_,
- ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAS" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance OptIdInfo ArityInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [ArityInfo, (IdInfo -> ArityInfo), (IdInfo -> ArityInfo -> IdInfo), (PprStyle -> (Id -> Id) -> ArityInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (ArityInfo), _CONSTM_ OptIdInfo getInfo (ArityInfo), _CONSTM_ OptIdInfo addInfo (ArityInfo), _CONSTM_ OptIdInfo ppInfo (ArityInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo UnknownArity [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(SAAAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ArityInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u1; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_,
- ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAS" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance OptIdInfo DeforestInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [DeforestInfo, (IdInfo -> DeforestInfo), (IdInfo -> DeforestInfo -> IdInfo), (PprStyle -> (Id -> Id) -> DeforestInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (DeforestInfo), _CONSTM_ OptIdInfo getInfo (DeforestInfo), _CONSTM_ OptIdInfo addInfo (DeforestInfo), _CONSTM_ OptIdInfo ppInfo (DeforestInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo Don'tDeforest [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAEAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: DeforestInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u7; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)E" _N_ _N_,
- ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAE" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance OptIdInfo DemandInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [DemandInfo, (IdInfo -> DemandInfo), (IdInfo -> DemandInfo -> IdInfo), (PprStyle -> (Id -> Id) -> DemandInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (DemandInfo), _CONSTM_ OptIdInfo getInfo (DemandInfo), _CONSTM_ OptIdInfo addInfo (DemandInfo), _CONSTM_ OptIdInfo ppInfo (DemandInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo UnknownDemand [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(ASAAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: DemandInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u2; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LALLLLLLLL)L" _N_ _N_,
- ppInfo = _A_ 3 _U_ 10122 _N_ _S_ "SAL" {_A_ 2 _U_ 1122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance OptIdInfo FBTypeInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [FBTypeInfo, (IdInfo -> FBTypeInfo), (IdInfo -> FBTypeInfo -> IdInfo), (PprStyle -> (Id -> Id) -> FBTypeInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (FBTypeInfo), _CONSTM_ OptIdInfo getInfo (FBTypeInfo), _CONSTM_ OptIdInfo addInfo (FBTypeInfo), _CONSTM_ OptIdInfo ppInfo (FBTypeInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoFBTypeInfo [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAASA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: FBTypeInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u9; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_,
- ppInfo = _A_ 3 _U_ 20222 _N_ _S_ "SAS" {_A_ 2 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance OptIdInfo SpecEnv
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [SpecEnv, (IdInfo -> SpecEnv), (IdInfo -> SpecEnv -> IdInfo), (PprStyle -> (Id -> Id) -> SpecEnv -> Int -> Bool -> PrettyRep)] [_ORIG_ IdInfo nullSpecEnv, _CONSTM_ OptIdInfo getInfo (SpecEnv), _CONSTM_ OptIdInfo addInfo (SpecEnv), _CONSTM_ OptIdInfo ppInfo (SpecEnv)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ IdInfo nullSpecEnv _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAU(L)AAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [SpecInfo]) -> _!_ _ORIG_ IdInfo SpecEnv [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u3; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 11 _N_ _S_ "U(LLU(L)LLLLLLL)U(L)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_,
- ppInfo = _A_ 3 _U_ 22122 _N_ _S_ "LLU(S)" {_A_ 3 _U_ 22122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance OptIdInfo StrictnessInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [StrictnessInfo, (IdInfo -> StrictnessInfo), (IdInfo -> StrictnessInfo -> IdInfo), (PprStyle -> (Id -> Id) -> StrictnessInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (StrictnessInfo), _CONSTM_ OptIdInfo getInfo (StrictnessInfo), _CONSTM_ OptIdInfo addInfo (StrictnessInfo), _CONSTM_ OptIdInfo ppInfo (StrictnessInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoStrictnessInfo [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAASAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StrictnessInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u4; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_,
- ppInfo = _A_ 3 _U_ 22122 _N_ _S_ "LLS" _N_ _N_ #-}
instance OptIdInfo UpdateInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [UpdateInfo, (IdInfo -> UpdateInfo), (IdInfo -> UpdateInfo -> IdInfo), (PprStyle -> (Id -> Id) -> UpdateInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (UpdateInfo), _CONSTM_ OptIdInfo getInfo (UpdateInfo), _CONSTM_ OptIdInfo addInfo (UpdateInfo), _CONSTM_ OptIdInfo ppInfo (UpdateInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoUpdateInfo [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAASAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UpdateInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u6; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_,
- ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAS" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq BasicLit}}, (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> _CMP_TAG)] [_DFUN_ Eq (BasicLit), _CONSTM_ Ord (<) (BasicLit), _CONSTM_ Ord (<=) (BasicLit), _CONSTM_ Ord (>=) (BasicLit), _CONSTM_ Ord (>) (BasicLit), _CONSTM_ Ord max (BasicLit), _CONSTM_ Ord min (BasicLit), _CONSTM_ Ord _tagCmp (BasicLit)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Class}}, (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Class), (Class -> Class -> Class), (Class -> Class -> _CMP_TAG)] [_DFUN_ Eq (Class), _CONSTM_ Ord (<) (Class), _CONSTM_ Ord (<=) (Class), _CONSTM_ Ord (>=) (Class), _CONSTM_ Ord (>) (Class), _CONSTM_ Ord max (Class), _CONSTM_ Ord min (Class), _CONSTM_ Ord _tagCmp (Class)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ ltInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ leInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord ClassOp
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq ClassOp}}, (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> _CMP_TAG)] [_DFUN_ Eq (ClassOp), _CONSTM_ Ord (<) (ClassOp), _CONSTM_ Ord (<=) (ClassOp), _CONSTM_ Ord (>=) (ClassOp), _CONSTM_ Ord (>) (ClassOp), _CONSTM_ Ord max (ClassOp), _CONSTM_ Ord min (ClassOp), _CONSTM_ Ord _tagCmp (ClassOp)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ ltInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ leInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ geInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ geInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ gtInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ gtInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Ord Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord Demand
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Demand}}, (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Demand), (Demand -> Demand -> Demand), (Demand -> Demand -> _CMP_TAG)] [_DFUN_ Eq (Demand), _CONSTM_ Ord (<) (Demand), _CONSTM_ Ord (<=) (Demand), _CONSTM_ Ord (>=) (Demand), _CONSTM_ Ord (>) (Demand), _CONSTM_ Ord max (Demand), _CONSTM_ Ord min (Demand), _CONSTM_ Ord _tagCmp (Demand)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord UpdateInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq UpdateInfo}}, (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> UpdateInfo), (UpdateInfo -> UpdateInfo -> UpdateInfo), (UpdateInfo -> UpdateInfo -> _CMP_TAG)] [_DFUN_ Eq (UpdateInfo), _CONSTM_ Ord (<) (UpdateInfo), _CONSTM_ Ord (<=) (UpdateInfo), _CONSTM_ Ord (>=) (UpdateInfo), _CONSTM_ Ord (>) (UpdateInfo), _CONSTM_ Ord max (UpdateInfo), _CONSTM_ Ord min (UpdateInfo), _CONSTM_ Ord _tagCmp (UpdateInfo)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord Name
- {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Name}}, (Name -> Name -> Bool), (Name -> Name -> Bool), (Name -> Name -> Bool), (Name -> Name -> Bool), (Name -> Name -> Name), (Name -> Name -> Name), (Name -> Name -> _CMP_TAG)] [_DFUN_ Eq (Name), _CONSTM_ Ord (<) (Name), _CONSTM_ Ord (<=) (Name), _CONSTM_ Ord (>=) (Name), _CONSTM_ Ord (>) (Name), _CONSTM_ Ord max (Name), _CONSTM_ Ord min (Name), _CONSTM_ Ord _tagCmp (Name)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq PrimKind}}, (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> _CMP_TAG)] [_DFUN_ Eq (PrimKind), _CONSTM_ Ord (<) (PrimKind), _CONSTM_ Ord (<=) (PrimKind), _CONSTM_ Ord (>=) (PrimKind), _CONSTM_ Ord (>) (PrimKind), _CONSTM_ Ord max (PrimKind), _CONSTM_ Ord min (PrimKind), _CONSTM_ Ord _tagCmp (PrimKind)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Ord TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyCon}}, (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> _CMP_TAG)] [_DFUN_ Eq (TyCon), _CONSTM_ Ord (<) (TyCon), _CONSTM_ Ord (<=) (TyCon), _CONSTM_ Ord (>=) (TyCon), _CONSTM_ Ord (>) (TyCon), _CONSTM_ Ord max (TyCon), _CONSTM_ Ord min (TyCon), _CONSTM_ Ord _tagCmp (TyCon)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVar}}, (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> _CMP_TAG)] [_DFUN_ Eq (TyVar), _CONSTM_ Ord (<) (TyVar), _CONSTM_ Ord (<=) (TyVar), _CONSTM_ Ord (>=) (TyVar), _CONSTM_ Ord (>) (TyVar), _CONSTM_ Ord max (TyVar), _CONSTM_ Ord min (TyVar), _CONSTM_ Ord _tagCmp (TyVar)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Class -> ExportFlag), (Class -> Bool), (Class -> (_PackedString, _PackedString)), (Class -> _PackedString), (Class -> [_PackedString]), (Class -> SrcLoc), (Class -> Unique), (Class -> Bool), (Class -> UniType), (Class -> Bool)] [_CONSTM_ NamedThing getExportFlag (Class), _CONSTM_ NamedThing isLocallyDefined (Class), _CONSTM_ NamedThing getOrigName (Class), _CONSTM_ NamedThing getOccurrenceName (Class), _CONSTM_ NamedThing getInformingModules (Class), _CONSTM_ NamedThing getSrcLoc (Class), _CONSTM_ NamedThing getTheUnique (Class), _CONSTM_ NamedThing hasType (Class), _CONSTM_ NamedThing getType (Class), _CONSTM_ NamedThing fromPreludeCore (Class)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(LLAAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [ub, uc]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(ALSAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAAAS)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ug; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Unique) } [ _NOREP_S_ "NamedThing.Class.getTheUnique", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Bool) } [ _NOREP_S_ "NamedThing.Class.hasType", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> UniType) } [ _NOREP_S_ "NamedThing.Class.getType", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing a => NamedThing (InPat a)
- {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 0 _N_ _N_ _N_ _N_ #-}
instance NamedThing TypecheckedPat
- {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TypecheckedPat -> ExportFlag), (TypecheckedPat -> Bool), (TypecheckedPat -> (_PackedString, _PackedString)), (TypecheckedPat -> _PackedString), (TypecheckedPat -> [_PackedString]), (TypecheckedPat -> SrcLoc), (TypecheckedPat -> Unique), (TypecheckedPat -> Bool), (TypecheckedPat -> UniType), (TypecheckedPat -> Bool)] [_CONSTM_ NamedThing getExportFlag (TypecheckedPat), _CONSTM_ NamedThing isLocallyDefined (TypecheckedPat), _CONSTM_ NamedThing getOrigName (TypecheckedPat), _CONSTM_ NamedThing getOccurrenceName (TypecheckedPat), _CONSTM_ NamedThing getInformingModules (TypecheckedPat), _CONSTM_ NamedThing getSrcLoc (TypecheckedPat), _CONSTM_ NamedThing getTheUnique (TypecheckedPat), _CONSTM_ NamedThing hasType (TypecheckedPat), _ORIG_ HsPat typeOfPat, _CONSTM_ NamedThing fromPreludeCore (TypecheckedPat)] _N_
- getExportFlag = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u0 ] _N_,
- isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u0 ] _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u0 ] _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u0 ] _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_,
- getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u0 ] _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_,
- hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TypecheckedPat) -> _!_ True [] [] _N_,
- getType = _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ HsPat typeOfPat _N_,
- fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u0 ] _N_ #-}
instance NamedThing Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_,
- getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing Name
- {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Name -> ExportFlag), (Name -> Bool), (Name -> (_PackedString, _PackedString)), (Name -> _PackedString), (Name -> [_PackedString]), (Name -> SrcLoc), (Name -> Unique), (Name -> Bool), (Name -> UniType), (Name -> Bool)] [_CONSTM_ NamedThing getExportFlag (Name), _CONSTM_ NamedThing isLocallyDefined (Name), _CONSTM_ NamedThing getOrigName (Name), _CONSTM_ NamedThing getOccurrenceName (Name), _CONSTM_ NamedThing getInformingModules (Name), _CONSTM_ NamedThing getSrcLoc (Name), _CONSTM_ NamedThing getTheUnique (Name), _CONSTM_ NamedThing hasType (Name), _CONSTM_ NamedThing getType (Name), _CONSTM_ NamedThing fromPreludeCore (Name)] _N_
- getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Name) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Name" ] _N_,
- getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Name) -> _!_ False [] [] _N_,
- getType = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Name) -> _APP_ _TYAPP_ _ORIG_ Util panic { UniType } [ _NOREP_S_ "NamedThing.Name.getType" ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instance NamedThing FullName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(FullName -> ExportFlag), (FullName -> Bool), (FullName -> (_PackedString, _PackedString)), (FullName -> _PackedString), (FullName -> [_PackedString]), (FullName -> SrcLoc), (FullName -> Unique), (FullName -> Bool), (FullName -> UniType), (FullName -> Bool)] [_CONSTM_ NamedThing getExportFlag (FullName), _CONSTM_ NamedThing isLocallyDefined (FullName), _CONSTM_ NamedThing getOrigName (FullName), _CONSTM_ NamedThing getOccurrenceName (FullName), _CONSTM_ NamedThing getInformingModules (FullName), _CONSTM_ NamedThing getSrcLoc (FullName), _CONSTM_ NamedThing getTheUnique (FullName), _CONSTM_ NamedThing hasType (FullName), _CONSTM_ NamedThing getType (FullName), _CONSTM_ NamedThing fromPreludeCore (FullName)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAEAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u4; _NO_DEFLT_ } _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ThisModule -> _!_ True [] []; _ORIG_ NameTypes InventedInThisModule -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LLAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [u1, u2]; _NO_DEFLT_ } _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(ALSAAA)" {_A_ 2 _U_ 11 _N_ _N_ _F_ _IF_ARGS_ 0 2 XC 10 \ (u0 :: _PackedString) (u1 :: Provenance) -> case u1 of { _ALG_ _ORIG_ NameTypes OtherPrelude (u2 :: _PackedString) -> u2; _ORIG_ NameTypes OtherModule (u3 :: _PackedString) (u4 :: [_PackedString]) -> u3; (u5 :: Provenance) -> u0 } _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ExportedByPreludeCore -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_ #-}
instance NamedThing ShortName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(ShortName -> ExportFlag), (ShortName -> Bool), (ShortName -> (_PackedString, _PackedString)), (ShortName -> _PackedString), (ShortName -> [_PackedString]), (ShortName -> SrcLoc), (ShortName -> Unique), (ShortName -> Bool), (ShortName -> UniType), (ShortName -> Bool)] [_CONSTM_ NamedThing getExportFlag (ShortName), _CONSTM_ NamedThing isLocallyDefined (ShortName), _CONSTM_ NamedThing getOrigName (ShortName), _CONSTM_ NamedThing getOccurrenceName (ShortName), _CONSTM_ NamedThing getInformingModules (ShortName), _CONSTM_ NamedThing getSrcLoc (ShortName), _CONSTM_ NamedThing getTheUnique (ShortName), _CONSTM_ NamedThing hasType (ShortName), _CONSTM_ NamedThing getType (ShortName), _CONSTM_ NamedThing fromPreludeCore (ShortName)] _N_
- getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ _ORIG_ Outputable NotExported [] [] _N_,
- isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ True [] [] _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(SA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: _PackedString) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u1; _NO_DEFLT_ } _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u2; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AA)" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> _!_ False [] []; _NO_DEFLT_ } _N_ #-}
instance NamedThing ProtoName
- {-# GHC_PRAGMA _M_ ProtoName {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(ProtoName -> ExportFlag), (ProtoName -> Bool), (ProtoName -> (_PackedString, _PackedString)), (ProtoName -> _PackedString), (ProtoName -> [_PackedString]), (ProtoName -> SrcLoc), (ProtoName -> Unique), (ProtoName -> Bool), (ProtoName -> UniType), (ProtoName -> Bool)] [_CONSTM_ NamedThing getExportFlag (ProtoName), _CONSTM_ NamedThing isLocallyDefined (ProtoName), _CONSTM_ NamedThing getOrigName (ProtoName), _CONSTM_ NamedThing getOccurrenceName (ProtoName), _CONSTM_ NamedThing getInformingModules (ProtoName), _CONSTM_ NamedThing getSrcLoc (ProtoName), _CONSTM_ NamedThing getTheUnique (ProtoName), _CONSTM_ NamedThing hasType (ProtoName), _CONSTM_ NamedThing getType (ProtoName), _CONSTM_ NamedThing fromPreludeCore (ProtoName)] _N_
- getExportFlag = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u0 ] _N_,
- isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u0 ] _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: ProtoName) -> case u0 of { _ALG_ _ORIG_ ProtoName Unk (u1 :: _PackedString) -> u1; _ORIG_ ProtoName Imp (u2 :: _PackedString) (u3 :: _PackedString) (u4 :: [_PackedString]) (u5 :: _PackedString) -> u5; _ORIG_ ProtoName Prel (u6 :: Name) -> _APP_ _CONSTM_ NamedThing getOccurrenceName (Name) [ u6 ]; _NO_DEFLT_ } _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_,
- getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u0 ] _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_,
- hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ProtoName) -> _!_ False [] [] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u0 ] _N_ #-}
instance NamedThing TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyCon -> ExportFlag), (TyCon -> Bool), (TyCon -> (_PackedString, _PackedString)), (TyCon -> _PackedString), (TyCon -> [_PackedString]), (TyCon -> SrcLoc), (TyCon -> Unique), (TyCon -> Bool), (TyCon -> UniType), (TyCon -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyCon), _CONSTM_ NamedThing isLocallyDefined (TyCon), _CONSTM_ NamedThing getOrigName (TyCon), _CONSTM_ NamedThing getOccurrenceName (TyCon), _CONSTM_ NamedThing getInformingModules (TyCon), _CONSTM_ NamedThing getSrcLoc (TyCon), _CONSTM_ NamedThing getTheUnique (TyCon), _CONSTM_ NamedThing hasType (TyCon), _CONSTM_ NamedThing getType (TyCon), _CONSTM_ NamedThing fromPreludeCore (TyCon)] _N_
- getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getTheUnique = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Unique } [ _NOREP_S_ "NamedThing.TyCon.getTheUnique" ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> Bool) } [ _NOREP_S_ "NamedThing.TyCon.hasType", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> UniType) } [ _NOREP_S_ "NamedThing.TyCon.getType", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
instance NamedThing TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVar -> ExportFlag), (TyVar -> Bool), (TyVar -> (_PackedString, _PackedString)), (TyVar -> _PackedString), (TyVar -> [_PackedString]), (TyVar -> SrcLoc), (TyVar -> Unique), (TyVar -> Bool), (TyVar -> UniType), (TyVar -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVar), _CONSTM_ NamedThing isLocallyDefined (TyVar), _CONSTM_ NamedThing getOrigName (TyVar), _CONSTM_ NamedThing getOccurrenceName (TyVar), _CONSTM_ NamedThing getInformingModules (TyVar), _CONSTM_ NamedThing getSrcLoc (TyVar), _CONSTM_ NamedThing getTheUnique (TyVar), _CONSTM_ NamedThing hasType (TyVar), _CONSTM_ NamedThing getType (TyVar), _CONSTM_ NamedThing fromPreludeCore (TyVar)] _N_
- getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ _ORIG_ Outputable NotExported [] [] _N_,
- isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ True [] [] _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVar" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar UserTyVar (u1 :: Unique) (u2 :: ShortName) -> case u2 of { _ALG_ _ORIG_ NameTypes ShortName (u3 :: _PackedString) (u4 :: SrcLoc) -> u4; _NO_DEFLT_ }; (u5 :: TyVar) -> _ORIG_ SrcLoc mkUnknownSrcLoc } _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar PolySysTyVar (u1 :: Unique) -> u1; _ORIG_ TyVar PrimSysTyVar (u2 :: Unique) -> u2; _ORIG_ TyVar OpenSysTyVar (u3 :: Unique) -> u3; _ORIG_ TyVar UserTyVar (u4 :: Unique) (u5 :: ShortName) -> u4; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ False [] [] _N_ #-}
instance (Outputable a, Outputable b) => Outputable (a, b)
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Module a b)
- {-# GHC_PRAGMA _M_ AbsSyn {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance Outputable BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BasicLit) _N_
- ppr = _A_ 0 _U_ 2122 _N_ _N_ _N_ _N_ #-}
instance Outputable Bool
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_
- ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Class) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(AU(LLLLAA)AAAAAAAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable ClassOp
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable a => Outputable (FiniteMap a b)
- {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Bind a b)
- {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Binds a b)
- {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (MonoBinds a b)
- {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (Sig a)
- {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 0 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (UnfoldingCoreAtom a)
- {-# GHC_PRAGMA _M_ HsCore {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (UnfoldingCoreExpr a)
- {-# GHC_PRAGMA _M_ HsCore {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (UnfoldingPrimOp a)
- {-# GHC_PRAGMA _M_ HsCore {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (ClassDecl a b)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a) => Outputable (ConDecl a)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a) => Outputable (DataTypeSig a)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 02 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a) => Outputable (DefaultDecl a)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 02 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a) => Outputable (FixityDecl a)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (InstDecl a b)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a) => Outputable (SpecialisedInstanceSig a)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 02 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a) => Outputable (TyDecl a)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (ArithSeqInfo a b)
- {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Expr a b)
- {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Qual a b)
- {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance Outputable IE
- {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (IE) _N_
- ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable IfaceImportDecl
- {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (IfaceImportDecl) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "LU(LLLA)" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (ImportedInterface a b)
- {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Interface a b)
- {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance Outputable Renaming
- {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Renaming) _N_
- ppr = _A_ 2 _U_ 0122 _N_ _S_ "AU(LL)" {_A_ 2 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable Literal
- {-# GHC_PRAGMA _M_ HsLit {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Literal) _N_
- ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHS a b)
- {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHS u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr: GRHSs", u8, u9 ] _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHSsAndBinds a b)
- {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHSsAndBinds u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr:GRHSsAndBinds", u8, u9 ] _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Match a b)
- {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: Match u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr: Match", u8, u9 ] _N_ #-}
instance Outputable a => Outputable (InPat a)
- {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable TypecheckedPat
- {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 0 _N_ _N_ _N_ _N_ _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (ClassOpPragmas a)
- {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (ClassPragmas a)
- {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (GenPragmas a)
- {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (InstancePragmas a)
- {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (MonoType a)
- {-# GHC_PRAGMA _M_ HsTypes {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (PolyType a)
- {-# GHC_PRAGMA _M_ HsTypes {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance Outputable Demand
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Demand) _N_
- ppr = _A_ 2 _U_ 0220 _N_ _S_ "AL" {_A_ 1 _U_ 220 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable Inst
- {-# GHC_PRAGMA _M_ Inst {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Inst) _N_
- ppr = _A_ 2 _U_ 1222 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable Name
- {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Name) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
instance Outputable FullName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (FullName) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LLLLAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable ShortName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (ShortName) _N_
- ppr = _A_ 4 _U_ 0120 _N_ _S_ "AU(LA)LA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (PrimKind) _N_
- ppr = _A_ 2 _U_ 0120 _N_ _S_ "AL" {_A_ 1 _U_ 120 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable PrimOp
- {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ #-}
instance Outputable ProtoName
- {-# GHC_PRAGMA _M_ ProtoName {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (ProtoName) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
instance Outputable SrcLoc
- {-# GHC_PRAGMA _M_ SrcLoc {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (SrcLoc) _N_
- ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyCon) _N_
- ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVar) _N_
- ppr = _A_ 2 _U_ 1122 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable a => Outputable [a]
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Text Demand
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Demand, [Char])]), (Int -> Demand -> [Char] -> [Char]), ([Char] -> [([Demand], [Char])]), ([Demand] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Demand), _CONSTM_ Text showsPrec (Demand), _CONSTM_ Text readList (Demand), _CONSTM_ Text showList (Demand)] _N_
- readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(Demand, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 3 _U_ 222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Demand) (u2 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> Demand -> [Char] -> [Char]) } [ _NOREP_S_ "%DPreludeCore.Text.showsPrec\"", u0, u1, u2 ] _N_,
- readList = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- showList = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
instance Text UpdateInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(UpdateInfo, [Char])]), (Int -> UpdateInfo -> [Char] -> [Char]), ([Char] -> [([UpdateInfo], [Char])]), ([UpdateInfo] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (UpdateInfo), _CONSTM_ Text showsPrec (UpdateInfo), _CONSTM_ Text readList (UpdateInfo), _CONSTM_ Text showList (UpdateInfo)] _N_
- readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AS" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 3 _U_ 222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: UpdateInfo) (u2 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> UpdateInfo -> [Char] -> [Char]) } [ _NOREP_S_ "%DPreludeCore.Text.showsPrec\"", u0, u1, u2 ] _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_
- readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_,
- showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
import UniType(UniType)
type PreludeNameFun = _PackedString -> Labda Name
cmpInstanceTypes :: MonoType ProtoName -> MonoType ProtoName -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
collectBinders :: Bind a (InPat a) -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectMonoBinders :: MonoBinds a (InPat a) -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectMonoBindersAndLocs :: MonoBinds a (InPat a) -> [(a, SrcLoc)]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectPatBinders :: InPat a -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectQualBinders :: [Qual Name (InPat Name)] -> [Name]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectTopLevelBinders :: Binds a (InPat a) -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectTypedBinders :: Bind Id TypecheckedPat -> [Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
collectTypedPatBinders :: TypecheckedPat -> [Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
extractMonoTyNames :: (a -> a -> Bool) -> MonoType a -> [a]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
getMentionedVars :: (_PackedString -> Labda Name) -> [IE] -> [FixityDecl ProtoName] -> [ClassDecl ProtoName (InPat ProtoName)] -> [InstDecl ProtoName (InPat ProtoName)] -> Binds ProtoName (InPat ProtoName) -> (Bool, [_PackedString])
- {-# GHC_PRAGMA _A_ 6 _U_ 210111 _N_ _S_ "LSALLL" {_A_ 5 _U_ 21111 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getNonPrelOuterTyCon :: MonoType ProtoName -> Labda ProtoName
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: MonoType ProtoName) -> case u0 of { _ALG_ _ORIG_ HsTypes MonoTyCon (u1 :: ProtoName) (u2 :: [MonoType ProtoName]) -> _!_ _ORIG_ Maybes Ni [ProtoName] [u1]; (u3 :: MonoType ProtoName) -> _!_ _ORIG_ Maybes Hamna [ProtoName] [] } _N_ #-}
mkDictApp :: Expr Id TypecheckedPat -> [Id] -> Expr Id TypecheckedPat
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _IF_ARGS_ 0 2 XC 6 \ (u0 :: Expr Id TypecheckedPat) (u1 :: [Id]) -> case u1 of { _ALG_ (:) (u2 :: Id) (u3 :: [Id]) -> _!_ _ORIG_ HsExpr DictApp [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u0; _NO_DEFLT_ } _N_ #-}
mkDictLam :: [Id] -> Expr Id TypecheckedPat -> Expr Id TypecheckedPat
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: [Id]) (u1 :: Expr Id TypecheckedPat) -> case u0 of { _ALG_ (:) (u2 :: Id) (u3 :: [Id]) -> _!_ _ORIG_ HsExpr DictLam [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-}
mkTyApp :: Expr Id TypecheckedPat -> [UniType] -> Expr Id TypecheckedPat
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _IF_ARGS_ 0 2 XC 6 \ (u0 :: Expr Id TypecheckedPat) (u1 :: [UniType]) -> case u1 of { _ALG_ (:) (u2 :: UniType) (u3 :: [UniType]) -> _!_ _ORIG_ HsExpr TyApp [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u0; _NO_DEFLT_ } _N_ #-}
mkTyLam :: [TyVar] -> Expr Id TypecheckedPat -> Expr Id TypecheckedPat
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: [TyVar]) (u1 :: Expr Id TypecheckedPat) -> case u0 of { _ALG_ (:) (u2 :: TyVar) (u3 :: [TyVar]) -> _!_ _ORIG_ HsExpr TyLam [Id, TypecheckedPat] [u0, u1]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-}
type TypecheckedBinds = Binds Id TypecheckedPat
type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
bindIsRecursive :: Bind Id TypecheckedPat -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: Bind Id TypecheckedPat) -> case u0 of { _ALG_ _ORIG_ HsBinds EmptyBind -> _!_ False [] []; _ORIG_ HsBinds NonRecBind (u1 :: MonoBinds Id TypecheckedPat) -> _!_ False [] []; _ORIG_ HsBinds RecBind (u2 :: MonoBinds Id TypecheckedPat) -> _!_ True [] []; _NO_DEFLT_ } _N_ #-}
nullBind :: Bind a b -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
nullBinds :: Binds a b -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
nullMonoBinds :: MonoBinds a b -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Bind a b)
- {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Binds a b)
- {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (MonoBinds a b)
- {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (Sig a)
- {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 0 _U_ 2 _N_ _N_ _N_ _N_ #-}
data UnfoldingPrimOp a = UfCCallOp _PackedString Bool Bool [PolyType a] (PolyType a) | UfOtherOp PrimOp
type UnfoldingType a = PolyType a
eqUfExpr :: UnfoldingCoreExpr ProtoName -> UnfoldingCoreExpr ProtoName -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable a => Outputable (UnfoldingCoreAtom a)
- {-# GHC_PRAGMA _M_ HsCore {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (UnfoldingCoreExpr a)
- {-# GHC_PRAGMA _M_ HsCore {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (UnfoldingPrimOp a)
- {-# GHC_PRAGMA _M_ HsCore {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
data SpecialisedInstanceSig a = InstSpecSig a (MonoType a) SrcLoc
data TyDecl a = TyData [(a, a)] a [a] [ConDecl a] [a] (DataPragmas a) SrcLoc | TySynonym a [a] (MonoType a) TypePragmas SrcLoc
eqConDecls :: [ConDecl ProtoName] -> [ConDecl ProtoName] -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (ClassDecl a b)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a) => Outputable (ConDecl a)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a) => Outputable (DataTypeSig a)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 02 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a) => Outputable (DefaultDecl a)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 02 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a) => Outputable (FixityDecl a)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (InstDecl a b)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a) => Outputable (SpecialisedInstanceSig a)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 02 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a) => Outputable (TyDecl a)
- {-# GHC_PRAGMA _M_ HsDecls {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
type TypecheckedExpr = Expr Id TypecheckedPat
type TypecheckedQual = Qual Id TypecheckedPat
pprExpr :: (NamedThing a, Outputable a, NamedThing b, Outputable b) => PprStyle -> Expr a b -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 22222222 _N_ _N_ _N_ _N_ #-}
pprParendExpr :: (NamedThing a, Outputable a, NamedThing b, Outputable b) => PprStyle -> Expr a b -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 22222222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (ArithSeqInfo a b)
- {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Expr a b)
- {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Qual a b)
- {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
type RenamedInterface = Interface Name (InPat Name)
data Renaming = MkRenaming _PackedString _PackedString
getIEStrings :: [IE] -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getRawIEStrings :: [IE] -> ([(_PackedString, ExportFlag)], [_PackedString])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
pprRenamings :: PprStyle -> [Renaming] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-}
instance Outputable IE
- {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (IE) _N_
- ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable IfaceImportDecl
- {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (IfaceImportDecl) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "LU(LLLA)" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (ImportedInterface a b)
- {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Interface a b)
- {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance Outputable Renaming
- {-# GHC_PRAGMA _M_ HsImpExp {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Renaming) _N_
- ppr = _A_ 2 _U_ 0122 _N_ _S_ "AU(LL)" {_A_ 2 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import UniType(UniType)
data Literal = CharLit Char | CharPrimLit Char | StringLit _PackedString | StringPrimLit _PackedString | IntLit Integer | FracLit (Ratio Integer) | LitLitLitIn _PackedString | LitLitLit _PackedString UniType | IntPrimLit Integer | FloatPrimLit (Ratio Integer) | DoublePrimLit (Ratio Integer)
negLiteral :: Literal -> Literal
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instance Outputable Literal
- {-# GHC_PRAGMA _M_ HsLit {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Literal) _N_
- ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
type TypecheckedGRHSsAndBinds = GRHSsAndBinds Id TypecheckedPat
type TypecheckedMatch = Match Id TypecheckedPat
pprGRHS :: (NamedThing a, Outputable a, NamedThing b, Outputable b) => PprStyle -> Bool -> GRHS a b -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222221122 _N_ _N_ _N_ _N_ #-}
pprGRHSsAndBinds :: (NamedThing a, Outputable a, NamedThing b, Outputable b) => PprStyle -> Bool -> GRHSsAndBinds a b -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222122 _N_ _N_ _N_ _N_ #-}
pprMatch :: (NamedThing a, Outputable a, NamedThing b, Outputable b) => PprStyle -> Bool -> Match a b -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 7 _U_ 222222122 _N_ _S_ "LLLLLLS" _N_ _N_ #-}
pprMatches :: (NamedThing a, Outputable a, NamedThing b, Outputable b) => PprStyle -> (Bool, Int -> Bool -> PrettyRep) -> [Match a b] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222221222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHS a b)
- {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHS u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr: GRHSs", u8, u9 ] _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHSsAndBinds a b)
- {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHSsAndBinds u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr:GRHSsAndBinds", u8, u9 ] _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Match a b)
- {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: Match u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr: Match", u8, u9 ] _N_ #-}
type RenamedPat = InPat Name
data TypecheckedPat = WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat)
irrefutablePat :: TypecheckedPat -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isConPat :: TypecheckedPat -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isLitPat :: TypecheckedPat -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
only_con :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
patsAreAllCons :: [TypecheckedPat] -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
patsAreAllLits :: [TypecheckedPat] -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
pprConPatTy :: PprStyle -> UniType -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
pprInPat :: Outputable a => PprStyle -> InPat a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 22122 _N_ _N_ _N_ _N_ #-}
pprTypecheckedPat :: PprStyle -> TypecheckedPat -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
typeOfPat :: TypecheckedPat -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
unfailablePat :: TypecheckedPat -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
unfailablePats :: [TypecheckedPat] -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instance NamedThing a => NamedThing (InPat a)
- {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 0 _N_ _N_ _N_ _N_ #-}
instance NamedThing TypecheckedPat
- {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TypecheckedPat -> ExportFlag), (TypecheckedPat -> Bool), (TypecheckedPat -> (_PackedString, _PackedString)), (TypecheckedPat -> _PackedString), (TypecheckedPat -> [_PackedString]), (TypecheckedPat -> SrcLoc), (TypecheckedPat -> Unique), (TypecheckedPat -> Bool), (TypecheckedPat -> UniType), (TypecheckedPat -> Bool)] [_CONSTM_ NamedThing getExportFlag (TypecheckedPat), _CONSTM_ NamedThing isLocallyDefined (TypecheckedPat), _CONSTM_ NamedThing getOrigName (TypecheckedPat), _CONSTM_ NamedThing getOccurrenceName (TypecheckedPat), _CONSTM_ NamedThing getInformingModules (TypecheckedPat), _CONSTM_ NamedThing getSrcLoc (TypecheckedPat), _CONSTM_ NamedThing getTheUnique (TypecheckedPat), _CONSTM_ NamedThing hasType (TypecheckedPat), _ORIG_ HsPat typeOfPat, _CONSTM_ NamedThing fromPreludeCore (TypecheckedPat)] _N_
- getExportFlag = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u0 ] _N_,
- isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u0 ] _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u0 ] _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u0 ] _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_,
- getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u0 ] _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_,
- hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TypecheckedPat) -> _!_ True [] [] _N_,
- getType = _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ HsPat typeOfPat _N_,
- fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TypecheckedPat) -> _APP_ _TYAPP_ patError# { (TypecheckedPat -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u0 ] _N_ #-}
instance Outputable a => Outputable (InPat a)
- {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable TypecheckedPat
- {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 0 _N_ _N_ _N_ _N_ _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
type RenamedInstancePragmas = InstancePragmas Name
data TypePragmas = NoTypePragmas | AbstractTySynonym
instance Outputable a => Outputable (ClassOpPragmas a)
- {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (ClassPragmas a)
- {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (GenPragmas a)
- {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (InstancePragmas a)
- {-# GHC_PRAGMA _M_ HsPragmas {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
type RenamedMonoType = MonoType Name
type RenamedPolyType = PolyType Name
cmpList :: (a -> a -> Int#) -> [a] -> [a] -> Int#
- {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LSS" _N_ _N_ #-}
cmpMonoType :: (a -> a -> Int#) -> MonoType a -> MonoType a -> Int#
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
cmpPolyType :: (a -> a -> Int#) -> PolyType a -> PolyType a -> Int#
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
eqMonoType :: MonoType ProtoName -> MonoType ProtoName -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
pprContext :: Outputable a => PprStyle -> [(a, a)] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22122 _N_ _S_ "LLS" _N_ _N_ #-}
pprParendMonoType :: Outputable a => PprStyle -> MonoType a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 22122 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (MonoType a)
- {-# GHC_PRAGMA _M_ HsTypes {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (PolyType a)
- {-# GHC_PRAGMA _M_ HsTypes {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Name where
-import Class(Class)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
-import Maybes(Labda)
-import NameTypes(FullName, Provenance, ShortName)
-import Outputable(ExportFlag, NamedThing, Outputable)
+import Id(Id)
+import NameTypes(FullName, ShortName)
+import Outputable(NamedThing, Outputable)
import PreludePS(_PackedString)
-import PrimKind(PrimKind)
-import SrcLoc(SrcLoc)
import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
import Unique(Unique)
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-}
+data Id
+data FullName
data Name = Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString
-data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data ShortName
+data TyCon
+data Unique
cmpName :: Name -> Name -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
eqName :: Name -> Name -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Name) (u1 :: Name) -> case _APP_ _ORIG_ Name cmpName [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-}
getTagFromClassOpName :: Name -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
invisibleName :: Name -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isClassName :: Name -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 14 \ (u0 :: Name) -> case u0 of { _ALG_ _ORIG_ Name PreludeClass (u1 :: Unique) (u2 :: FullName) -> _!_ True [] []; _ORIG_ Name OtherClass (u3 :: Unique) (u4 :: FullName) (u5 :: [Name]) -> _!_ True [] []; (u6 :: Name) -> _!_ False [] [] } _N_ #-}
isClassOpName :: Name -> Name -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-}
isTyConName :: Name -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 15 \ (u0 :: Name) -> case u0 of { _ALG_ _ORIG_ Name WiredInTyCon (u1 :: TyCon) -> _!_ True [] []; _ORIG_ Name PreludeTyCon (u2 :: Unique) (u3 :: FullName) (u4 :: Int) (u5 :: Bool) -> _!_ True [] []; _ORIG_ Name OtherTyCon (u6 :: Unique) (u7 :: FullName) (u8 :: Int) (u9 :: Bool) (ua :: [Name]) -> _!_ True [] []; (ub :: Name) -> _!_ False [] [] } _N_ #-}
isUnboundName :: Name -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 13 \ (u0 :: Name) -> case u0 of { _ALG_ _ORIG_ Name Unbound (u1 :: _PackedString) -> _!_ True [] []; (u2 :: Name) -> _!_ False [] [] } _N_ #-}
instance Eq Name
- {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Name -> Name -> Bool), (Name -> Name -> Bool)] [_CONSTM_ Eq (==) (Name), _CONSTM_ Eq (/=) (Name)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Name) (u1 :: Name) -> case _APP_ _ORIG_ Name cmpName [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Name) (u1 :: Name) -> case _APP_ _ORIG_ Name cmpName [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Ord Name
- {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Name}}, (Name -> Name -> Bool), (Name -> Name -> Bool), (Name -> Name -> Bool), (Name -> Name -> Bool), (Name -> Name -> Name), (Name -> Name -> Name), (Name -> Name -> _CMP_TAG)] [_DFUN_ Eq (Name), _CONSTM_ Ord (<) (Name), _CONSTM_ Ord (<=) (Name), _CONSTM_ Ord (>=) (Name), _CONSTM_ Ord (>) (Name), _CONSTM_ Ord max (Name), _CONSTM_ Ord min (Name), _CONSTM_ Ord _tagCmp (Name)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance NamedThing Name
- {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Name -> ExportFlag), (Name -> Bool), (Name -> (_PackedString, _PackedString)), (Name -> _PackedString), (Name -> [_PackedString]), (Name -> SrcLoc), (Name -> Unique), (Name -> Bool), (Name -> UniType), (Name -> Bool)] [_CONSTM_ NamedThing getExportFlag (Name), _CONSTM_ NamedThing isLocallyDefined (Name), _CONSTM_ NamedThing getOrigName (Name), _CONSTM_ NamedThing getOccurrenceName (Name), _CONSTM_ NamedThing getInformingModules (Name), _CONSTM_ NamedThing getSrcLoc (Name), _CONSTM_ NamedThing getTheUnique (Name), _CONSTM_ NamedThing hasType (Name), _CONSTM_ NamedThing getType (Name), _CONSTM_ NamedThing fromPreludeCore (Name)] _N_
- getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Name) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Name" ] _N_,
- getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Name) -> _!_ False [] [] _N_,
- getType = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Name) -> _APP_ _TYAPP_ _ORIG_ Util panic { UniType } [ _NOREP_S_ "NamedThing.Name.getType" ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instance Outputable Name
- {-# GHC_PRAGMA _M_ Name {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Name) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
ppr sty (OtherTopId u n) = ppr sty n
ppr sty (ClassOpName u c s i)
- = case sty of
- PprForUser -> ppPStr s
- PprInterface _ -> ppPStr s
- other -> ppBesides [ppPStr s, ppChar '{',
- ppSep [pprUnique u,
- ppStr "op", ppInt i,
- ppStr "cls", ppr sty c],
- ppChar '}']
-
- ppr sty (Unbound s) = ppStr ("*UNBOUND*"++ _UNPK_ s)
+ = let
+ ps = ppPStr s
+ in
+ case sty of
+ PprForUser -> ps
+ PprInterface _ -> ps
+ PprDebug -> ps
+ other -> ppBesides [ps, ppChar '{',
+ ppSep [pprUnique u,
+ ppStr "op", ppInt i,
+ ppStr "cls", ppr sty c],
+ ppChar '}']
+
+ ppr sty (Unbound s) = ppStr ("*UNBOUND*"++ _UNPK_ s)
pp_debug uniq thing
= ppBesides [ppr PprDebug thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface BasicLit where
-import Class(Class)
import Outputable(Outputable)
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
import Pretty(PprStyle)
import PrimKind(PrimKind)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
import UniType(UniType)
data BasicLit = MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer)
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data PrimKind
+data UniType
isLitLitLit :: BasicLit -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 12 \ (u0 :: BasicLit) -> case u0 of { _ALG_ _ORIG_ BasicLit MachLitLit (u1 :: _PackedString) (u2 :: PrimKind) -> _!_ True [] []; (u3 :: BasicLit) -> _!_ False [] [] } _N_ #-}
isNoRepLit :: BasicLit -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 14 \ (u0 :: BasicLit) -> case u0 of { _ALG_ _ORIG_ BasicLit NoRepStr (u1 :: _PackedString) -> _!_ True [] []; _ORIG_ BasicLit NoRepInteger (u2 :: Integer) -> _!_ True [] []; _ORIG_ BasicLit NoRepRational (u3 :: Ratio Integer) -> _!_ True [] []; (u4 :: BasicLit) -> _!_ False [] [] } _N_ #-}
kindOfBasicLit :: BasicLit -> PrimKind
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkMachInt :: Integer -> BasicLit
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkMachWord :: Integer -> BasicLit
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
showBasicLit :: PprStyle -> BasicLit -> [Char]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
typeOfBasicLit :: BasicLit -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instance Eq BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool)] [_CONSTM_ Eq (==) (BasicLit), _CONSTM_ Eq (/=) (BasicLit)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq BasicLit}}, (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> _CMP_TAG)] [_DFUN_ Eq (BasicLit), _CONSTM_ Ord (<) (BasicLit), _CONSTM_ Ord (<=) (BasicLit), _CONSTM_ Ord (>=) (BasicLit), _CONSTM_ Ord (>) (BasicLit), _CONSTM_ Ord max (BasicLit), _CONSTM_ Ord min (BasicLit), _CONSTM_ Ord _tagCmp (BasicLit)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BasicLit) _N_
- ppr = _A_ 0 _U_ 2122 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface CLabelInfo where
import CharSeq(CSeq)
-import Class(Class)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
-import Maybes(Labda)
-import NameTypes(FullName)
+import Id(Id)
import PreludePS(_PackedString)
import Pretty(PprStyle, PrettyRep)
-import PrimKind(PrimKind)
import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
import Unique(Unique)
data CLabel
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Id
+data TyCon
+data Unique
cSEP :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charToC :: Char -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
charToEasyHaskell :: Char -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
externallyVisibleCLabel :: CLabel -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
identToC :: _PackedString -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-}
isAsmTemp :: CLabel -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isReadOnly :: CLabel -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkAltLabel :: Unique -> Int -> CLabel
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
mkAsmTempLabel :: Unique -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkBlackHoleInfoTableLabel :: CLabel
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkClosureLabel :: Id -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkConEntryLabel :: Id -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkConUpdCodePtrVecLabel :: TyCon -> Int -> CLabel
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
mkDefaultLabel :: Unique -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkErrorStdEntryLabel :: CLabel
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkFastEntryLabel :: Id -> Int -> CLabel
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
mkInfoTableLabel :: Id -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkInfoTableVecTblLabel :: TyCon -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkPhantomInfoTableLabel :: Id -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkRednCountsLabel :: Id -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkReturnPtLabel :: Unique -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkStaticConEntryLabel :: Id -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkStaticInfoTableLabel :: Id -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkStdEntryLabel :: Id -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkStdUpdCodePtrVecLabel :: TyCon -> Int -> CLabel
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
mkStdUpdVecTblLabel :: TyCon -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkVapEntryLabel :: Id -> Bool -> CLabel
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
mkVapInfoTableLabel :: Id -> Bool -> CLabel
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
mkVecTblLabel :: Unique -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
modnameToC :: _PackedString -> _PackedString
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
needsCDecl :: CLabel -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
pprCLabel :: PprStyle -> CLabel -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
stringToC :: [Char] -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
instance Eq CLabel
- {-# GHC_PRAGMA _M_ CLabelInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool)] [_CONSTM_ Eq (==) (CLabel), _CONSTM_ Eq (/=) (CLabel)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord CLabel
- {-# GHC_PRAGMA _M_ CLabelInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq CLabel}}, (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> CLabel), (CLabel -> CLabel -> CLabel), (CLabel -> CLabel -> _CMP_TAG)] [_DFUN_ Eq (CLabel), _CONSTM_ Ord (<) (CLabel), _CONSTM_ Ord (<=) (CLabel), _CONSTM_ Ord (>=) (CLabel), _CONSTM_ Ord (>) (CLabel), _CONSTM_ Ord max (CLabel), _CONSTM_ Ord min (CLabel), _CONSTM_ Ord _tagCmp (CLabel)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
mkClosureLabel id = IdLabel (CLabelId id) Closure
mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl
mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd
-mkFastEntryLabel id arity = --false:ASSERT(arity > 0)
+mkFastEntryLabel id arity = ASSERT(arity > 0)
IdLabel (CLabelId id) (EntryFast arity)
mkConEntryLabel id = IdLabel (CLabelId id) ConEntry
mkStaticConEntryLabel id = IdLabel (CLabelId id) StaticConEntry
import Class(Class, ClassOp)
import CmdLineOpts(GlobalSwitch)
import CoreSyn(CoreAtom, CoreExpr)
-import IdInfo(ArgUsageInfo, ArityInfo, DeforestInfo, DemandInfo, FBTypeInfo, IdInfo, SpecEnv, SpecInfo, StrictnessInfo, UpdateInfo, bottomIsGuaranteed, getInfo_UF, nullSpecEnv)
+import IdInfo(ArgUsageInfo, ArityInfo, DemandInfo, FBTypeInfo, IdInfo, SpecEnv, SpecInfo, StrictnessInfo, UpdateInfo, nullSpecEnv)
import Inst(Inst, InstOrigin, OverloadedLit)
-import InstEnv(InstTemplate, InstTy)
+import InstEnv(InstTemplate)
import MagicUFs(MagicUnfoldingFun)
import Maybes(Labda)
import Name(Name)
-import NameTypes(FullName, Provenance, ShortName)
-import Outputable(ExportFlag, NamedThing, Outputable)
-import PreludeGlaST(_MutableArray)
+import NameTypes(FullName, ShortName)
+import Outputable(NamedThing, Outputable)
import PreludePS(_PackedString)
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
import PrimKind(PrimKind)
import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance)
-import SplitUniq(SplitUniqSupply)
import SrcLoc(SrcLoc)
import Subst(Subst)
import TyCon(Arity(..), TyCon)
import TyVar(TyVar, TyVarTemplate)
import TyVarEnv(TypeEnv(..))
-import UniTyFuns(getMentionedTyConsAndClassesFromUniType)
import UniType(TauType(..), ThetaType(..), UniType)
import UniqFM(UniqFM)
import Unique(Unique, UniqueSupply)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
-data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-}
+data Bag a
+data Class
+data ClassOp
type ConTag = Int
type DataCon = Id
type DictFun = Id
type DictVar = Id
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-}
-data SpecEnv {-# GHC_PRAGMA SpecEnv [SpecInfo] #-}
-data SpecInfo {-# GHC_PRAGMA SpecInfo [Labda UniType] Int Id #-}
-data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
-data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data IdDetails {-# GHC_PRAGMA LocalId ShortName Bool | SysLocalId ShortName Bool | SpecPragmaId ShortName (Labda SpecInfo) Bool | ImportedId FullName | PreludeId FullName | TopLevId FullName | DataConId FullName Int [TyVarTemplate] [(Class, UniType)] [UniType] TyCon | TupleConId Int | SuperDictSelId Class Class | ClassOpId Class ClassOp | DefaultMethodId Class ClassOp Bool | DictFunId Class UniType Bool | ConstMethodId Class UniType ClassOp Bool | InstId Inst | SpecId Id [Labda UniType] Bool | WorkerId Id #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data GlobalSwitch
+data IdInfo
+data SpecEnv
+data SpecInfo
+data Inst
+data InstTemplate
+data Labda a
+data Name
+data FullName
+data Id
+data IdDetails
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data UnfoldingDetails {-# GHC_PRAGMA NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-}
+data PrettyRep
+data PrimKind
+data UnfoldingDetails
+data SrcLoc
+data Subst
type Arity = Int
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
+data TyCon
+data TyVar
+data TyVarTemplate
type TypeEnv = UniqFM UniType
type TauType = UniType
type ThetaType = [(Class, UniType)]
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
-data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-}
+data UniType
+data UniqFM a
+data Unique
+data UniqueSupply
addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
addIdArity :: Id -> Int -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
addIdDemandInfo :: Id -> DemandInfo -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
addIdSpecialisation :: Id -> SpecEnv -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
addIdStrictness :: Id -> StrictnessInfo -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
addIdUnfolding :: Id -> UnfoldingDetails -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
addIdUpdateInfo :: Id -> UpdateInfo -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
applySubstToId :: Subst -> Id -> (Subst, Id)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LSU(LLU(S)LLLLLLL)S)" {_A_ 5 _U_ 22212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
applyTypeEnvToId :: UniqFM UniType -> Id -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLLS)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-bottomIsGuaranteed :: StrictnessInfo -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: StrictnessInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo BottomGuaranteed -> _!_ True [] []; (u1 :: StrictnessInfo) -> _!_ False [] [] } _N_ #-}
cmpId :: Id -> Id -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
cmpId_withSpecDataCon :: Id -> Id -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAL)U(U(P)AAL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
eqId :: Id -> Id -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-}
externallyVisibleId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
fIRST_TAG :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [1#] _N_ #-}
getDataConArity :: Id -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LLU(SLLLLLLLLL)L)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getDataConSig :: Id -> ([TyVarTemplate], [(Class, UniType)], [UniType], TyCon)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getDataConTag :: Id -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getDataConTyCon :: Id -> TyCon
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getIdArgUsageInfo :: Id -> ArgUsageInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAAAAASAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ArgUsageInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> uc; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getIdArity :: Id -> ArityInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(SAAAAAAAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ArityInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> u5; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getIdDemandInfo :: Id -> DemandInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(ASAAAAAAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: DemandInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> u6; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getIdFBTypeInfo :: Id -> FBTypeInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAAAAAASA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: FBTypeInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> ud; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getIdInfo :: Id -> IdInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(LLLLLLLLLL)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: IdInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u3; _NO_DEFLT_ } _N_ #-}
getIdKind :: Id -> PrimKind
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: UniType) -> case u0 of { _ALG_ (u1 :: UniType) -> _APP_ _ORIG_ UniTyFuns kindFromType [ u1 ] } _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Id) -> let {(u5 :: UniType) = case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ }} in _APP_ _ORIG_ UniTyFuns kindFromType [ u5 ] _N_ #-}
getIdSpecialisation :: Id -> SpecEnv
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAU(L)AAAAAAA)A)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [SpecInfo]) -> _!_ _ORIG_ IdInfo SpecEnv [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> u7; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getIdStrictness :: Id -> StrictnessInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAASAAAAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StrictnessInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> u8; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getIdUnfolding :: Id -> UnfoldingDetails
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAASAAAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UnfoldingDetails) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> u9; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getIdUniType :: Id -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_ #-}
getIdUpdateInfo :: Id -> UpdateInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAAASAAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UpdateInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> ua; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
-getInfo_UF :: IdInfo -> UnfoldingDetails
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAASAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UnfoldingDetails) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u5; _NO_DEFLT_ } _N_ #-}
getInstNamePieces :: Bool -> Inst -> [_PackedString]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
getInstantiatedDataConSig :: Id -> [UniType] -> ([UniType], [UniType], UniType)
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _N_ _N_ _N_ #-}
getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: UniType) -> case u0 of { _ALG_ (u1 :: UniType) -> _APP_ _ORIG_ UniTyFuns getMentionedTyConsAndClassesFromUniType [ u1 ] } _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Id) -> let {(u5 :: UniType) = case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ }} in _APP_ _ORIG_ UniTyFuns getMentionedTyConsAndClassesFromUniType [ u5 ] _N_ #-}
-getMentionedTyConsAndClassesFromUniType :: UniType -> (Bag TyCon, Bag Class)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
idWantsToBeINLINEd :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAASAAAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: UnfoldingDetails) -> case u0 of { _ALG_ _ORIG_ SimplEnv IWantToBeINLINEd (u1 :: UnfoldingGuidance) -> _!_ True [] []; (u2 :: UnfoldingDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-}
isBottomingId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAASAAAAAA)A)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: StrictnessInfo) -> case u0 of { _ALG_ (u1 :: StrictnessInfo) -> _APP_ _ORIG_ IdInfo bottomIsGuaranteed [ u1 ] } _N_} _N_ _N_ #-}
isClassOpId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id ClassOpId (u1 :: Class) (u2 :: ClassOp) -> _!_ True [] []; (u3 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-}
isConstMethodId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id ConstMethodId (u1 :: Class) (u2 :: UniType) (u3 :: ClassOp) (u4 :: Bool) -> _!_ True [] []; (u5 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-}
isDataCon :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isDefaultMethodId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id DefaultMethodId (u1 :: Class) (u2 :: ClassOp) (u3 :: Bool) -> _!_ True [] []; (u4 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-}
isDictFunId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id DictFunId (u1 :: Class) (u2 :: UniType) (u3 :: Bool) -> _!_ True [] []; (u4 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-}
isImportedId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id ImportedId (u1 :: FullName) -> _!_ True [] []; (u2 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-}
isInstId_maybe :: Id -> Labda Inst
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 19 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id InstId (u1 :: Inst) -> _!_ _ORIG_ Maybes Ni [Inst] [u1]; (u2 :: IdDetails) -> _!_ _ORIG_ Maybes Hamna [Inst] [] } _N_} _N_ _N_ #-}
isNullaryDataCon :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isSpecId_maybe :: Id -> Labda (Id, [Labda UniType])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isSpecPragmaId_maybe :: Id -> Labda (Labda SpecInfo)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 19 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id SpecPragmaId (u1 :: ShortName) (u2 :: Labda SpecInfo) (u3 :: Bool) -> _!_ _ORIG_ Maybes Ni [(Labda SpecInfo)] [u2]; (u4 :: IdDetails) -> _!_ _ORIG_ Maybes Hamna [(Labda SpecInfo)] [] } _N_} _N_ _N_ #-}
isSuperDictSelId_maybe :: Id -> Labda (Class, Class)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isSysLocalId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id SysLocalId (u1 :: ShortName) (u2 :: Bool) -> _!_ True [] []; (u3 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-}
isTopLevId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id TopLevId (u1 :: FullName) -> _!_ True [] []; (u2 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-}
isTupleCon :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isWorkerId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 18 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id WorkerId (u1 :: Id) -> _!_ True [] []; (u2 :: IdDetails) -> _!_ False [] [] } _N_} _N_ _N_ #-}
isWrapperId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAASAAAAAA)A)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: StrictnessInfo) -> case u0 of { _ALG_ (u1 :: StrictnessInfo) -> _APP_ _ORIG_ IdInfo workerExists [ u1 ] } _N_} _N_ _N_ #-}
localiseId :: Id -> Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LLLL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkClassOpId :: Unique -> Class -> ClassOp -> UniType -> IdInfo -> Id
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-}
mkConstMethodId :: Unique -> Class -> ClassOp -> UniType -> UniType -> Bool -> IdInfo -> Id
- {-# GHC_PRAGMA _A_ 7 _U_ 2222222 _N_ _N_ _N_ _N_ #-}
mkDataCon :: Unique -> FullName -> [TyVarTemplate] -> [(Class, UniType)] -> [UniType] -> TyCon -> SpecEnv -> Id
- {-# GHC_PRAGMA _A_ 7 _U_ 2222222 _N_ _N_ _N_ _N_ #-}
mkDefaultMethodId :: Unique -> Class -> ClassOp -> Bool -> UniType -> IdInfo -> Id
- {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _N_ _N_ _N_ #-}
mkDictFunId :: Unique -> Class -> UniType -> UniType -> Bool -> IdInfo -> Id
- {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _N_ _N_ _N_ #-}
mkId :: Name -> UniType -> IdInfo -> Id
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-}
mkIdWithNewUniq :: Id -> Unique -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(ALLL)L" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkImported :: Unique -> FullName -> UniType -> IdInfo -> Id
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
mkInstId :: Inst -> Id
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkPreludeId :: Unique -> FullName -> UniType -> IdInfo -> Id
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
mkSameSpecCon :: [Labda UniType] -> Id -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkSpecId :: Unique -> Id -> [Labda UniType] -> UniType -> IdInfo -> Id
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-}
mkSpecPragmaId :: _PackedString -> Unique -> UniType -> Labda SpecInfo -> SrcLoc -> Id
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-}
mkSuperDictSelId :: Unique -> Class -> Class -> UniType -> IdInfo -> Id
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-}
mkSysLocal :: _PackedString -> Unique -> UniType -> SrcLoc -> Id
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
mkTemplateLocals :: [UniType] -> [Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkTupleCon :: Int -> Id
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkUserLocal :: _PackedString -> Unique -> UniType -> SrcLoc -> Id
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
mkWorkerId :: Unique -> Id -> UniType -> IdInfo -> Id
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
myWrapperMaybe :: Id -> Labda Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 19 \ (u0 :: IdDetails) -> case u0 of { _ALG_ _ORIG_ Id WorkerId (u1 :: Id) -> _!_ _ORIG_ Maybes Ni [Id] [u1]; (u2 :: IdDetails) -> _!_ _ORIG_ Maybes Hamna [Id] [] } _N_} _N_ _N_ #-}
nullSpecEnv :: SpecEnv
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pprIdInUnfolding :: UniqFM Id -> Id -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "SU(U(P)LLL)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
replaceIdInfo :: Id -> IdInfo -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLAL)L" {_A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: UniType) (u2 :: IdDetails) (u3 :: IdInfo) -> _!_ _ORIG_ Id Id [] [u0, u1, u3, u2] _N_} _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: Id) (u1 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ Id Id (u2 :: Unique) (u3 :: UniType) (u4 :: IdInfo) (u5 :: IdDetails) -> _!_ _ORIG_ Id Id [] [u2, u3, u1, u5]; _NO_DEFLT_ } _N_ #-}
showId :: PprStyle -> Id -> [Char]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
toplevelishId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
unfoldingUnfriendlyId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
unlocaliseId :: _PackedString -> Id -> Labda Id
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLLS)" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
updateIdType :: Id -> UniType -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LALL)L" {_A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: IdInfo) (u2 :: IdDetails) (u3 :: UniType) -> _!_ _ORIG_ Id Id [] [u0, u3, u1, u2] _N_} _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: Id) (u1 :: UniType) -> case u0 of { _ALG_ _ORIG_ Id Id (u2 :: Unique) (u3 :: UniType) (u4 :: IdInfo) (u5 :: IdDetails) -> _!_ _ORIG_ Id Id [] [u2, u1, u4, u5]; _NO_DEFLT_ } _N_ #-}
whatsMentionedInId :: UniqFM Id -> Id -> (Bag Id, Bag TyCon, Bag Class)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Eq Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Ord Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_,
- getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
import BasicLit(BasicLit)
import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
import CharSeq(CSeq)
-import Class(Class)
import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
+import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
+import Id(Id)
import IdEnv(IdEnv(..))
-import InstEnv(InstTemplate, InstTy)
+import InstEnv(InstTemplate)
import MagicUFs(MagicUnfoldingFun)
import Maybes(Labda)
import Outputable(Outputable)
import PlainCore(PlainCoreAtom(..), PlainCoreExpr(..))
-import PreludeGlaST(_MutableArray)
import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind)
import PrimOps(PrimOp)
-import SimplEnv(FormSummary, IdVal, InExpr(..), OutAtom(..), OutExpr(..), OutId(..), SimplEnv, UnfoldingDetails(..), UnfoldingGuidance(..))
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc, mkUnknownSrcLoc)
+import SimplEnv(FormSummary, IdVal, InExpr(..), OutAtom(..), OutExpr(..), OutId(..), UnfoldingDetails(..), UnfoldingGuidance(..))
+import SrcLoc(SrcLoc)
import Subst(Subst)
import TaggedCore(SimplifiableBinder(..), SimplifiableCoreExpr(..))
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import TyVar(TyVar)
import UniType(UniType)
import UniqFM(UniqFM)
import Unique(UniqSM(..), Unique, UniqueSupply)
class OptIdInfo a where
noInfo :: a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 1 _N_ _S_ "U(SAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) -> _APP_ _TYAPP_ patError# { u0 } [ _NOREP_S_ "%DIdInfo.OptIdInfo.noInfo\"" ] _N_ #-}
getInfo :: IdInfo -> a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: IdInfo -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.getInfo\"", u2 ] _N_ #-}
addInfo :: IdInfo -> a -> IdInfo
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AASA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: IdInfo -> u0 -> IdInfo) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) (u3 :: u0) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0 -> IdInfo) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.addInfo\"", u2, u3 ] _N_ #-}
ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122222 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 122222 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 6 _U_ 022222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 6 XXXXXX 7 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: PprStyle) (u3 :: Id -> Id) (u4 :: u0) (u5 :: Int) (u6 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.ppInfo\"", u2, u3, u4, u5, u6 ] _N_ #-}
data ArgUsage = ArgUsage Int | UnknownArgUsage
-data ArgUsageInfo {-# GHC_PRAGMA NoArgUsageInfo | SomeArgUsageInfo [ArgUsage] #-}
+data ArgUsageInfo
type ArgUsageType = [ArgUsage]
-data ArityInfo {-# GHC_PRAGMA UnknownArity | ArityExactly Int #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-}
-data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-}
-data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
+data ArityInfo
+data Bag a
+data BasicLit
+data BinderInfo
+data CoreAtom a
+data CoreExpr a b
data DeforestInfo = Don'tDeforest | DoDeforest
data Demand = WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum
-data DemandInfo {-# GHC_PRAGMA UnknownDemand | DemandedAsPer Demand #-}
+data DemandInfo
data FBConsum = FBGoodConsum | FBBadConsum
data FBProd = FBGoodProd | FBBadProd
data FBType = FBType [FBConsum] FBProd
-data FBTypeInfo {-# GHC_PRAGMA NoFBTypeInfo | SomeFBTypeInfo FBType #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data FBTypeInfo
+data Id
type IdEnv a = UniqFM a
-data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-}
-data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-}
-data MagicUnfoldingFun {-# GHC_PRAGMA MUF (SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)) #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
+data IdInfo
+data InstTemplate
+data MagicUnfoldingFun
+data Labda a
type PlainCoreAtom = CoreAtom Id
type PlainCoreExpr = CoreExpr Id Id
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data FormSummary {-# GHC_PRAGMA WhnfForm | BottomForm | OtherForm #-}
-data IdVal {-# GHC_PRAGMA InlineIt (UniqFM IdVal) (UniqFM UniType) (CoreExpr (Id, BinderInfo) Id) | ItsAnAtom (CoreAtom Id) #-}
+data PrettyRep
+data FormSummary
+data IdVal
type InExpr = CoreExpr (Id, BinderInfo) Id
type OutAtom = CoreAtom Id
type OutExpr = CoreExpr Id Id
type OutId = Id
data UnfoldingDetails = NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance
data UnfoldingGuidance = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-}
+data SrcLoc
+data Subst
type SimplifiableBinder = (Id, BinderInfo)
type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id
-data SpecEnv {-# GHC_PRAGMA SpecEnv [SpecInfo] #-}
+data SpecEnv
data SpecInfo = SpecInfo [Labda UniType] Int Id
data StrictnessInfo = NoStrictnessInfo | BottomGuaranteed | StrictnessInfo [Demand] (Labda Id)
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data UniType
+data UniqFM a
type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
-data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-}
-data UpdateInfo {-# GHC_PRAGMA NoUpdateInfo | SomeUpdateInfo [Int] #-}
+data Unique
+data UniqueSupply
+data UpdateInfo
type UpdateSpec = [Int]
addInfo_UF :: IdInfo -> UnfoldingDetails -> IdInfo
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_ #-}
addOneToSpecEnv :: SpecEnv -> SpecInfo -> SpecEnv
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(L)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
applySubstToIdInfo :: Subst -> IdInfo -> (Subst, IdInfo)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLU(S)LLLLLLL)" _N_ _N_ #-}
apply_to_IdInfo :: (UniType -> UniType) -> IdInfo -> IdInfo
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLLLLLLLLL)" _N_ _N_ #-}
arityMaybe :: ArityInfo -> Labda Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: ArityInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo UnknownArity -> _!_ _ORIG_ Maybes Hamna [Int] []; _ORIG_ IdInfo ArityExactly (u1 :: Int) -> _!_ _ORIG_ Maybes Ni [Int] [u1]; _NO_DEFLT_ } _N_ #-}
boringIdInfo :: IdInfo -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(SLALLLLAAA)" _N_ _N_ #-}
bottomIsGuaranteed :: StrictnessInfo -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: StrictnessInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo BottomGuaranteed -> _!_ True [] []; (u1 :: StrictnessInfo) -> _!_ False [] [] } _N_ #-}
getArgUsage :: ArgUsageInfo -> [ArgUsage]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: ArgUsageInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo NoArgUsageInfo -> _!_ _NIL_ [ArgUsage] []; _ORIG_ IdInfo SomeArgUsageInfo (u1 :: [ArgUsage]) -> u1; _NO_DEFLT_ } _N_ #-}
getFBType :: FBTypeInfo -> Labda FBType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: FBTypeInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo NoFBTypeInfo -> _!_ _ORIG_ Maybes Hamna [FBType] []; _ORIG_ IdInfo SomeFBTypeInfo (u1 :: FBType) -> _!_ _ORIG_ Maybes Ni [FBType] [u1]; _NO_DEFLT_ } _N_ #-}
getInfo_UF :: IdInfo -> UnfoldingDetails
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAASAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UnfoldingDetails) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u5; _NO_DEFLT_ } _N_ #-}
getSrcLocIdInfo :: IdInfo -> SrcLoc
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> ua; _NO_DEFLT_ } _N_ #-}
getWorkerId :: StrictnessInfo -> Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getWrapperArgTypeCategories :: UniType -> StrictnessInfo -> Labda [Char]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: UnfoldingGuidance) -> _!_ _ORIG_ SimplEnv IWantToBeINLINEd [] [u0] _N_ #-}
indicatesWorker :: [Demand] -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
lookupConstMethodId :: SpecEnv -> UniType -> Labda Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(S)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupSpecEnv :: SpecEnv -> [UniType] -> Labda (Id, [UniType], Int)
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(S)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupSpecId :: Id -> [Labda UniType] -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLU(LLU(S)LLLLLLL)L)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkArgUsageInfo :: [ArgUsage] -> ArgUsageInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [ArgUsage]) -> _!_ _ORIG_ IdInfo SomeArgUsageInfo [] [u0] _N_ #-}
mkArityInfo :: Int -> ArityInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ IdInfo ArityExactly [] [u0] _N_ #-}
mkBottomStrictnessInfo :: StrictnessInfo
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo BottomGuaranteed [] [] _N_ #-}
mkDemandInfo :: Demand -> DemandInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Demand) -> _!_ _ORIG_ IdInfo DemandedAsPer [] [u0] _N_ #-}
mkFBTypeInfo :: FBType -> FBTypeInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: FBType) -> _!_ _ORIG_ IdInfo SomeFBTypeInfo [] [u0] _N_ #-}
mkMagicUnfolding :: _PackedString -> UnfoldingDetails
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkSpecEnv :: [SpecInfo] -> SpecEnv
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [SpecInfo]) -> _!_ _ORIG_ IdInfo SpecEnv [] [u0] _N_ #-}
mkStrictnessInfo :: [Demand] -> Labda Id -> StrictnessInfo
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 6 \ (u0 :: [Demand]) (u1 :: Labda Id) -> case u0 of { _ALG_ (:) (u2 :: Demand) (u3 :: [Demand]) -> _!_ _ORIG_ IdInfo StrictnessInfo [] [u0, u1]; _NIL_ -> _!_ _ORIG_ IdInfo NoStrictnessInfo [] []; _NO_DEFLT_ } _N_ #-}
mkUnfolding :: UnfoldingGuidance -> CoreExpr Id Id -> UnfoldingDetails
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
-mkUnknownSrcLoc :: SrcLoc
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkUpdateInfo :: [Int] -> UpdateInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Int]) -> _!_ _ORIG_ IdInfo SomeUpdateInfo [] [u0] _N_ #-}
noIdInfo :: IdInfo
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _ORIG_ IdInfo IdInfo [] [_CONSTM_ OptIdInfo noInfo (ArityInfo), _CONSTM_ OptIdInfo noInfo (DemandInfo), _ORIG_ IdInfo nullSpecEnv, _CONSTM_ OptIdInfo noInfo (StrictnessInfo), _ORIG_ IdInfo noInfo_UF, _CONSTM_ OptIdInfo noInfo (UpdateInfo), _CONSTM_ OptIdInfo noInfo (DeforestInfo), _CONSTM_ OptIdInfo noInfo (ArgUsageInfo), _CONSTM_ OptIdInfo noInfo (FBTypeInfo), _ORIG_ SrcLoc mkUnknownSrcLoc] _N_ #-}
noInfo_UF :: UnfoldingDetails
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ SimplEnv NoUnfoldingDetails [] [] _N_ #-}
nonAbsentArgs :: [Demand] -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
nullSpecEnv :: SpecEnv
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
ppIdInfo :: PprStyle -> Id -> Bool -> (Id -> Id) -> UniqFM UnfoldingDetails -> IdInfo -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 6 _U_ 22122222 _N_ _S_ "LLLLLU(SLLLLLLALA)" _N_ _N_ #-}
unknownArity :: ArityInfo
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo UnknownArity [] [] _N_ #-}
updateInfoMaybe :: UpdateInfo -> Labda [Int]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
willBeDemanded :: DemandInfo -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
workerExists :: StrictnessInfo -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
wwEnum :: Demand
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo WwEnum [] [] _N_ #-}
wwLazy :: Demand
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
wwPrim :: Demand
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo WwPrim [] [] _N_ #-}
wwStrict :: Demand
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo WwStrict [] [] _N_ #-}
wwUnpack :: [Demand] -> Demand
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Demand]) -> _!_ _ORIG_ IdInfo WwUnpack [] [u0] _N_ #-}
instance Eq Demand
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Demand -> Demand -> Bool), (Demand -> Demand -> Bool)] [_CONSTM_ Eq (==) (Demand), _CONSTM_ Eq (/=) (Demand)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq FBConsum
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(FBConsum -> FBConsum -> Bool), (FBConsum -> FBConsum -> Bool)] [_CONSTM_ Eq (==) (FBConsum), _CONSTM_ Eq (/=) (FBConsum)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Eq FBProd
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(FBProd -> FBProd -> Bool), (FBProd -> FBProd -> Bool)] [_CONSTM_ Eq (==) (FBProd), _CONSTM_ Eq (/=) (FBProd)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Eq FBType
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(FBType -> FBType -> Bool), (FBType -> FBType -> Bool)] [_CONSTM_ Eq (==) (FBType), _CONSTM_ Eq (/=) (FBType)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(LL)U(LL)" {_A_ 4 _U_ 2121 _N_ _N_ _N_ _N_} _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(LL)U(LL)" {_A_ 4 _U_ 2121 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Eq UpdateInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool)] [_CONSTM_ Eq (==) (UpdateInfo), _CONSTM_ Eq (/=) (UpdateInfo)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance OptIdInfo ArgUsageInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [ArgUsageInfo, (IdInfo -> ArgUsageInfo), (IdInfo -> ArgUsageInfo -> IdInfo), (PprStyle -> (Id -> Id) -> ArgUsageInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (ArgUsageInfo), _CONSTM_ OptIdInfo getInfo (ArgUsageInfo), _CONSTM_ OptIdInfo addInfo (ArgUsageInfo), _CONSTM_ OptIdInfo ppInfo (ArgUsageInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoArgUsageInfo [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ArgUsageInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u8; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_,
- ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAS" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance OptIdInfo ArityInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [ArityInfo, (IdInfo -> ArityInfo), (IdInfo -> ArityInfo -> IdInfo), (PprStyle -> (Id -> Id) -> ArityInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (ArityInfo), _CONSTM_ OptIdInfo getInfo (ArityInfo), _CONSTM_ OptIdInfo addInfo (ArityInfo), _CONSTM_ OptIdInfo ppInfo (ArityInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo UnknownArity [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(SAAAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ArityInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u1; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_,
- ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAS" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance OptIdInfo DeforestInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [DeforestInfo, (IdInfo -> DeforestInfo), (IdInfo -> DeforestInfo -> IdInfo), (PprStyle -> (Id -> Id) -> DeforestInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (DeforestInfo), _CONSTM_ OptIdInfo getInfo (DeforestInfo), _CONSTM_ OptIdInfo addInfo (DeforestInfo), _CONSTM_ OptIdInfo ppInfo (DeforestInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo Don'tDeforest [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAEAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: DeforestInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u7; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)E" _N_ _N_,
- ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAE" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance OptIdInfo DemandInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [DemandInfo, (IdInfo -> DemandInfo), (IdInfo -> DemandInfo -> IdInfo), (PprStyle -> (Id -> Id) -> DemandInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (DemandInfo), _CONSTM_ OptIdInfo getInfo (DemandInfo), _CONSTM_ OptIdInfo addInfo (DemandInfo), _CONSTM_ OptIdInfo ppInfo (DemandInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo UnknownDemand [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(ASAAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: DemandInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u2; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LALLLLLLLL)L" _N_ _N_,
- ppInfo = _A_ 3 _U_ 10122 _N_ _S_ "SAL" {_A_ 2 _U_ 1122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance OptIdInfo FBTypeInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [FBTypeInfo, (IdInfo -> FBTypeInfo), (IdInfo -> FBTypeInfo -> IdInfo), (PprStyle -> (Id -> Id) -> FBTypeInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (FBTypeInfo), _CONSTM_ OptIdInfo getInfo (FBTypeInfo), _CONSTM_ OptIdInfo addInfo (FBTypeInfo), _CONSTM_ OptIdInfo ppInfo (FBTypeInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoFBTypeInfo [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAASA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: FBTypeInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u9; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_,
- ppInfo = _A_ 3 _U_ 20222 _N_ _S_ "SAS" {_A_ 2 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance OptIdInfo SpecEnv
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [SpecEnv, (IdInfo -> SpecEnv), (IdInfo -> SpecEnv -> IdInfo), (PprStyle -> (Id -> Id) -> SpecEnv -> Int -> Bool -> PrettyRep)] [_ORIG_ IdInfo nullSpecEnv, _CONSTM_ OptIdInfo getInfo (SpecEnv), _CONSTM_ OptIdInfo addInfo (SpecEnv), _CONSTM_ OptIdInfo ppInfo (SpecEnv)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ IdInfo nullSpecEnv _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAU(L)AAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [SpecInfo]) -> _!_ _ORIG_ IdInfo SpecEnv [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u3; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 11 _N_ _S_ "U(LLU(L)LLLLLLL)U(L)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_,
- ppInfo = _A_ 3 _U_ 22122 _N_ _S_ "LLU(S)" {_A_ 3 _U_ 22122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance OptIdInfo StrictnessInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [StrictnessInfo, (IdInfo -> StrictnessInfo), (IdInfo -> StrictnessInfo -> IdInfo), (PprStyle -> (Id -> Id) -> StrictnessInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (StrictnessInfo), _CONSTM_ OptIdInfo getInfo (StrictnessInfo), _CONSTM_ OptIdInfo addInfo (StrictnessInfo), _CONSTM_ OptIdInfo ppInfo (StrictnessInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoStrictnessInfo [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAASAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StrictnessInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u4; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_,
- ppInfo = _A_ 3 _U_ 22122 _N_ _S_ "LLS" _N_ _N_ #-}
instance OptIdInfo UpdateInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [UpdateInfo, (IdInfo -> UpdateInfo), (IdInfo -> UpdateInfo -> IdInfo), (PprStyle -> (Id -> Id) -> UpdateInfo -> Int -> Bool -> PrettyRep)] [_CONSTM_ OptIdInfo noInfo (UpdateInfo), _CONSTM_ OptIdInfo getInfo (UpdateInfo), _CONSTM_ OptIdInfo addInfo (UpdateInfo), _CONSTM_ OptIdInfo ppInfo (UpdateInfo)] _N_
- noInfo = _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ IdInfo NoUpdateInfo [] [] _N_,
- getInfo = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAASAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UpdateInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: IdInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo IdInfo (u1 :: ArityInfo) (u2 :: DemandInfo) (u3 :: SpecEnv) (u4 :: StrictnessInfo) (u5 :: UnfoldingDetails) (u6 :: UpdateInfo) (u7 :: DeforestInfo) (u8 :: ArgUsageInfo) (u9 :: FBTypeInfo) (ua :: SrcLoc) -> u6; _NO_DEFLT_ } _N_,
- addInfo = _A_ 2 _U_ 12 _N_ _S_ "U(LLLLLLLLLL)S" _N_ _N_,
- ppInfo = _A_ 3 _U_ 20122 _N_ _S_ "LAS" {_A_ 2 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord Demand
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Demand}}, (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Demand), (Demand -> Demand -> Demand), (Demand -> Demand -> _CMP_TAG)] [_DFUN_ Eq (Demand), _CONSTM_ Ord (<) (Demand), _CONSTM_ Ord (<=) (Demand), _CONSTM_ Ord (>=) (Demand), _CONSTM_ Ord (>) (Demand), _CONSTM_ Ord max (Demand), _CONSTM_ Ord min (Demand), _CONSTM_ Ord _tagCmp (Demand)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord UpdateInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq UpdateInfo}}, (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> Bool), (UpdateInfo -> UpdateInfo -> UpdateInfo), (UpdateInfo -> UpdateInfo -> UpdateInfo), (UpdateInfo -> UpdateInfo -> _CMP_TAG)] [_DFUN_ Eq (UpdateInfo), _CONSTM_ Ord (<) (UpdateInfo), _CONSTM_ Ord (<=) (UpdateInfo), _CONSTM_ Ord (>=) (UpdateInfo), _CONSTM_ Ord (>) (UpdateInfo), _CONSTM_ Ord max (UpdateInfo), _CONSTM_ Ord min (UpdateInfo), _CONSTM_ Ord _tagCmp (UpdateInfo)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable Demand
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Demand) _N_
- ppr = _A_ 2 _U_ 0220 _N_ _S_ "AL" {_A_ 1 _U_ 220 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Text Demand
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Demand, [Char])]), (Int -> Demand -> [Char] -> [Char]), ([Char] -> [([Demand], [Char])]), ([Demand] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Demand), _CONSTM_ Text showsPrec (Demand), _CONSTM_ Text readList (Demand), _CONSTM_ Text showList (Demand)] _N_
- readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(Demand, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 3 _U_ 222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Demand) (u2 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> Demand -> [Char] -> [Char]) } [ _NOREP_S_ "%DPreludeCore.Text.showsPrec\"", u0, u1, u2 ] _N_,
- readList = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- showList = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
instance Text UpdateInfo
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(UpdateInfo, [Char])]), (Int -> UpdateInfo -> [Char] -> [Char]), ([Char] -> [([UpdateInfo], [Char])]), ([UpdateInfo] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (UpdateInfo), _CONSTM_ Text showsPrec (UpdateInfo), _CONSTM_ Text readList (UpdateInfo), _CONSTM_ Text showList (UpdateInfo)] _N_
- readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AS" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 3 _U_ 222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: UpdateInfo) (u2 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> UpdateInfo -> [Char] -> [Char]) } [ _NOREP_S_ "%DPreludeCore.Text.showsPrec\"", u0, u1, u2 ] _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Inst where
-import Bag(Bag)
import Class(Class, ClassOp)
import HsBinds(Binds)
import HsExpr(ArithSeqInfo, Expr, Qual, RenamedArithSeqInfo(..), RenamedExpr(..))
import HsMatches(Match)
import HsPat(InPat, RenamedPat(..))
import HsTypes(PolyType)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo, SpecEnv)
-import InstEnv(ClassInstEnv(..), InstTemplate, InstTy, InstanceMapper(..), MatchEnv(..))
+import Id(Id)
+import IdInfo(SpecEnv)
+import InstEnv(ClassInstEnv(..), InstTemplate, InstanceMapper(..), MatchEnv(..))
import Maybes(Labda)
import Name(Name)
import NameTypes(FullName, ShortName)
import Outputable(Outputable)
-import PreludeGlaST(_MutableArray)
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
import Pretty(PprStyle, PrettyRep)
import Subst(Subst)
import TyCon(TyCon)
import TyVar(TyVar, TyVarTemplate)
-import UniTyFuns(isTyVarTy)
import UniType(UniType)
import Unique(Unique)
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
-data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-}
-data ArithSeqInfo a b {-# GHC_PRAGMA From (Expr a b) | FromThen (Expr a b) (Expr a b) | FromTo (Expr a b) (Expr a b) | FromThenTo (Expr a b) (Expr a b) (Expr a b) #-}
-data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-}
+data Class
+data ClassOp
+data ArithSeqInfo a b
+data Expr a b
data Inst = Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin
data InstOrigin = OccurrenceOf Id SrcLoc | InstanceDeclOrigin SrcLoc | LiteralOrigin Literal SrcLoc | ArithSeqOrigin (ArithSeqInfo Name (InPat Name)) SrcLoc | SignatureOrigin | ClassDeclOrigin SrcLoc | DerivingOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class Bool TyCon SrcLoc | InstanceSpecOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class UniType SrcLoc | DefaultDeclOrigin SrcLoc | ValSpecOrigin Name SrcLoc | CCallOrigin SrcLoc [Char] (Labda (Expr Name (InPat Name))) | LitLitOrigin SrcLoc [Char] | UnknownOrigin
data OverloadedLit = OverloadedIntegral Integer Id Id | OverloadedFractional (Ratio Integer) Id
type RenamedArithSeqInfo = ArithSeqInfo Name (InPat Name)
type RenamedExpr = Expr Name (InPat Name)
-data Literal {-# GHC_PRAGMA CharLit Char | CharPrimLit Char | StringLit _PackedString | StringPrimLit _PackedString | IntLit Integer | FracLit (Ratio Integer) | LitLitLitIn _PackedString | LitLitLit _PackedString UniType | IntPrimLit Integer | FloatPrimLit (Ratio Integer) | DoublePrimLit (Ratio Integer) #-}
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
+data Literal
+data InPat a
type RenamedPat = InPat Name
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
type ClassInstEnv = [(UniType, InstTemplate)]
-data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-}
+data InstTemplate
type InstanceMapper = Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)
type MatchEnv a b = [(a, b)]
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Name
+data PrimKind
+data SrcLoc
+data Subst
+data TyCon
+data TyVar
+data TyVarTemplate
+data UniType
+data Unique
applySubstToInst :: Subst -> Inst -> (Subst, Inst)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
apply_to_Inst :: (UniType -> UniType) -> Inst -> Inst
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
extractConstrainedTyVarsFromInst :: Inst -> [TyVar]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
extractTyVarsFromInst :: Inst -> [TyVar]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getDictClassAndType :: Inst -> (Class, UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getInstOrigin :: Inst -> (SrcLoc, PprStyle -> Int -> Bool -> PrettyRep)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getInstUniType :: Inst -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instBindingRequired :: Inst -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instCanBeGeneralised :: Inst -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isTyVarDict :: Inst -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: Inst) -> case u0 of { _ALG_ _ORIG_ Inst Dict (u1 :: Unique) (u2 :: Class) (u3 :: UniType) (u4 :: InstOrigin) -> _APP_ _ORIG_ UniTyFuns isTyVarTy [ u3 ]; (u5 :: Inst) -> _!_ False [] [] } _N_ #-}
-isTyVarTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
matchesInst :: Inst -> Inst -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
mkDict :: Unique -> Class -> UniType -> InstOrigin -> Inst
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: Class) (u2 :: UniType) (u3 :: InstOrigin) -> _!_ _ORIG_ Inst Dict [] [u0, u1, u2, u3] _N_ #-}
mkLitInst :: Unique -> OverloadedLit -> UniType -> InstOrigin -> Inst
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: OverloadedLit) (u2 :: UniType) (u3 :: InstOrigin) -> _!_ _ORIG_ Inst LitInst [] [u0, u1, u2, u3] _N_ #-}
mkMethod :: Unique -> Id -> [UniType] -> InstOrigin -> Inst
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: Id) (u2 :: [UniType]) (u3 :: InstOrigin) -> _!_ _ORIG_ Inst Method [] [u0, u1, u2, u3] _N_ #-}
instance Outputable Inst
- {-# GHC_PRAGMA _M_ Inst {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Inst) _N_
- ppr = _A_ 2 _U_ 1222 _N_ _S_ "SS" _N_ _N_ #-}
import PreludePS(_PackedString)
import SrcLoc(SrcLoc)
import Unique(Unique)
-data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-}
-data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-}
+data ExportFlag
+data FullName
data Provenance = ThisModule | InventedInThisModule | ExportedByPreludeCore | OtherPrelude _PackedString | OtherModule _PackedString [_PackedString] | HereInPreludeCore | OtherInstance _PackedString [_PackedString]
-data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data ShortName
+data SrcLoc
+data Unique
fromPrelude :: _PackedString -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
invisibleFullName :: FullName -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAEA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Bool) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u5; _NO_DEFLT_ } _N_ #-}
mkFullName :: _PackedString -> _PackedString -> Provenance -> ExportFlag -> SrcLoc -> FullName
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-}
mkPreludeCoreName :: _PackedString -> _PackedString -> FullName
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
mkPrivateFullName :: _PackedString -> _PackedString -> Provenance -> ExportFlag -> SrcLoc -> FullName
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-}
mkShortName :: _PackedString -> SrcLoc -> ShortName
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: SrcLoc) -> _!_ _ORIG_ NameTypes ShortName [] [u0, u1] _N_ #-}
unlocaliseFullName :: FullName -> FullName
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LLLALL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
unlocaliseShortName :: _PackedString -> Unique -> ShortName -> FullName
- {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LLU(LL)" {_A_ 4 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing FullName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(FullName -> ExportFlag), (FullName -> Bool), (FullName -> (_PackedString, _PackedString)), (FullName -> _PackedString), (FullName -> [_PackedString]), (FullName -> SrcLoc), (FullName -> Unique), (FullName -> Bool), (FullName -> UniType), (FullName -> Bool)] [_CONSTM_ NamedThing getExportFlag (FullName), _CONSTM_ NamedThing isLocallyDefined (FullName), _CONSTM_ NamedThing getOrigName (FullName), _CONSTM_ NamedThing getOccurrenceName (FullName), _CONSTM_ NamedThing getInformingModules (FullName), _CONSTM_ NamedThing getSrcLoc (FullName), _CONSTM_ NamedThing getTheUnique (FullName), _CONSTM_ NamedThing hasType (FullName), _CONSTM_ NamedThing getType (FullName), _CONSTM_ NamedThing fromPreludeCore (FullName)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAEAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u4; _NO_DEFLT_ } _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ThisModule -> _!_ True [] []; _ORIG_ NameTypes InventedInThisModule -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LLAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [u1, u2]; _NO_DEFLT_ } _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(ALSAAA)" {_A_ 2 _U_ 11 _N_ _N_ _F_ _IF_ARGS_ 0 2 XC 10 \ (u0 :: _PackedString) (u1 :: Provenance) -> case u1 of { _ALG_ _ORIG_ NameTypes OtherPrelude (u2 :: _PackedString) -> u2; _ORIG_ NameTypes OtherModule (u3 :: _PackedString) (u4 :: [_PackedString]) -> u3; (u5 :: Provenance) -> u0 } _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ExportedByPreludeCore -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_ #-}
instance NamedThing ShortName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(ShortName -> ExportFlag), (ShortName -> Bool), (ShortName -> (_PackedString, _PackedString)), (ShortName -> _PackedString), (ShortName -> [_PackedString]), (ShortName -> SrcLoc), (ShortName -> Unique), (ShortName -> Bool), (ShortName -> UniType), (ShortName -> Bool)] [_CONSTM_ NamedThing getExportFlag (ShortName), _CONSTM_ NamedThing isLocallyDefined (ShortName), _CONSTM_ NamedThing getOrigName (ShortName), _CONSTM_ NamedThing getOccurrenceName (ShortName), _CONSTM_ NamedThing getInformingModules (ShortName), _CONSTM_ NamedThing getSrcLoc (ShortName), _CONSTM_ NamedThing getTheUnique (ShortName), _CONSTM_ NamedThing hasType (ShortName), _CONSTM_ NamedThing getType (ShortName), _CONSTM_ NamedThing fromPreludeCore (ShortName)] _N_
- getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ _ORIG_ Outputable NotExported [] [] _N_,
- isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ True [] [] _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(SA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: _PackedString) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u1; _NO_DEFLT_ } _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u2; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AA)" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> _!_ False [] []; _NO_DEFLT_ } _N_ #-}
instance Outputable FullName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (FullName) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LLLLAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable ShortName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (ShortName) _N_
- ppr = _A_ 4 _U_ 0120 _N_ _S_ "AU(LA)LA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getOrigName (ShortName s l) = (panic "NamedThing.ShortName.getOrigName", s)
getOccurrenceName (ShortName s l) = s
getSrcLoc (ShortName s l) = l
- fromPreludeCore (ShortName _ _) = False
+ fromPreludeCore _ = False
#ifdef DEBUG
getTheUnique (ShortName s l) = panic "NamedThing.ShortName.getTheUnique"
getInformingModules a = panic "NamedThing.ShortName.getInformingModule"
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface OrdList where
-data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-}
+data OrdList a
flattenOrdList :: OrdList a -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkEmptyList :: OrdList a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ OrdList NoObj [u0] [] _N_ #-}
mkParList :: OrdList a -> OrdList a -> OrdList a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: OrdList u0) (u2 :: OrdList u0) -> _!_ _ORIG_ OrdList ParList [u0] [u1, u2] _N_ #-}
mkSeqList :: OrdList a -> OrdList a -> OrdList a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: OrdList u0) (u2 :: OrdList u0) -> _!_ _ORIG_ OrdList SeqList [u0] [u1, u2] _N_ #-}
mkUnitList :: a -> OrdList a
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: u0) -> _!_ _ORIG_ OrdList OrdObj [u0] [u1] _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface ProtoName where
-import Id(Id)
import Maybes(Labda)
import Name(Name)
-import NameTypes(FullName, ShortName)
import Outputable(NamedThing, Outputable)
import PreludePS(_PackedString)
-import TyCon(TyCon)
-import Unique(Unique)
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
+data Labda a
+data Name
data ProtoName = Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name
cmpByLocalName :: ProtoName -> ProtoName -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
cmpProtoName :: ProtoName -> ProtoName -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
elemByLocalNames :: ProtoName -> [ProtoName] -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
elemProtoNames :: ProtoName -> [ProtoName] -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
eqByLocalName :: ProtoName -> ProtoName -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
eqProtoName :: ProtoName -> ProtoName -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
isConopPN :: ProtoName -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkPreludeProtoName :: Name -> ProtoName
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Name) -> _!_ _ORIG_ ProtoName Prel [] [u0] _N_ #-}
instance NamedThing ProtoName
- {-# GHC_PRAGMA _M_ ProtoName {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(ProtoName -> ExportFlag), (ProtoName -> Bool), (ProtoName -> (_PackedString, _PackedString)), (ProtoName -> _PackedString), (ProtoName -> [_PackedString]), (ProtoName -> SrcLoc), (ProtoName -> Unique), (ProtoName -> Bool), (ProtoName -> UniType), (ProtoName -> Bool)] [_CONSTM_ NamedThing getExportFlag (ProtoName), _CONSTM_ NamedThing isLocallyDefined (ProtoName), _CONSTM_ NamedThing getOrigName (ProtoName), _CONSTM_ NamedThing getOccurrenceName (ProtoName), _CONSTM_ NamedThing getInformingModules (ProtoName), _CONSTM_ NamedThing getSrcLoc (ProtoName), _CONSTM_ NamedThing getTheUnique (ProtoName), _CONSTM_ NamedThing hasType (ProtoName), _CONSTM_ NamedThing getType (ProtoName), _CONSTM_ NamedThing fromPreludeCore (ProtoName)] _N_
- getExportFlag = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u0 ] _N_,
- isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u0 ] _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: ProtoName) -> case u0 of { _ALG_ _ORIG_ ProtoName Unk (u1 :: _PackedString) -> u1; _ORIG_ ProtoName Imp (u2 :: _PackedString) (u3 :: _PackedString) (u4 :: [_PackedString]) (u5 :: _PackedString) -> u5; _ORIG_ ProtoName Prel (u6 :: Name) -> _APP_ _CONSTM_ NamedThing getOccurrenceName (Name) [ u6 ]; _NO_DEFLT_ } _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_,
- getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u0 ] _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_,
- hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ProtoName) -> _!_ False [] [] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ProtoName) -> _APP_ _TYAPP_ patError# { (ProtoName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u0 ] _N_ #-}
instance Outputable ProtoName
- {-# GHC_PRAGMA _M_ ProtoName {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (ProtoName) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface SplitUniq where
-import Unique(Unique, mkUniqueGrimily)
+import Unique(Unique)
type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data SplitUniqSupply
+data Unique
getSUnique :: SplitUniqSupply -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> case u1 of { _ALG_ I# (u4 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u4]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getSUniqueAndDepleted :: SplitUniqSupply -> (Unique, SplitUniqSupply)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)LA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getSUniques :: Int -> SplitUniqSupply -> [Unique]
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)L" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getSUniquesAndDepleted :: Int -> SplitUniqSupply -> ([Unique], SplitUniqSupply)
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
initSUs :: SplitUniqSupply -> (SplitUniqSupply -> a) -> (SplitUniqSupply, a)
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(ALL)L" {_A_ 3 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 3 XXX 6 _/\_ u0 -> \ (u1 :: SplitUniqSupply) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply -> u0) -> let {(u4 :: u0) = _APP_ u3 [ u1 ]} in _!_ _TUP_2 [SplitUniqSupply, u0] [u2, u4] _N_} _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: SplitUniqSupply) (u2 :: SplitUniqSupply -> u0) -> case u1 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u3 :: Int) (u4 :: SplitUniqSupply) (u5 :: SplitUniqSupply) -> let {(u6 :: u0) = _APP_ u2 [ u4 ]} in _!_ _TUP_2 [SplitUniqSupply, u0] [u5, u6]; _NO_DEFLT_ } _N_ #-}
mapAndUnzipSUs :: (a -> SplitUniqSupply -> (b, c)) -> [a] -> SplitUniqSupply -> ([b], [c])
- {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-}
mapSUs :: (a -> SplitUniqSupply -> b) -> [a] -> SplitUniqSupply -> [b]
- {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-}
mkSplitUniqSupply :: Char -> _State _RealWorld -> (SplitUniqSupply, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-mkUniqueGrimily :: Int# -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_ #-}
returnSUs :: a -> SplitUniqSupply -> a
- {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _S_ "SL" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: SplitUniqSupply) -> u1 _N_ #-}
splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-}
thenSUs :: (SplitUniqSupply -> a) -> (a -> SplitUniqSupply -> b) -> SplitUniqSupply -> b
- {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LSS" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: SplitUniqSupply -> u0) (u3 :: u0 -> SplitUniqSupply -> u1) (u4 :: SplitUniqSupply) -> case _APP_ _ORIG_ SplitUniq splitUniqSupply [ u4 ] of { _ALG_ _TUP_2 (u5 :: SplitUniqSupply) (u6 :: SplitUniqSupply) -> let {(u7 :: u0) = _APP_ u2 [ u5 ]} in _APP_ u3 [ u7, u6 ]; _NO_DEFLT_ } _N_ #-}
interface SrcLoc where
import Outputable(Outputable)
import PreludePS(_PackedString)
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
+data SrcLoc
mkBuiltinSrcLoc :: SrcLoc
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkGeneratedSrcLoc :: SrcLoc
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkSrcLoc :: _PackedString -> _PackedString -> SrcLoc
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _ORIG_ SrcLoc SrcLoc [] [u0, u1] _N_ #-}
mkSrcLoc2 :: _PackedString -> Int -> SrcLoc
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: Int#) -> _!_ _ORIG_ SrcLoc SrcLoc2 [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 XC 4 \ (u0 :: _PackedString) (u1 :: Int) -> case u1 of { _ALG_ I# (u2 :: Int#) -> _!_ _ORIG_ SrcLoc SrcLoc2 [] [u0, u2]; _NO_DEFLT_ } _N_ #-}
mkUnknownSrcLoc :: SrcLoc
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
unpackSrcLoc :: SrcLoc -> (_PackedString, _PackedString)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instance Outputable SrcLoc
- {-# GHC_PRAGMA _M_ SrcLoc {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (SrcLoc) _N_
- ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-}
import SplitUniq(SplitUniqSupply)
import UniType(UniType)
infixr 9 `thenUs`
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
+data CSeq
+data PrimOp
+data SplitUniqSupply
type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
-data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-}
+data Unique
+data UniqueSupply
absentErrorIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
addrDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
addrPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
addrTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
arrayPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
binaryClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
boolTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
buildDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
buildIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
byteArrayPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
cCallableClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
cReturnableClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
cmpTagTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
cmpUnique :: Unique -> Unique -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _ALWAYS_ \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> 0#; False -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> -1#; False -> 1#; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
consDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
dialogueTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
doubleDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
doublePrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
doubleTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
enumClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
eqClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
eqTagDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
eqUnique :: Unique -> Unique -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _ALWAYS_ \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
errorIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
falseDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatingClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
foldlIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
foldrIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
forkIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
fractionalClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
getBuiltinUniques :: Int -> [Unique]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
getUnique :: UniqueSupply -> (UniqueSupply, Unique)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getUniques :: Int -> UniqueSupply -> (UniqueSupply, [Unique])
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)S" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-}
gtTagDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
iOTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
initUs :: UniqueSupply -> (UniqueSupply -> (UniqueSupply, a)) -> (UniqueSupply, a)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _F_ _IF_ARGS_ 1 2 XX 2 _/\_ u0 -> \ (u1 :: UniqueSupply) (u2 :: UniqueSupply -> (UniqueSupply, u0)) -> _APP_ u2 [ u1 ] _N_ #-}
intDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integerDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integerMinusOneIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integerPlusOneIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integerTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integerZeroIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integralClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
ixClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
liftDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
liftTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
listTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
ltTagDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mallocPtrDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mallocPtrPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mallocPtrTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mapAndUnzipUs :: (a -> UniqueSupply -> (UniqueSupply, (b, c))) -> [a] -> UniqueSupply -> (UniqueSupply, ([b], [c]))
- {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-}
mapUs :: (a -> UniqueSupply -> (UniqueSupply, b)) -> [a] -> UniqueSupply -> (UniqueSupply, [b])
- {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-}
mkBuiltinUnique :: Int -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkPrimOpIdUnique :: PrimOp -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkPseudoUnique1 :: Int -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkPseudoUnique2 :: Int -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkPseudoUnique3 :: Int -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkTupleDataConUnique :: Int -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkUnifiableTyVarUnique :: Int -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkUniqueGrimily :: Int# -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_ #-}
mkUniqueSupplyGrimily :: SplitUniqSupply -> UniqueSupply
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: SplitUniqSupply) -> _!_ _ORIG_ Unique MkNewSupply [] [u0] _N_ #-}
mutableArrayPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mutableByteArrayPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
nilDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
numClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
ordClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
packCStringIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
parErrorIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
parIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
patErrorIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pprUnique :: Unique -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
pprUnique10 :: Unique -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
primIoTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
ratioDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
ratioTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
rationalTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
realClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
realFloatClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
realFracClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
realWorldPrimIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
realWorldTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
return2GMPsDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
return2GMPsTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
returnIntAndGMPDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
returnIntAndGMPTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
returnUs :: a -> UniqueSupply -> (UniqueSupply, a)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: UniqueSupply) -> _!_ _TUP_2 [UniqueSupply, u0] [u2, u1] _N_ #-}
runBuiltinUs :: (UniqueSupply -> (UniqueSupply, a)) -> a
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
runSTIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
seqIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
showUnique :: Unique -> _PackedString
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
stTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stablePtrDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stablePtrPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stablePtrTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndAddrPrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndAddrPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndArrayPrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndArrayPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndByteArrayPrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndByteArrayPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndCharPrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndCharPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndDoublePrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndDoublePrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndFloatPrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndFloatPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndIntPrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndIntPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndMallocPtrPrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndMallocPtrPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndMutableArrayPrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndMutableArrayPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndMutableByteArrayPrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndMutableByteArrayPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndPtrPrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndPtrPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndStablePtrPrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndStablePtrPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndSynchVarPrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndSynchVarPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndWordPrimDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndWordPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
statePrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stringTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
synchVarPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
textClassKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
thenUs :: (UniqueSupply -> (UniqueSupply, a)) -> (a -> UniqueSupply -> (UniqueSupply, b)) -> UniqueSupply -> (UniqueSupply, b)
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: UniqueSupply -> (UniqueSupply, u0)) (u3 :: u0 -> UniqueSupply -> (UniqueSupply, u1)) (u4 :: UniqueSupply) -> case _APP_ u2 [ u4 ] of { _ALG_ _TUP_2 (u5 :: UniqueSupply) (u6 :: u0) -> _APP_ u3 [ u6, u5 ]; _NO_DEFLT_ } _N_ #-}
traceIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
trueDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
u2i :: Unique -> Int#
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-}
uniqSupply_u :: UniqueSupply
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+unpackCString2IdKey :: Unique
+unpackCStringAppendIdKey :: Unique
unpackCStringIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
unpkUnifiableTyVarUnique :: Unique -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
voidPrimIdKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
voidPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
wordDataConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
wordPrimTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
wordTyConKey :: Unique
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
instance Eq Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Ord Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Text Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_
- readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_,
- showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
textClassKey,
traceIdKey,
trueDataConKey,
- unpackCStringIdKey,
+ unpackCStringIdKey, unpackCString2IdKey, unpackCStringAppendIdKey,
packCStringIdKey,
integerZeroIdKey, integerPlusOneIdKey, integerMinusOneIdKey,
voidPrimIdKey,
\begin{code}
mkPreludeClassUnique i = mkUnique '1' i
mkPreludeTyConUnique i = mkUnique '2' i
-mkPreludeDataConUnique i = mkUnique '3' i
-mkTupleDataConUnique i = mkUnique '4' i
+mkPreludeDataConUnique i = mkUnique 'Y' i -- must be alphabetic
+mkTupleDataConUnique i = mkUnique 'Z' i -- ditto (*may* be used in C labels)
-- mkPrimOpIdUnique op: see below (uses '5')
mkPreludeMiscIdUnique i = mkUnique '7' i
\end{code}
--UNUSED:showSpaceIdKey = mkPreludeMiscIdUnique 21
traceIdKey = mkPreludeMiscIdUnique 22
unpackCStringIdKey = mkPreludeMiscIdUnique 23
+unpackCString2IdKey = mkPreludeMiscIdUnique 20 -- NB: NB: NB
+unpackCStringAppendIdKey= mkPreludeMiscIdUnique 21 -- NB: NB: NB
voidPrimIdKey = mkPreludeMiscIdUnique 24
#ifdef GRAN
import BasicLit(BasicLit)
import CLabelInfo(CLabel)
import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import ClosureInfo(ClosureInfo, LambdaFormInfo, StandardFormInfo)
+import ClosureInfo(ClosureInfo, LambdaFormInfo)
import CostCentre(CostCentre)
import HeapOffs(HeapOffset)
-import Id(Id, IdDetails)
+import Id(Id)
import IdEnv(IdEnv(..))
-import IdInfo(IdInfo)
import Maybes(Labda)
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
import PrimKind(PrimKind)
import PrimOps(PrimOp)
import StgSyn(StgAtom)
-import UniType(UniType)
import UniqFM(UniqFM)
import UniqSet(UniqSet(..))
import Unique(Unique)
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
-data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-}
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
-data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-}
+data AbstractC
+data CAddrMode
+data MagicId
+data BasicLit
data CLabel
type CgBindings = UniqFM CgIdInfo
data CgIdInfo = MkCgIdInfo Id VolatileLoc StableLoc LambdaFormInfo
-data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-}
-data LambdaFormInfo {-# GHC_PRAGMA LFReEntrant Bool Int Bool | LFCon Id Bool | LFTuple Id Bool | LFThunk Bool Bool Bool StandardFormInfo | LFArgument | LFImported | LFLetNoEscape Int (UniqFM Id) | LFBlackHole | LFIndirection #-}
+data CgState
+data LambdaFormInfo
data HeapOffset
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
type IdEnv a = UniqFM a
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data StableLoc {-# GHC_PRAGMA NoStableLoc | VirAStkLoc Int | VirBStkLoc Int | LitLoc BasicLit | StableAmodeLoc CAddrMode #-}
-data StgAtom a {-# GHC_PRAGMA StgVarAtom a | StgLitAtom BasicLit #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data Labda a
+data StableLoc
+data StgAtom a
+data UniqFM a
type UniqSet a = UniqFM a
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
-data VolatileLoc {-# GHC_PRAGMA NoVolatileLoc | TempVarLoc Unique | RegLoc MagicId | VirHpLoc HeapOffset | VirNodeLoc HeapOffset #-}
+data Unique
+data VolatileLoc
bindArgsToRegs :: [Id] -> [MagicId] -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _N_ _N_ #-}
bindNewPrimToAmode :: Id -> CAddrMode -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
bindNewToAStack :: (Id, Int) -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 101 _N_ _S_ "U(LL)AU(LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
bindNewToBStack :: (Id, Int) -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 101 _N_ _S_ "U(LL)AU(LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
bindNewToNode :: Id -> HeapOffset -> LambdaFormInfo -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 5 _U_ 22201 _N_ _S_ "LLLAU(LLL)" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
bindNewToReg :: Id -> MagicId -> LambdaFormInfo -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 5 _U_ 22201 _N_ _S_ "LLLAU(LLL)" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
bindNewToTemp :: Id -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
- {-# GHC_PRAGMA _A_ 1 _U_ 201 _N_ _N_ _N_ _N_ #-}
getAtomAmode :: StgAtom Id -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "S" _N_ _N_ #-}
getAtomAmodes :: [StgAtom Id] -> CgInfoDownwards -> CgState -> ([CAddrMode], CgState)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "S" _N_ _N_ #-}
getCAddrMode :: Id -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(LLLS)" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getCAddrModeAndInfo :: Id -> CgInfoDownwards -> CgState -> ((CAddrMode, LambdaFormInfo), CgState)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(LLLS)" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getCAddrModeIfVolatile :: Id -> CgInfoDownwards -> CgState -> (Labda CAddrMode, CgState)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(LLLS)" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getVolatileRegs :: UniqFM Id -> CgInfoDownwards -> CgState -> ([MagicId], CgState)
- {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _N_ _N_ _N_ #-}
heapIdInfo :: Id -> HeapOffset -> LambdaFormInfo -> CgIdInfo
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
idInfoToAmode :: PrimKind -> CgIdInfo -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LU(ASLA)" {_A_ 5 _U_ 21122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
letNoEscapeIdInfo :: Id -> Int -> Int -> LambdaFormInfo -> CgIdInfo
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
maybeAStkLoc :: StableLoc -> Labda Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: StableLoc) -> case u0 of { _ALG_ _ORIG_ CgBindery VirAStkLoc (u1 :: Int) -> _!_ _ORIG_ Maybes Ni [Int] [u1]; (u2 :: StableLoc) -> _!_ _ORIG_ Maybes Hamna [Int] [] } _N_ #-}
maybeBStkLoc :: StableLoc -> Labda Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: StableLoc) -> case u0 of { _ALG_ _ORIG_ CgBindery VirBStkLoc (u1 :: Int) -> _!_ _ORIG_ Maybes Ni [Int] [u1]; (u2 :: StableLoc) -> _!_ _ORIG_ Maybes Hamna [Int] [] } _N_ #-}
newTempAmodeAndIdInfo :: Id -> LambdaFormInfo -> (CAddrMode, CgIdInfo)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
nukeVolatileBinds :: UniqFM CgIdInfo -> UniqFM CgIdInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
rebindToAStack :: Id -> Int -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 4 _U_ 2201 _N_ _S_ "LLAU(LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rebindToBStack :: Id -> Int -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 4 _U_ 2201 _N_ _S_ "LLAU(LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
stableAmodeIdInfo :: Id -> CAddrMode -> LambdaFormInfo -> CgIdInfo
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
import CgMonad(CgInfoDownwards, CgState, EndOfBlockInfo, StubFlag)
import CostCentre(CostCentre)
import HeapOffs(HeapOffset)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Maybes(Labda)
import PrimOps(PrimOp)
import StgSyn(StgAtom, StgBinding, StgCaseAlternatives, StgCaseDefault, StgExpr)
import UniType(UniType)
import UniqFM(UniqFM)
import Unique(Unique)
-data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data StgCaseAlternatives a b {-# GHC_PRAGMA StgAlgAlts UniType [(Id, [a], [Bool], StgExpr a b)] (StgCaseDefault a b) | StgPrimAlts UniType [(BasicLit, StgExpr a b)] (StgCaseDefault a b) #-}
-data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-}
+data CgState
+data Id
+data StgCaseAlternatives a b
+data StgExpr a b
cgCase :: StgExpr Id Id -> UniqFM Id -> UniqFM Id -> Unique -> StgCaseAlternatives Id Id -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _S_ "SLLLL" _N_ _N_ #-}
saveVolatileVarsAndRegs :: UniqFM Id -> CgInfoDownwards -> CgState -> ((AbstractC, EndOfBlockInfo, Labda Int), CgState)
- {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _N_ _N_ _N_ #-}
-- Perform the operation
getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
- profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM") IntKind] `thenC`
-
absC (COpStmt result_amodes op
arg_amodes -- note: no liveness arg
liveness_mask vol_regs) `thenC`
- profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM_STOP") IntKind] `thenC`
-
-- Scrutinise the result
cgInlineAlts NoGC uniq alts
| otherwise -- *Can* trigger GC
- = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
+ = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
+--NO: getIntSwitchChkrC `thenFC` \ isw_chkr ->
-- Get amodes for the arguments and results, and assign to regs
-- (Can-trigger-gc primops guarantee to have their (nonRobust)
-- args in regs)
let
- op_result_regs = assignPrimOpResultRegs op
+ op_result_regs = assignPrimOpResultRegs {-NO:isw_chkr-} op
op_result_amodes = map CReg op_result_regs
(op_arg_amodes, liveness_mask, arg_assts)
- = makePrimOpArgsRobust op arg_amodes
+ = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
liveness_arg = mkIntCLit liveness_mask
in
-- do_op_and_continue will be passed an amode for the continuation
do_op_and_continue sequel
- = profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM") IntKind] `thenC`
-
- absC (COpStmt op_result_amodes
+ = absC (COpStmt op_result_amodes
op
(pin_liveness op liveness_arg op_arg_amodes)
liveness_mask
[{-no vol_regs-}])
`thenC`
- profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM_STOP") IntKind] `thenC`
-
sequelToAmode sequel `thenFC` \ dest_amode ->
absC (CReturn dest_amode DirectReturn)
cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
= -- Generate the instruction to restore cost centre, if any
restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
+ getIntSwitchChkrC `thenFC` \ isw_chkr ->
-- Generate sequel info for use downstream
-- At the moment, we only do it if the type is vector-returnable.
= if not use_labelled_alts then
Nothing -- no semi-tagging info
else
- cgSemiTaggedAlts uniq alts deflt -- Just <something>
+ cgSemiTaggedAlts isw_chkr uniq alts deflt -- Just <something>
in
cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt
`thenFC` \ (tagged_alt_absCs, deflt_absC) ->
\begin{code}
cgAlgAlts gc_flag uniq restore_cc semi_tagging
ty alts deflt@(StgBindDefault binder True{-used-} _)
- = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging) alts)
+ = getIntSwitchChkrC `thenFC` \ isw_chkr ->
+ let
+ extra_branches :: [FCode (ConTag, AbstractC)]
+ extra_branches = catMaybes (map (mk_extra_branch isw_chkr) default_cons)
+
+ must_label_default = semi_tagging || not (null extra_branches)
+ in
+ forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging) alts)
extra_branches
(cgAlgDefault gc_flag uniq restore_cc must_label_default deflt)
where
- extra_branches :: [FCode (ConTag, AbstractC)]
- extra_branches = catMaybes (map mk_extra_branch default_cons)
-
- must_label_default = semi_tagging || not (null extra_branches)
default_join_lbl = mkDefaultLabel uniq
jump_instruction = CJump (CLbl default_join_lbl CodePtrKind)
-- nothing to do. Otherwise, we have a special case for a nullary constructor,
-- but in the general case we do an allocation and heap-check.
- mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
+ mk_extra_branch :: IntSwitchChecker -> DataCon -> (Maybe (FCode (ConTag, AbstractC)))
- mk_extra_branch con
+ mk_extra_branch isw_chkr con
= ASSERT(isDataCon con)
- case dataReturnConvAlg con of
+ case dataReturnConvAlg isw_chkr con of
ReturnInHeap -> Nothing
ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
returnFC (tag, abs_c)
cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> PlainStgExpr -> Code
cgAlgAltRhs gc_flag con args use_mask rhs
- = let
+ = getIntSwitchChkrC `thenFC` \ isw_chkr ->
+ let
(live_regs, node_reqd)
- = case (dataReturnConvAlg con) of
+ = case (dataReturnConvAlg isw_chkr con) of
ReturnInHeap -> ([], True)
ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False)
-- Pick the live registers using the use_mask
algebraic case alternatives for semi-tagging.
\begin{code}
-cgSemiTaggedAlts :: Unique
+cgSemiTaggedAlts :: IntSwitchChecker
+ -> Unique
-> [(Id, [Id], [Bool], PlainStgExpr)]
-> StgCaseDefault Id Id
-> SemiTaggingStuff
-cgSemiTaggedAlts uniq alts deflt
- = Just (map st_alt alts, st_deflt deflt)
+cgSemiTaggedAlts isw_chkr uniq alts deflt
+ = Just (map (st_alt isw_chkr) alts, st_deflt deflt)
where
st_deflt StgNoDefault = Nothing
mkDefaultLabel uniq)
)
- st_alt (con, args, use_mask, _)
- = case (dataReturnConvAlg con) of
+ st_alt isw_chkr (con, args, use_mask, _)
+ = case (dataReturnConvAlg isw_chkr con) of
ReturnInHeap ->
-- Ha! Nothing to do; Node already points to the thing
(con_tag,
- (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") [], -- ToDo: monadise?
+ (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
+ [mkIntCLit (length args)], -- how big the thing in the heap is
join_label)
)
in
(con_tag,
(mkAbstractCs [
- CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") [], -- ToDo: macroise?
+ CCallProfCtrMacro SLIT("RET_SEMI_IN_REGS") -- ToDo: macroise?
+ [mkIntCLit (length regs_w_offsets),
+ mkIntCLit (length used_regs_w_offsets)],
CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
join_label))
where
move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
move_to_reg (reg, offset)
= CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
-
\end{code}
%************************************************************************
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface CgClosure where
import AbsCSyn(AbstractC)
-import CgBindery(CgIdInfo, StableLoc, VolatileLoc)
+import CgBindery(CgIdInfo)
import CgMonad(CgInfoDownwards, CgState, CompilationInfo, EndOfBlockInfo, StubFlag)
import ClosureInfo(LambdaFormInfo)
import CmdLineOpts(GlobalSwitch)
import CostCentre(CostCentre)
import HeapOffs(HeapOffset)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Maybes(Labda)
import PreludePS(_PackedString)
import PrimOps(PrimOp)
import UniType(UniType)
import UniqFM(UniqFM)
import Unique(Unique)
-data CgIdInfo {-# GHC_PRAGMA MkCgIdInfo Id VolatileLoc StableLoc LambdaFormInfo #-}
-data CgInfoDownwards {-# GHC_PRAGMA MkCgInfoDown CompilationInfo (UniqFM CgIdInfo) EndOfBlockInfo #-}
-data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-}
-data CompilationInfo {-# GHC_PRAGMA MkCompInfo (GlobalSwitch -> Bool) _PackedString #-}
+data CgIdInfo
+data CgInfoDownwards
+data CgState
+data CompilationInfo
data HeapOffset
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-}
-data UpdateFlag {-# GHC_PRAGMA ReEntrant | Updatable | SingleEntry #-}
+data Id
+data Labda a
+data StgExpr a b
+data UpdateFlag
cgRhsClosure :: Id -> CostCentre -> StgBinderInfo -> [Id] -> [Id] -> StgExpr Id Id -> LambdaFormInfo -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState)
- {-# GHC_PRAGMA _A_ 7 _U_ 222222222 _N_ _S_ "LLLLLLS" _N_ _N_ #-}
cgTopRhsClosure :: Id -> CostCentre -> StgBinderInfo -> [Id] -> StgExpr Id Id -> LambdaFormInfo -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState)
- {-# GHC_PRAGMA _A_ 6 _U_ 22222222 _N_ _N_ _N_ _N_ #-}
pprPanic "closureCodeBody:thunk:prim type!" (ppr PprDebug tycon)
else
#endif
- getAbsC body_code `thenFC` \ body_absC ->
-#ifndef DPH
- moduleName `thenFC` \ mod_name ->
- absC (CClosureInfoAndCode closure_info body_absC Nothing stdUpd (cl_descr mod_name))
-#else
- -- Applying a similar scheme to Simon's placing info tables before code...
- -- ToDo:DPH: update
- absC (CNativeInfoTableAndCode closure_info
- closure_description
- (CCodeBlock entry_label body_absC))
-#endif {- Data Parallel Haskell -}
+ getAbsC body_code `thenFC` \ body_absC ->
+ moduleName `thenFC` \ mod_name ->
+ getIntSwitchChkrC `thenFC` \ isw_chkr ->
+
+ absC (CClosureInfoAndCode closure_info body_absC Nothing
+ stdUpd (cl_descr mod_name)
+ (dataConLiveness isw_chkr closure_info))
where
cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
-- Do the business
funWrapper closure_info arg_regs (cgExpr body)
in
-#ifndef DPH
-- Make a labelled code-block for the slow and fast entry code
forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
- `thenFC` \ slow_abs_c ->
- forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
- moduleName `thenFC` \ mod_name ->
+ `thenFC` \ slow_abs_c ->
+ forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
+ moduleName `thenFC` \ mod_name ->
+ getIntSwitchChkrC `thenFC` \ isw_chkr ->
+
-- Now either construct the info table, or put the fast code in alone
-- (We never have slow code without an info table)
absC (
- if info_table_needed
- then
- CClosureInfoAndCode closure_info slow_abs_c
- (Just fast_abs_c) stdUpd (cl_descr mod_name)
+ if info_table_needed then
+ CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
+ stdUpd (cl_descr mod_name)
+ (dataConLiveness isw_chkr closure_info)
else
CCodeBlock fast_label fast_abs_c
)
-
- where
-#else
- -- The info table goes before the slow entry point.
- forkAbsC slow_entry_code `thenFC` \ slow_abs_c ->
- forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
- moduleName `thenFC` \ mod_name ->
- absC (CNativeInfoTableAndCode
- closure_info
- (closureDescription mod_name id all_args body)
- (CCodeBlock slow_label
- (AbsCStmts slow_abs_c
- (CCodeBlock fast_label
- fast_abs_c))))
where
- slow_label = if slow_code_needed then
- mkStdEntryLabel id
- else
- mkErrorStdEntryLabel
- -- We may need a pointer to stuff in the info table,
- -- but if the slow entry code isn't needed, this code
- -- will never be entered, so we can use a standard
- -- panic routine.
-
-#endif {- Data Parallel Haskell -}
-
lf_info = closureLFInfo closure_info
cl_descr mod_name = closureDescription mod_name id all_args body
setupUpdate closure_info code
= if (closureUpdReqd closure_info) then
- link_caf_if_needed `thenFC` \ update_closure ->
- pushUpdateFrame update_closure vector code
+ link_caf_if_needed `thenFC` \ update_closure ->
+ getIntSwitchChkrC `thenFC` \ isw_chkr ->
+ pushUpdateFrame update_closure (vector isw_chkr) code
else
-- Non-updatable thunks still need a resume-cost-centre "update"
-- frame to be pushed if we are doing evaluation profiling.
closure_label = mkClosureLabel (closureId closure_info)
- vector = case (closureType closure_info) of
+ vector isw_chkr
+ = case (closureType closure_info) of
Nothing -> CReg StdUpdRetVecReg
Just (spec_tycon, _, spec_datacons) ->
- case ctrlReturnConvAlg spec_tycon of
+ case (ctrlReturnConvAlg spec_tycon) of
UnvectoredReturn 1 ->
let
spec_data_con = head spec_datacons
only_tag = getDataConTag spec_data_con
- direct = case dataReturnConvAlg spec_data_con of
+
+ direct = case (dataReturnConvAlg isw_chkr spec_data_con) of
ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
ReturnInHeap -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
+
vectored = mkStdUpdVecTblLabel spec_tycon
in
CUnVecLbl direct vectored
interface CgCompInfo where
import AbsCSyn(RegRelative)
import HeapOffs(HeapOffset)
-data RegRelative {-# GHC_PRAGMA HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset #-}
+data RegRelative
cON_UF_SIZE :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [2#] _N_ #-}
iND_TAG :: Integer
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
lIVENESS_R1 :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [1#] _N_ #-}
lIVENESS_R2 :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [2#] _N_ #-}
lIVENESS_R3 :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [4#] _N_ #-}
lIVENESS_R4 :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [8#] _N_ #-}
lIVENESS_R5 :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [16#] _N_ #-}
lIVENESS_R6 :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [32#] _N_ #-}
lIVENESS_R7 :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [64#] _N_ #-}
lIVENESS_R8 :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [128#] _N_ #-}
mAX_Double_REG :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [2#] _N_ #-}
mAX_FAMILY_SIZE_FOR_VEC_RETURNS :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [8#] _N_ #-}
mAX_Float_REG :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [4#] _N_ #-}
mAX_INTLIKE :: Integer
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _#_ int2Integer# [] [16#] _N_ #-}
mAX_SPEC_ALL_NONPTRS :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [5#] _N_ #-}
mAX_SPEC_ALL_PTRS :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [12#] _N_ #-}
mAX_SPEC_MIXED_FIELDS :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [3#] _N_ #-}
mAX_SPEC_SELECTEE_SIZE :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [12#] _N_ #-}
mAX_Vanilla_REG :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [8#] _N_ #-}
mIN_BIG_TUPLE_SIZE :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [16#] _N_ #-}
mIN_INTLIKE :: Integer
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mIN_MP_INT_SIZE :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [16#] _N_ #-}
mIN_SIZE_NonUpdHeapObject :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [1#] _N_ #-}
mIN_SIZE_NonUpdStaticHeapObject :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [0#] _N_ #-}
mIN_UPD_SIZE :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [2#] _N_ #-}
mP_STRUCT_SIZE :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [3#] _N_ #-}
oTHER_TAG :: Integer
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
sCC_CON_UF_SIZE :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [3#] _N_ #-}
sCC_STD_UF_SIZE :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [5#] _N_ #-}
sTD_UF_SIZE :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [4#] _N_ #-}
spARelToInt :: RegRelative -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
spBRelToInt :: RegRelative -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
uF_COST_CENTRE :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [4#] _N_ #-}
uF_RET :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [0#] _N_ #-}
uF_SUA :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [2#] _N_ #-}
uF_SUB :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [1#] _N_ #-}
uF_UPDATEE :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [3#] _N_ #-}
uNFOLDING_CHEAP_OP_COST :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [1#] _N_ #-}
uNFOLDING_CON_DISCOUNT_WEIGHT :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [1#] _N_ #-}
uNFOLDING_CREATION_THRESHOLD :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [30#] _N_ #-}
uNFOLDING_DEAR_OP_COST :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [4#] _N_ #-}
uNFOLDING_NOREP_LIT_COST :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [4#] _N_ #-}
uNFOLDING_OVERRIDE_THRESHOLD :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [8#] _N_ #-}
uNFOLDING_USE_THRESHOLD :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [3#] _N_ #-}
constructors will start at 0 and go up.
\begin{code}
oTHER_TAG = (INFO_OTHER_TAG :: Integer) -- (-1) unevaluated, probably
-iND_TAG = (INFO_IND_TAG :: Integer) -- (-1) NOT USED, REALLY
+iND_TAG = (INFO_IND_TAG :: Integer) -- (-2) NOT USED, REALLY
\end{code}
Stuff for liveness masks:
import CgMonad(CgInfoDownwards, CgState, StubFlag)
import CostCentre(CostCentre)
import HeapOffs(HeapOffset)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import PreludePS(_PackedString)
import PrimKind(PrimKind)
import PrimOps(PrimOp)
import StgSyn(StgAtom)
-import UniType(UniType)
import UniqFM(UniqFM)
import Unique(Unique)
-data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-}
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
-data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
-data StgAtom a {-# GHC_PRAGMA StgVarAtom a | StgLitAtom BasicLit #-}
+data CAddrMode
+data MagicId
+data CgState
+data Id
+data PrimKind
+data PrimOp
+data StgAtom a
bindConArgs :: Id -> [Id] -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 2 _U_ 1222 _N_ _S_ "U(LLLS)L" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
buildDynCon :: Id -> CostCentre -> Id -> [CAddrMode] -> Bool -> CgInfoDownwards -> CgState -> (CgIdInfo, CgState)
- {-# GHC_PRAGMA _A_ 5 _U_ 2222122 _N_ _S_ "LLLLE" _N_ _N_ #-}
cgReturnDataCon :: Id -> [CAddrMode] -> Bool -> UniqFM Id -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _S_ "LLLLU(LLU(LLS))L" _N_ _N_ #-}
cgTopRhsCon :: Id -> Id -> [StgAtom Id] -> Bool -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState)
- {-# GHC_PRAGMA _A_ 4 _U_ 222022 _N_ _S_ "LLSA" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
bindConArgs :: DataCon -> [Id] -> Code
bindConArgs con args
= ASSERT(isDataCon con)
- case (dataReturnConvAlg con) of
+ getIntSwitchChkrC `thenFC` \ isw_chkr ->
+
+ case (dataReturnConvAlg isw_chkr con) of
ReturnInRegs rs -> bindArgsToRegs args rs
ReturnInHeap ->
let
cgReturnDataCon con amodes all_zero_size_args live_vars
= ASSERT(isDataCon con)
- getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
+ getIntSwitchChkrC `thenFC` \ isw_chkr ->
+ getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
case sequel of
-- Ignore the sequel: we've already looked at it above
other_sequel -> -- The usual case
- case dataReturnConvAlg con of
+ case (dataReturnConvAlg isw_chkr con) of
ReturnInHeap ->
-- BUILD THE OBJECT IN THE HEAP
in
-- RETURN
- profCtrC SLIT("RET_NEW_IN_HEAP") [] `thenC`
+ profCtrC SLIT("RET_NEW_IN_HEAP") [mkIntCLit (length amodes)] `thenC`
performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars
ReturnInRegs regs ->
- let reg_assts = mkAbstractCs (zipWith move_to_reg amodes regs)
+ let
+ reg_assts = mkAbstractCs (zipWith move_to_reg amodes regs)
info_lbl = mkPhantomInfoTableLabel con
in
---OLD:WDP:94/06 evalCostCentreC "SET_RetCC" [CReg CurCostCentre] `thenC`
- profCtrC SLIT("RET_NEW_IN_REGS") [] `thenC`
+ profCtrC SLIT("RET_NEW_IN_REGS") [mkIntCLit (length amodes)] `thenC`
performReturn reg_assts (mkStaticAlgReturnCode con (Just info_lbl)) live_vars
where
import TyCon(TyCon)
import UniType(UniType)
import UniqFM(UniqFM)
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
-data CompilationInfo {-# GHC_PRAGMA MkCompInfo (GlobalSwitch -> Bool) _PackedString #-}
+data AbstractC
+data CompilationInfo
type TCE = UniqFM TyCon
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data UniqFM a
genStaticConBits :: CompilationInfo -> [TyCon] -> FiniteMap TyCon [[Labda UniType]] -> AbstractC
- {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _N_ _N_ _N_ #-}
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
import CgUsages ( getHpRelOffset )
import CLabelInfo ( mkConEntryLabel, mkStaticConEntryLabel,
- mkInfoTableLabel,
+ --UNUSED: mkInfoTableLabel,
mkClosureLabel, --UNUSED: mkConUpdCodePtrUnvecLabel,
mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel,
mkStdUpdVecTblLabel, CLabel
import ClosureInfo ( layOutStaticClosure, layOutDynCon,
closureSizeWithoutFixedHdr, closurePtrsSize,
fitsMinUpdSize, mkConLFInfo, layOutPhantomClosure,
- infoTableLabelFromCI
+ infoTableLabelFromCI, dataConLiveness
)
import CmdLineOpts ( GlobalSwitch(..) )
import FiniteMap
(map (mk_upd_label spec_tycon) spec_data_cons)
------------------
mk_upd_label tycon con
- = case dataReturnConvAlg con of
- ReturnInRegs _ -> CLbl (mkConUpdCodePtrVecLabel tycon tag) CodePtrKind
- ReturnInHeap -> CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrKind
+ = CLbl
+ (case (dataReturnConvAlg isw_chkr con) of
+ ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
+ ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag)
+ CodePtrKind
where
tag = getDataConTag con
------------------
- (MkCompInfo sw_chkr _) = comp_info
+ (MkCompInfo sw_chkr isw_chkr _) = comp_info
\end{code}
%************************************************************************
\begin{code}
genConInfo :: CompilationInfo -> TyCon -> Id -> AbstractC
-genConInfo comp_info tycon data_con
+genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
= mkAbstractCs [
-#ifndef DPH
CSplitMarker,
inregs_upd_maybe,
closure_code,
static_code,
-#else
- info_table,
- CSplitMarker,
- static_info_table,
-#endif {- Data Parallel Haskell -}
closure_maybe]
-- Order of things is to reduce forward references
where
- (closure_info, body_code) = mkConCodeAndInfo data_con
+ (closure_info, body_code) = mkConCodeAndInfo isw_chkr data_con
-- To allow the debuggers, interpreters, etc to cope with static
-- data structures (ie those built at compile time), we take care that
entry_addr = CLbl entry_label CodePtrKind
con_descr = _UNPK_ (getOccurrenceName data_con)
-#ifndef DPH
- closure_code = CClosureInfoAndCode closure_info body Nothing stdUpd con_descr
- static_code = CClosureInfoAndCode static_ci body Nothing stdUpd con_descr
+ closure_code = CClosureInfoAndCode closure_info body Nothing
+ stdUpd con_descr
+ (dataConLiveness isw_chkr closure_info)
+ static_code = CClosureInfoAndCode static_ci body Nothing
+ stdUpd con_descr
+ (dataConLiveness isw_chkr static_ci)
inregs_upd_maybe = genPhantomUpdInfo comp_info tycon data_con
tag = getDataConTag data_con
-#else
- info_table
- = CNativeInfoTableAndCode closure_info con_descr entry_code
- static_info_table
- = CNativeInfoTableAndCode static_ci con_descr (CJump entry_addr)
-#endif {- Data Parallel Haskell -}
-
cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs
-- For zero-arity data constructors, or, more accurately,
\end{code}
\begin{code}
-mkConCodeAndInfo :: Id -- Data constructor
+mkConCodeAndInfo :: IntSwitchChecker
+ -> Id -- Data constructor
-> (ClosureInfo, Code) -- The info table
-mkConCodeAndInfo con
- = case (dataReturnConvAlg con) of
+mkConCodeAndInfo isw_chkr con
+ = case (dataReturnConvAlg isw_chkr con) of
ReturnInRegs regs ->
let
= layOutDynCon con kindFromMagicId regs
body_code
- = -- OLD: We don't set CC when entering data any more (WDP 94/06)
- -- lexCostCentreC "ENTER_CC_DCL" [CReg node] `thenC`
- -- evalCostCentreC "SET_RetCC_CL" [CReg node] `thenC`
- profCtrC SLIT("RET_OLD_IN_REGS") [] `thenC`
+ = profCtrC SLIT("RET_OLD_IN_REGS") [mkIntCLit (length regs_w_offsets)] `thenC`
performReturn (mkAbstractCs (map move_to_reg regs_w_offsets))
(mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
let
(_, _, arg_tys, _) = getDataConSig con
- (closure_info, _)
+ (closure_info, arg_things)
= layOutDynCon con kindFromType arg_tys
body_code
= -- OLD: We don't set CC when entering data any more (WDP 94/06)
-- lexCostCentreC "ENTER_CC_DCL" [CReg node] `thenC`
- profCtrC SLIT("RET_OLD_IN_HEAP") [] `thenC`
+ profCtrC SLIT("RET_OLD_IN_HEAP") [mkIntCLit (length arg_things)] `thenC`
performReturn AbsCNop -- Ptr to thing already in Node
(mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
\begin{code}
genPhantomUpdInfo :: CompilationInfo -> TyCon -> Id{-data con-} -> AbstractC
-genPhantomUpdInfo comp_info tycon data_con
- = case dataReturnConvAlg data_con of
- ReturnInHeap -> AbsCNop -- No need for a phantom update
+genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
+ = case (dataReturnConvAlg isw_chkr data_con) of
+
+ ReturnInHeap -> --OLD: pprTrace "NoPhantom: " (ppr PprDebug data_con) $
+ AbsCNop -- No need for a phantom update
ReturnInRegs regs ->
+ --OLD: pprTrace "YesPhantom! " (ppr PprDebug data_con) $
+ let
+ phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing
+ upd_code con_descr
+ (dataConLiveness isw_chkr phantom_ci)
- let
- phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing upd_code con_descr
phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
con_descr = _UNPK_ (getOccurrenceName data_con)
-- Code for building a new constructor in place over the updatee
- overwrite_code = profCtrC SLIT("UPD_CON_IN_PLACE") [] `thenC`
+ overwrite_code
+ = profCtrC SLIT("UPD_CON_IN_PLACE")
+ [mkIntCLit (length regs_w_offsets)] `thenC`
absC (mkAbstractCs
[
CAssign (CReg node) updatee,
else UPD_INPLACE_PTRS
-- Code for allocating a new constructor in the heap
- alloc_code =
- let amodes_w_offsets = [ (CReg r, o) | (r,o) <- regs_w_offsets ]
+ alloc_code
+ = let
+ amodes_w_offsets = [ (CReg r, o) | (r,o) <- regs_w_offsets ]
in
-- Allocate and build closure specifying upd_new_w_regs
allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
let
amode = CAddr hp_rel
in
- profCtrC SLIT("UPD_CON_IN_NEW") [] `thenC`
- absC (mkAbstractCs
- [
- CMacroStmt UPD_IND [updatee, amode],
- CAssign (CReg node) amode,
- CAssign (CReg infoptr) (CLbl info_label DataPtrKind)
- ])
+ profCtrC SLIT("UPD_CON_IN_NEW")
+ [mkIntCLit (length amodes_w_offsets)] `thenC`
+ absC (mkAbstractCs
+ [ CMacroStmt UPD_IND [updatee, amode],
+ CAssign (CReg node) amode,
+ CAssign (CReg infoptr) (CLbl info_label DataPtrKind)
+ ])
(closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs
info_label = infoTableLabelFromCI closure_info
import CgMonad(CgInfoDownwards, CgState, StubFlag)
import CostCentre(CostCentre)
import HeapOffs(HeapOffset)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import PrimOps(PrimOp)
import StgSyn(StgAtom, StgBinding, StgCaseAlternatives, StgExpr)
import UniType(UniType)
import UniqFM(UniqFM)
import Unique(Unique)
-data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-}
+data CgState
+data Id
+data StgExpr a b
cgExpr :: StgExpr Id Id -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-}
cgSccExpr :: StgExpr Id Id -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-}
getPrimOpArgAmodes :: PrimOp -> [StgAtom Id] -> CgInfoDownwards -> CgState -> ([CAddrMode], CgState)
- {-# GHC_PRAGMA _A_ 2 _U_ 1222 _N_ _S_ "SL" _N_ _N_ #-}
\begin{code}
cgExpr x@(StgPrimApp op args live_vars)
- = -- trace ("cgExpr:PrimApp:"++(ppShow 80 (ppr PprDebug x))) (
- getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
+ = getIntSwitchChkrC `thenFC` \ isw_chkr ->
+ getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
let
- result_regs = assignPrimOpResultRegs op
+ result_regs = assignPrimOpResultRegs {-NO:isw_chkr-} op
result_amodes = map CReg result_regs
may_gc = primOpCanTriggerGC op
dyn_tag = head result_amodes
-- (Can-trigger-gc primops guarantee to have their args in regs)
let
(arg_robust_amodes, liveness_mask, arg_assts)
- = makePrimOpArgsRobust op arg_amodes
+ = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
liveness_arg = mkIntCLit liveness_mask
in
returnFC (
arg_assts,
- mkAbstractCs [
- spat_prim_macro,
- COpStmt result_amodes op
- (pin_liveness op liveness_arg arg_robust_amodes)
- liveness_mask
- [{-no vol_regs-}],
- spat_prim_stop_macro ]
+ COpStmt result_amodes op
+ (pin_liveness op liveness_arg arg_robust_amodes)
+ liveness_mask
+ [{-no vol_regs-}]
)
else
-- Use args from their current amodes.
liveness_mask = panic "cgExpr: liveness of non-GC-ing primop touched\n"
in
returnFC (
--- DO NOT want CCallProfMacros in CSimultaneous stuff. Yurgh. (WDP 95/01)
--- Arises in compiling PreludeGlaST (and elsewhere??)
--- mkAbstractCs [
--- spat_prim_macro,
COpStmt result_amodes op arg_amodes liveness_mask [{-no vol_regs-}],
--- spat_prim_stop_macro ],
- AbsCNop
+ AbsCNop
)
) `thenFC` \ (do_before_stack_cleanup,
do_just_before_jump) ->
ReturnsAlg tycon ->
--OLD: evalCostCentreC "SET_RetCC" [CReg CurCostCentre] `thenC`
- profCtrC SLIT("RET_NEW_IN_REGS") [] `thenC`
+ profCtrC SLIT("RET_NEW_IN_REGS") [num_of_fields] `thenC`
performReturn do_before_stack_cleanup
(\ sequel -> robustifySequel may_gc sequel
dyn_tag DataPtrKind
data_con = head (getTyConDataCons tycon)
- dir_lbl = case dataReturnConvAlg data_con of
- ReturnInRegs _ -> CLbl (mkPhantomInfoTableLabel data_con)
- DataPtrKind
- ReturnInHeap -> panic "CgExpr: can't return prim in heap"
- -- Never used, and no point in generating
- -- the code for it!
+
+ (dir_lbl, num_of_fields)
+ = case (dataReturnConvAlg fake_isw_chkr data_con) of
+ ReturnInRegs rs
+ -> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrKind,
+--OLD: pprTrace "CgExpr:prim datacon:" (ppr PprDebug data_con) $
+ mkIntCLit (length rs)) -- for ticky-ticky only
+
+ ReturnInHeap
+ -> pprPanic "CgExpr: can't return prim in heap:" (ppr PprDebug data_con)
+ -- Never used, and no point in generating
+ -- the code for it!
+
+ fake_isw_chkr x = Nothing
where
-- for all PrimOps except ccalls, we pin the liveness info
-- on as the first "argument"
sequelToAmode sequel `thenFC` \ amode ->
returnFC (CAssign (CReg RetReg) amode, InRetReg)
robustifySequel _ sequel = returnFC (AbsCNop, sequel)
-
- spat_prim_macro = CCallProfCtrMacro SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM") IntKind]
- spat_prim_stop_macro = CCallProfCtrMacro SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_PRIM_STOP") IntKind]
-
\end{code}
%********************************************************
import CLabelInfo(CLabel)
import CgBindery(CgIdInfo)
import CgMonad(CgInfoDownwards, CgState, StubFlag)
-import ClosureInfo(ClosureInfo, LambdaFormInfo)
+import ClosureInfo(ClosureInfo)
import CostCentre(CostCentre)
import HeapOffs(HeapOffset)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Maybes(Labda)
import PreludePS(_PackedString)
import PrimKind(PrimKind)
import PrimOps(PrimOp)
-import SMRep(SMRep)
-import UniType(UniType)
import UniqFM(UniqFM)
import Unique(Unique)
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
-data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-}
-data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-}
-data ClosureInfo {-# GHC_PRAGMA MkClosureInfo Id LambdaFormInfo SMRep #-}
+data AbstractC
+data CAddrMode
+data CgState
+data ClosureInfo
data HeapOffset
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
allocDynClosure :: ClosureInfo -> CAddrMode -> CAddrMode -> [(CAddrMode, HeapOffset)] -> CgInfoDownwards -> CgState -> (HeapOffset, CgState)
- {-# GHC_PRAGMA _A_ 4 _U_ 222111 _N_ _N_ _N_ _N_ #-}
allocHeap :: HeapOffset -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LLU(LLU(LLU(LL)))" {_A_ 5 _U_ 21222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
heapCheck :: [MagicId] -> Bool -> (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 5 _U_ 22221 _N_ _S_ "LLLLU(LLU(LLL))" _N_ _N_ #-}
import StgSyn(StgBinderInfo, StgExpr)
import UniqFM(UniqFM)
cgLetNoEscapeClosure :: Id -> CostCentre -> StgBinderInfo -> UniqFM Id -> EndOfBlockInfo -> Labda Int -> [Id] -> StgExpr Id Id -> CgInfoDownwards -> CgState -> ((Id, CgIdInfo), CgState)
- {-# GHC_PRAGMA _A_ 8 _U_ 2002202212 _N_ _S_ "LAALLALL" {_A_ 5 _U_ 2222212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import CgRetConv ( assignRegs )
import CgStackery ( mkVirtStkOffsets )
import CgUsages ( setRealAndVirtualSps, getVirtSps )
-import CLabelInfo ( mkFastEntryLabel )
+import CLabelInfo ( mkStdEntryLabel )
import ClosureInfo ( mkLFLetNoEscape )
import Id ( getIdKind )
import Util
(forkAbsC (cgLetNoEscapeBody args body))
`thenFC` \ (vA, vB, code) ->
let
- label = mkFastEntryLabel binder arity
+ label = mkStdEntryLabel binder -- arity
in
absC (CCodeBlock label code) `thenC`
returnFC (binder, letNoEscapeIdInfo binder vA vB lf_info)
-> Code
cgLetNoEscapeBody all_args rhs
- = getVirtSps `thenFC` \ (vA, vB) ->
+ = getVirtSps `thenFC` \ (vA, vB) ->
+ getIntSwitchChkrC `thenFC` \ isw_chkr ->
let
arg_kinds = map getIdKind all_args
- (arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds
+ (arg_regs, _) = assignRegs isw_chkr [{-nothing live-}] arg_kinds
stk_args = drop (length arg_regs) all_args
-- stk_args is the args which are passed on the stack at the fast-entry point
import BasicLit(BasicLit)
import CLabelInfo(CLabel)
import CgBindery(CgBindings(..), CgIdInfo, StableLoc, VolatileLoc, heapIdInfo, stableAmodeIdInfo)
-import ClosureInfo(ClosureInfo, LambdaFormInfo, StandardFormInfo)
+import ClosureInfo(ClosureInfo, LambdaFormInfo)
import CmdLineOpts(GlobalSwitch)
-import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC)
+import CostCentre(CostCentre, IsCafCC)
import HeapOffs(HeapOffset, VirtualHeapOffset(..), VirtualSpAOffset(..), VirtualSpBOffset(..))
-import Id(DataCon(..), Id, IdDetails)
+import Id(DataCon(..), Id)
import IdEnv(IdEnv(..))
-import IdInfo(IdInfo)
import Maybes(Labda)
import Outputable(NamedThing, Outputable)
import PreludePS(_PackedString)
import PrimKind(PrimKind)
import PrimOps(PrimOp)
import StgSyn(PlainStgLiveVars(..))
-import UniType(UniType)
import UniqFM(UniqFM)
import UniqSet(UniqSet(..))
import Unique(Unique)
infixr 9 `thenC`
infixr 9 `thenFC`
type AStackUsage = (Int, [(Int, StubFlag)], Int, Int)
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
+data AbstractC
type BStackUsage = (Int, [Int], Int, Int)
-data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-}
+data CAddrMode
data CLabel
type CgBindings = UniqFM CgIdInfo
-data CgIdInfo {-# GHC_PRAGMA MkCgIdInfo Id VolatileLoc StableLoc LambdaFormInfo #-}
+data CgIdInfo
data CgInfoDownwards = MkCgInfoDown CompilationInfo (UniqFM CgIdInfo) EndOfBlockInfo
data CgState = MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset))
type Code = CgInfoDownwards -> CgState -> CgState
-data CompilationInfo = MkCompInfo (GlobalSwitch -> Bool) _PackedString
-data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-}
+data CompilationInfo = MkCompInfo (GlobalSwitch -> Bool) ((Int -> GlobalSwitch) -> Labda Int) _PackedString
+data CostCentre
data EndOfBlockInfo = EndOfBlockInfo Int Int Sequel
type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
+data GlobalSwitch
data HeapOffset
type HeapUsage = (HeapOffset, HeapOffset)
-data LambdaFormInfo {-# GHC_PRAGMA LFReEntrant Bool Int Bool | LFCon Id Bool | LFTuple Id Bool | LFThunk Bool Bool Bool StandardFormInfo | LFArgument | LFImported | LFLetNoEscape Int (UniqFM Id) | LFBlackHole | LFIndirection #-}
-data IsCafCC {-# GHC_PRAGMA IsCafCC | IsNotCafCC #-}
+type IntSwitchChecker = (Int -> GlobalSwitch) -> Labda Int
+data LambdaFormInfo
+data IsCafCC
type SemiTaggingStuff = Labda ([(Int, (AbstractC, CLabel))], Labda (Labda Id, (AbstractC, CLabel)))
data Sequel = InRetReg | OnStack Int | UpdateCode CAddrMode | CaseAlts CAddrMode (Labda ([(Int, (AbstractC, CLabel))], Labda (Labda Id, (AbstractC, CLabel))))
-data StubFlag {-# GHC_PRAGMA Stubbed | NotStubbed #-}
+data StubFlag
type VirtualHeapOffset = HeapOffset
type VirtualSpAOffset = Int
type VirtualSpBOffset = Int
type DataCon = Id
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
type IdEnv a = UniqFM a
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
+data Labda a
type PlainStgLiveVars = UniqFM Id
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data UniqFM a
type UniqSet a = UniqFM a
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Unique
absC :: AbstractC -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
addBindC :: Id -> CgIdInfo -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 4 _U_ 1201 _N_ _S_ "LLAU(LLL)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
addBindsC :: [(Id, CgIdInfo)] -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 101 _N_ _S_ "LAU(LLL)" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
addFreeBSlots :: [Int] -> [Int] -> [Int]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
costCentresC :: _PackedString -> [CAddrMode] -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 4 _U_ 2211 _N_ _S_ "LLU(U(SA)AA)U(LLL)" {_A_ 4 _U_ 2211 _N_ _N_ _N_ _N_} _N_ _N_ #-}
costCentresFlag :: CgInfoDownwards -> CgState -> (Bool, CgState)
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(U(LA)AA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
fixC :: (a -> CgInfoDownwards -> CgState -> (a, CgState)) -> CgInfoDownwards -> CgState -> (a, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLL" _N_ _N_ #-}
forkAbsC :: (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> (AbstractC, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "LLU(LLL)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
forkAlts :: [CgInfoDownwards -> CgState -> (a, CgState)] -> [CgInfoDownwards -> CgState -> (a, CgState)] -> (CgInfoDownwards -> CgState -> (b, CgState)) -> CgInfoDownwards -> CgState -> (([a], b), CgState)
- {-# GHC_PRAGMA _A_ 5 _U_ 11122 _N_ _N_ _N_ _N_ #-}
forkClosureBody :: (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(LLA)U(LLL)" {_A_ 4 _U_ 1221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
forkEval :: EndOfBlockInfo -> (CgInfoDownwards -> CgState -> CgState) -> (CgInfoDownwards -> CgState -> (Sequel, CgState)) -> CgInfoDownwards -> CgState -> (EndOfBlockInfo, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 21112 _N_ _N_ _N_ _N_ #-}
forkEvalHelp :: EndOfBlockInfo -> (CgInfoDownwards -> CgState -> CgState) -> (CgInfoDownwards -> CgState -> (a, CgState)) -> CgInfoDownwards -> CgState -> ((Int, Int, a), CgState)
- {-# GHC_PRAGMA _A_ 5 _U_ 21112 _N_ _S_ "LLLU(LLA)L" _N_ _N_ #-}
forkStatics :: (CgInfoDownwards -> CgState -> (a, CgState)) -> CgInfoDownwards -> CgState -> (a, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(LAA)U(LLL)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getAbsC :: (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> (AbstractC, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "LLU(LLL)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getEndOfBlockInfo :: CgInfoDownwards -> CgState -> (EndOfBlockInfo, CgState)
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAL)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: EndOfBlockInfo) (u1 :: CgState) -> _!_ _TUP_2 [EndOfBlockInfo, CgState] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: CgInfoDownwards) (u1 :: CgState) -> case u0 of { _ALG_ _ORIG_ CgMonad MkCgInfoDown (u2 :: CompilationInfo) (u3 :: UniqFM CgIdInfo) (u4 :: EndOfBlockInfo) -> _!_ _TUP_2 [EndOfBlockInfo, CgState] [u4, u1]; _NO_DEFLT_ } _N_ #-}
+getIntSwitchChkrC :: CgInfoDownwards -> CgState -> ((Int -> GlobalSwitch) -> Labda Int, CgState)
getUnstubbedAStackSlots :: Int -> CgInfoDownwards -> CgState -> ([Int], CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(U(LLLL)LL))" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
heapIdInfo :: Id -> HeapOffset -> LambdaFormInfo -> CgIdInfo
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
initC :: CompilationInfo -> (CgInfoDownwards -> CgState -> CgState) -> AbstractC
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
isStringSwitchSetC :: ([Char] -> GlobalSwitch) -> CgInfoDownwards -> CgState -> (Bool, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "LU(U(LA)AA)L" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isStubbed :: StubFlag -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: StubFlag) -> case u0 of { _ALG_ _ORIG_ CgMonad Stubbed -> _!_ True [] []; _ORIG_ CgMonad NotStubbed -> _!_ False [] []; _NO_DEFLT_ } _N_ #-}
isSwitchSetC :: GlobalSwitch -> CgInfoDownwards -> CgState -> (Bool, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LU(U(LA)AA)L" {_A_ 3 _U_ 212 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 6 \ (u0 :: GlobalSwitch) (u1 :: GlobalSwitch -> Bool) (u2 :: CgState) -> let {(u3 :: Bool) = _APP_ u1 [ u0 ]} in _!_ _TUP_2 [Bool, CgState] [u3, u2] _N_} _F_ _ALWAYS_ \ (u0 :: GlobalSwitch) (u1 :: CgInfoDownwards) (u2 :: CgState) -> case u1 of { _ALG_ _ORIG_ CgMonad MkCgInfoDown (u3 :: CompilationInfo) (u4 :: UniqFM CgIdInfo) (u5 :: EndOfBlockInfo) -> case u3 of { _ALG_ _ORIG_ CgMonad MkCompInfo (u6 :: GlobalSwitch -> Bool) (u7 :: _PackedString) -> let {(u8 :: Bool) = _APP_ u6 [ u0 ]} in _!_ _TUP_2 [Bool, CgState] [u8, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
listCs :: [CgInfoDownwards -> CgState -> CgState] -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-}
listFCs :: [CgInfoDownwards -> CgState -> (a, CgState)] -> CgInfoDownwards -> CgState -> ([a], CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-}
lookupBindC :: Id -> CgInfoDownwards -> CgState -> (CgIdInfo, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LU(ALA)U(LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mapCs :: (a -> CgInfoDownwards -> CgState -> CgState) -> [a] -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _S_ "LSLL" _N_ _N_ #-}
mapFCs :: (a -> CgInfoDownwards -> CgState -> (b, CgState)) -> [a] -> CgInfoDownwards -> CgState -> ([b], CgState)
- {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _S_ "LSLL" _N_ _N_ #-}
modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 4 _U_ 1201 _N_ _S_ "LLAU(LLL)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
moduleName :: CgInfoDownwards -> CgState -> (_PackedString, CgState)
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(U(AL)AA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: CgState) -> _!_ _TUP_2 [_PackedString, CgState] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CX 5 \ (u0 :: CgInfoDownwards) (u1 :: CgState) -> case u0 of { _ALG_ _ORIG_ CgMonad MkCgInfoDown (u2 :: CompilationInfo) (u3 :: UniqFM CgIdInfo) (u4 :: EndOfBlockInfo) -> case u2 of { _ALG_ _ORIG_ CgMonad MkCompInfo (u5 :: GlobalSwitch -> Bool) (u6 :: _PackedString) -> _!_ _TUP_2 [_PackedString, CgState] [u6, u1]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
noBlackHolingFlag :: CgInfoDownwards -> CgState -> (Bool, CgState)
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(U(LA)AA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
nopC :: CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 2 _U_ 01 _N_ _S_ "AU(LLL)" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: AbstractC) (u1 :: UniqFM CgIdInfo) (u2 :: ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset))) -> _!_ _ORIG_ CgMonad MkCgState [] [u0, u1, u2] _N_} _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: CgInfoDownwards) (u1 :: CgState) -> u1 _N_ #-}
nukeDeadBindings :: UniqFM Id -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(U(LLLL)U(LLLL)L))" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
profCtrC :: _PackedString -> [CAddrMode] -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 4 _U_ 2211 _N_ _S_ "LLU(U(SA)AA)U(LLL)" {_A_ 4 _U_ 2211 _N_ _N_ _N_ _N_} _N_ _N_ #-}
returnFC :: a -> CgInfoDownwards -> CgState -> (a, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: CgInfoDownwards) (u3 :: CgState) -> _!_ _TUP_2 [u0, CgState] [u1, u3] _N_ #-}
sequelToAmode :: Sequel -> CgInfoDownwards -> CgState -> (CAddrMode, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 102 _N_ _S_ "SAL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
setEndOfBlockInfo :: EndOfBlockInfo -> (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 4 _U_ 2112 _N_ _S_ "LSU(LLA)L" {_A_ 5 _U_ 21222 _N_ _N_ _F_ _IF_ARGS_ 0 5 XXXXX 8 \ (u0 :: EndOfBlockInfo) (u1 :: CgInfoDownwards -> CgState -> CgState) (u2 :: CompilationInfo) (u3 :: UniqFM CgIdInfo) (u4 :: CgState) -> let {(u5 :: CgInfoDownwards) = _!_ _ORIG_ CgMonad MkCgInfoDown [] [u2, u3, u0]} in _APP_ u1 [ u5, u4 ] _N_} _F_ _ALWAYS_ \ (u0 :: EndOfBlockInfo) (u1 :: CgInfoDownwards -> CgState -> CgState) (u2 :: CgInfoDownwards) (u3 :: CgState) -> case u2 of { _ALG_ _ORIG_ CgMonad MkCgInfoDown (u4 :: CompilationInfo) (u5 :: UniqFM CgIdInfo) (u6 :: EndOfBlockInfo) -> let {(u7 :: CgInfoDownwards) = _!_ _ORIG_ CgMonad MkCgInfoDown [] [u4, u5, u0]} in _APP_ u1 [ u7, u3 ]; _NO_DEFLT_ } _N_ #-}
stableAmodeIdInfo :: Id -> CAddrMode -> LambdaFormInfo -> CgIdInfo
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
thenC :: (CgInfoDownwards -> CgState -> CgState) -> (CgInfoDownwards -> CgState -> a) -> CgInfoDownwards -> CgState -> a
- {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "LSLL" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: CgInfoDownwards -> CgState -> CgState) (u2 :: CgInfoDownwards -> CgState -> u0) (u3 :: CgInfoDownwards) (u4 :: CgState) -> let {(u5 :: CgState) = _APP_ u1 [ u3, u4 ]} in _APP_ u2 [ u3, u5 ] _N_ #-}
thenFC :: (CgInfoDownwards -> CgState -> (a, CgState)) -> (a -> CgInfoDownwards -> CgState -> b) -> CgInfoDownwards -> CgState -> b
- {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "LSLL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: CgInfoDownwards -> CgState -> (u0, CgState)) (u3 :: u0 -> CgInfoDownwards -> CgState -> u1) (u4 :: CgInfoDownwards) (u5 :: CgState) -> let {(u6 :: (u0, CgState)) = _APP_ u2 [ u4, u5 ]} in let {(u9 :: u0) = case u6 of { _ALG_ _TUP_2 (u7 :: u0) (u8 :: CgState) -> u7; _NO_DEFLT_ }} in let {(uc :: CgState) = case u6 of { _ALG_ _TUP_2 (ua :: u0) (ub :: CgState) -> ub; _NO_DEFLT_ }} in _APP_ u3 [ u9, u4, uc ] _N_ #-}
instance Eq CLabel
- {-# GHC_PRAGMA _M_ CLabelInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool)] [_CONSTM_ Eq (==) (CLabel), _CONSTM_ Eq (/=) (CLabel)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq GlobalSwitch
- {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool)] [_CONSTM_ Eq (==) (GlobalSwitch), _CONSTM_ Eq (/=) (GlobalSwitch)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Eq Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Ord CLabel
- {-# GHC_PRAGMA _M_ CLabelInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq CLabel}}, (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> Bool), (CLabel -> CLabel -> CLabel), (CLabel -> CLabel -> CLabel), (CLabel -> CLabel -> _CMP_TAG)] [_DFUN_ Eq (CLabel), _CONSTM_ Ord (<) (CLabel), _CONSTM_ Ord (<=) (CLabel), _CONSTM_ Ord (>=) (CLabel), _CONSTM_ Ord (>) (CLabel), _CONSTM_ Ord max (CLabel), _CONSTM_ Ord min (CLabel), _CONSTM_ Ord _tagCmp (CLabel)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord GlobalSwitch
- {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq GlobalSwitch}}, (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> _CMP_TAG)] [_DFUN_ Eq (GlobalSwitch), _CONSTM_ Ord (<) (GlobalSwitch), _CONSTM_ Ord (<=) (GlobalSwitch), _CONSTM_ Ord (>=) (GlobalSwitch), _CONSTM_ Ord (>) (GlobalSwitch), _CONSTM_ Ord max (GlobalSwitch), _CONSTM_ Ord min (GlobalSwitch), _CONSTM_ Ord _tagCmp (GlobalSwitch)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Ord Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_,
- getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance Text Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_
- readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_,
- showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
-- addFreeASlots, -- no need to export it
addFreeBSlots, -- ToDo: Belong elsewhere
- isSwitchSetC, isStringSwitchSetC,
+ isSwitchSetC, isStringSwitchSetC, getIntSwitchChkrC,
noBlackHolingFlag,
profCtrC, --UNUSED: concurrentC,
CgBindings(..),
CgInfoDownwards(..), CgState(..), -- non-abstract
CgIdInfo, -- abstract
- CompilationInfo(..),
+ CompilationInfo(..), IntSwitchChecker(..),
GlobalSwitch, -- abstract
stableAmodeIdInfo, heapIdInfo,
= MkCompInfo
(GlobalSwitch -> Bool)
-- use it to look up whatever we like in command-line flags
+ IntSwitchChecker-- similar; for flags that have an Int assoc.
+ -- with them, notably number of regs available.
FAST_STRING -- the module name
-
+
+type IntSwitchChecker = (Int -> GlobalSwitch) -> Maybe Int
data CgState
= MkCgState
\begin{code}
isSwitchSetC :: GlobalSwitch -> FCode Bool
-isSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state
+isSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
= (sw_chkr switch, state)
isStringSwitchSetC :: (String -> GlobalSwitch) -> FCode Bool
-isStringSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state
+isStringSwitchSetC switch (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
= (sw_chkr (switch (panic "isStringSwitchSetC")), state)
+getIntSwitchChkrC :: FCode IntSwitchChecker
+
+getIntSwitchChkrC (MkCgInfoDown (MkCompInfo _ isw_chkr _) _ _) state
+ = (isw_chkr, state)
+
costCentresC :: FAST_STRING -> [CAddrMode] -> Code
-costCentresC macro args (MkCgInfoDown (MkCompInfo sw_chkr _) _ _)
+costCentresC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
state@(MkCgState absC binds usage)
= if sw_chkr SccProfilingOn
then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
profCtrC :: FAST_STRING -> [CAddrMode] -> Code
-profCtrC macro args (MkCgInfoDown (MkCompInfo sw_chkr _) _ _)
+profCtrC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
state@(MkCgState absC binds usage)
= if not (sw_chkr DoTickyProfiling)
then state
{- UNUSED, as it happens:
concurrentC :: AbstractC -> Code
-concurrentC more_absC (MkCgInfoDown (MkCompInfo sw_chkr _) _ _)
+concurrentC more_absC (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
state@(MkCgState absC binds usage)
= if not (sw_chkr ForConcurrent)
then state
\begin{code}
noBlackHolingFlag, costCentresFlag :: FCode Bool
-noBlackHolingFlag (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state
+noBlackHolingFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
= (sw_chkr OmitBlackHoling, state)
-costCentresFlag (MkCgInfoDown (MkCompInfo sw_chkr _) _ _) state
+costCentresFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
= (sw_chkr SccProfilingOn, state)
\end{code}
\begin{code}
moduleName :: FCode FAST_STRING
-moduleName (MkCgInfoDown (MkCompInfo _ mod_name) _ _) state
+moduleName (MkCgInfoDown (MkCompInfo _ _ mod_name) _ _) state
= (mod_name, state)
\end{code}
interface CgRetConv where
import AbsCSyn(AbstractC, CAddrMode, MagicId)
import CLabelInfo(CLabel)
-import Class(Class)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import CmdLineOpts(GlobalSwitch)
+import Id(Id)
import Maybes(Labda)
-import NameTypes(FullName)
import PrimKind(PrimKind)
import PrimOps(PrimOp)
import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-import Unique(Unique)
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
+data MagicId
data CLabel
data CtrlReturnConvention = VectoredReturn Int | UnvectoredReturn Int
data DataReturnConvention = ReturnInHeap | ReturnInRegs [MagicId]
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
+data Id
+data PrimKind
+data TyCon
assignPrimOpResultRegs :: PrimOp -> [MagicId]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-assignRegs :: [MagicId] -> [PrimKind] -> ([MagicId], [PrimKind])
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
+assignRegs :: ((Int -> GlobalSwitch) -> Labda Int) -> [MagicId] -> [PrimKind] -> ([MagicId], [PrimKind])
ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-dataReturnConvAlg :: Id -> DataReturnConvention
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+dataReturnConvAlg :: ((Int -> GlobalSwitch) -> Labda Int) -> Id -> DataReturnConvention
dataReturnConvPrim :: PrimKind -> MagicId
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "E" _N_ _N_ #-}
makePrimOpArgsRobust :: PrimOp -> [CAddrMode] -> ([CAddrMode], Int, AbstractC)
- {-# GHC_PRAGMA _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkLiveRegsBitMask :: [MagicId] -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
noLiveRegsMask :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [0#] _N_ #-}
import AbsCSyn
import AbsPrel ( PrimOp(..), PrimOpResultInfo(..), primOpCanTriggerGC,
- getPrimOpResultInfo, PrimKind
+ getPrimOpResultInfo, integerDataCon, PrimKind
IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
)
IF_ATTACK_PRAGMAS(COMMA cmpUniType)
)
import CgCompInfo -- various things
-
+import CgMonad ( IntSwitchChecker(..) )
+import CmdLineOpts ( GlobalSwitch(..) )
import Id ( Id, getDataConSig, fIRST_TAG, isDataCon,
DataCon(..), ConTag(..)
)
\begin{code}
ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
+
ctrlReturnConvAlg tycon
= case (getTyConFamilySize tycon) of
Nothing -> -- pprPanic "ctrlReturnConvAlg:" (ppr PprDebug tycon)
then it gives up, returning @ReturnInHeap@.
\begin{code}
-dataReturnConvAlg :: DataCon -> DataReturnConvention
+dataReturnConvAlg :: IntSwitchChecker -> DataCon -> DataReturnConvention
-dataReturnConvAlg data_con
+dataReturnConvAlg isw_chkr data_con
= ASSERT(isDataCon data_con)
case leftover_kinds of
[] -> ReturnInRegs reg_assignment
other -> ReturnInHeap -- Didn't fit in registers
where
(_, _, arg_tys, _) = getDataConSig data_con
- (reg_assignment, leftover_kinds) = assignRegs [node,infoptr]
- (map kindFromType arg_tys)
+
+ (reg_assignment, leftover_kinds)
+ = assignRegs isw_chkr_to_use
+ [node, infoptr] -- taken...
+ (map kindFromType arg_tys)
+
+ isw_chkr_to_use = isw_chkr
+{-OLD:
+ = if is_prim_result_ty {-and therefore *ignore* any return-in-regs threshold-}
+ then \ x -> Nothing
+ else isw_chkr
+-}
+ is_prim_result_ty = data_con == integerDataCon -- ***HACK***! (WDP 95/11)
\end{code}
\begin{code}
\begin{code}
assignPrimOpResultRegs
- :: PrimOp -- The constructors in canonical order
+ :: PrimOp -- The constructors in canonical order
-> [MagicId] -- The return regs all concatenated to together,
-- (*including* one for the tag if necy)
ReturnsPrim kind -> [dataReturnConvPrim kind]
- ReturnsAlg tycon -> let cons = getTyConDataCons tycon
- result_regs = concat (map get_return_regs cons)
- in
- -- Since R1 is dead, it can hold the tag if necessary
- case cons of
- [_] -> result_regs
- other -> (VanillaReg IntKind ILIT(1)) : result_regs
+ ReturnsAlg tycon
+ -> let
+ cons = getTyConDataCons tycon
+ result_regs = concat (map get_return_regs cons)
+ in
+ -- As R1 is dead, it can hold the tag if necessary
+ case cons of
+ [_] -> result_regs
+ other -> (VanillaReg IntKind ILIT(1)) : result_regs
+ where
+ get_return_regs con
+ = case (dataReturnConvAlg fake_isw_chkr con) of
+ ReturnInRegs regs -> regs
+ ReturnInHeap -> panic "getPrimOpAlgResultRegs"
- where
- get_return_regs con = case (dataReturnConvAlg con) of
- ReturnInHeap -> panic "getPrimOpAlgResultRegs"
- ReturnInRegs regs -> regs
+ fake_isw_chkr :: IntSwitchChecker
+ fake_isw_chkr x = Nothing
\end{code}
@assignPrimOpArgsRobust@ is used only for primitive ops which may
non_robust_amodes = filter (not . amodeCanSurviveGC) arg_amodes
arg_kinds = map getAmodeKind non_robust_amodes
- (arg_regs, extra_args) = assignRegs [{-nothing live-}] arg_kinds
+ (arg_regs, extra_args)
+ = assignRegs fake_isw_chkr [{-nothing live-}] arg_kinds
-- Check that all the args fit before returning arg_regs
final_arg_regs = case extra_args of
[] -> arg_regs
other -> error ("Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?) " ++ ppShow 80 (ppr PprDebug op))
- arg_assts = mkAbstractCs (zipWith assign_to_reg arg_regs non_robust_amodes)
+ arg_assts = mkAbstractCs (zipWith assign_to_reg final_arg_regs non_robust_amodes)
assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
safe_arg regs arg
| amodeCanSurviveGC arg = (regs, arg)
| otherwise = (tail regs, CReg (head regs))
- safe_amodes = snd (mapAccumL safe_arg arg_regs arg_amodes)
+ safe_amodes = snd (mapAccumL safe_arg final_arg_regs arg_amodes)
- liveness_mask = mkLiveRegsBitMask arg_regs
+ liveness_mask = mkLiveRegsBitMask final_arg_regs
in
(safe_amodes, liveness_mask, arg_assts)
+ where
+ fake_isw_chkr :: IntSwitchChecker
+ fake_isw_chkr x = Nothing
\end{code}
%************************************************************************
register); we just return immediately with the left-overs specified.
\begin{code}
-assignRegs :: [MagicId] -- Unavailable registers
+assignRegs :: IntSwitchChecker
+ -> [MagicId] -- Unavailable registers
-> [PrimKind] -- Arg or result kinds to assign
-> ([MagicId], -- Register assignment in same order
-- for *initial segment of* input list
[PrimKind])-- leftover kinds
-#ifndef DPH
-assignRegs regs_in_use kinds
- = assign_reg kinds [] (mkRegTbl regs_in_use)
+assignRegs isw_chkr regs_in_use kinds
+ = assign_reg kinds [] (mkRegTbl isw_chkr regs_in_use)
where
assign_reg :: [PrimKind] -- arg kinds being scrutinized
-- or, I suppose,
-- (c) we came across a Kind we couldn't handle (this one shouldn't happen)
assign_reg leftover_ks acc _ = (reverse acc, leftover_ks)
-#else
-assignRegs node_using_Ret1 kinds
- = if node_using_Ret1
- then assign_reg kinds [] (tail vanillaRegNos) (tail datRegNos)
- else assign_reg kinds [] vanillaRegNos (tail datRegNos)
- where
- assign_reg:: [PrimKind] -- arg kinds being scrutinized
- -> [MagicId] -- accum. regs assigned so far (reversed)
- -> [Int] -- Vanilla Regs (ptr, int, char, float or double)
- -> [Int] -- Data Regs ( int, char, float or double)
- -> ([MagicId], [PrimKind])
-
- assign_reg (k:ks) acc (IBOX(p):ptr_regs) dat_regs
- | isFollowableKind k
- = assign_reg ks (VanillaReg k p:acc) ptr_regs dat_regs
-
- assign_reg (CharKind:ks) acc ptr_regs (d:dat_regs)
- = assign_reg ks (DataReg CharKind d:acc) ptr_regs dat_regs
-
- assign_reg (IntKind:ks) acc ptr_regs (d:dat_regs)
- = assign_reg ks (DataReg IntKind d:acc) ptr_regs dat_regs
-
- assign_reg (WordKind:ks) acc ptr_regs (d:dat_regs)
- = assign_reg ks (DataReg WordKind d:acc) ptr_regs dat_regs
-
- assign_reg (AddrKind:ks) acc ptr_regs (d:dat_regs)
- = assign_reg ks (DataReg AddrKind d:acc) ptr_regs dat_regs
-
- assign_reg (FloatKind:ks) acc ptr_regs (d:dat_regs)
- = assign_reg ks (DataReg FloatKind d:acc) ptr_regs dat_regs
-
- -- Notice how doubles take up two data registers....
- assign_reg (DoubleKind:ks) acc ptr_regs (IBOX(d1):d2:dat_regs)
- = assign_reg ks (DoubleReg d1:acc) ptr_regs dat_regs
-
- assign_reg (VoidKind:ks) acc ptr_regs dat_regs
- = assign_reg ks (VoidReg:acc) ptr_regs dat_regs
-
- -- The catch-all. It can happen because either
- -- (a) we've assigned all the regs so leftover_ks is []
- -- (b) we couldn't find a spare register in the appropriate supply
- -- or, I suppose,
- -- (c) we came across a Kind we couldn't handle (this one shouldn't happen)
- -- ToDo Maybe when dataReg becomes empty, we can start using the
- -- vanilla registers ????
- assign_reg leftover_ks acc _ _ = (reverse acc, leftover_ks)
-#endif {- Data Parallel Haskell -}
\end{code}
Register supplies. Vanilla registers can contain pointers, Ints, Chars.
vanillaRegNos = [1 .. mAX_Vanilla_REG]
\end{code}
-Only a subset of the registers on the DAP can be used to hold pointers (and most
-of these are taken up with things like the heap pointer and stack pointers).
-However the resulting registers can hold integers, floats or chars. We therefore
-allocate pointer like things into the @vanillaRegNos@ (and Ints Chars or Floats
-if the remaining registers are empty). See NOTE.regsiterMap for an outline of
-the global and local register allocation scheme.
-
-\begin{code}
-#ifdef DPH
-datRegNos ::[Int]
-datRegNos = [1..mAX_Data_REG] -- For Ints, Floats, Doubles or Chars
-#endif {- Data Parallel Haskell -}
-\end{code}
-
Floats and doubles have separate register supplies.
\begin{code}
-#ifndef DPH
floatRegNos, doubleRegNos :: [Int]
floatRegNos = [1 .. mAX_Float_REG]
doubleRegNos = [1 .. mAX_Double_REG]
-mkRegTbl :: [MagicId] -> ([Int], [Int], [Int])
-mkRegTbl regs_in_use = (ok_vanilla, ok_float, ok_double)
+mkRegTbl :: IntSwitchChecker -> [MagicId] -> ([Int], [Int], [Int])
+
+mkRegTbl isw_chkr regs_in_use
+ = (ok_vanilla, ok_float, ok_double)
where
- ok_vanilla = catMaybes (map (select (VanillaReg VoidKind)) vanillaRegNos)
+ ok_vanilla = catMaybes (map (select (VanillaReg VoidKind)) (taker vanillaRegNos))
ok_float = catMaybes (map (select FloatReg) floatRegNos)
ok_double = catMaybes (map (select DoubleReg) doubleRegNos)
+ taker :: [Int] -> [Int]
+ taker rs
+ = case (isw_chkr ReturnInRegsThreshold) of
+ Nothing -> rs -- no flag set; use all of them
+ Just n -> take n rs
+
select :: (FAST_INT -> MagicId) -> Int{-cand-} -> Maybe Int
-- one we've unboxed the Int, we make a MagicId
-- and see if it is already in use; if not, return its number.
else Nothing
where
not_elem = isn'tIn "mkRegTbl"
-
-#endif {- Data Parallel Haskell -}
\end{code}
import PrimOps(PrimOp)
import UniqFM(UniqFM)
import Unique(Unique)
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
-data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-}
-data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
+data AbstractC
+data CAddrMode
+data CgState
+data PrimKind
adjustRealSps :: Int -> Int -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 4 _U_ 2201 _N_ _S_ "LLAU(LLU(U(LLLL)U(LLLL)L))" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
allocAStack :: CgInfoDownwards -> CgState -> (Int, CgState)
- {-# GHC_PRAGMA _A_ 2 _U_ 01 _N_ _S_ "AU(LLU(U(LLLL)LL))" {_A_ 5 _U_ 22122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
allocBStack :: Int -> CgInfoDownwards -> CgState -> (Int, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(LU(LLLL)L))" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
allocUpdateFrame :: Int -> CAddrMode -> ((Int, Int, Int) -> CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 5 _U_ 12111 _N_ _S_ "LLSU(LLU(LLS))U(LLU(LU(LLLL)L))" _N_ _N_ #-}
getFinalStackHW :: (Int -> Int -> CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "SLU(LLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkStkAmodes :: Int -> Int -> [CAddrMode] -> CgInfoDownwards -> CgState -> ((Int, Int, AbstractC), CgState)
- {-# GHC_PRAGMA _A_ 5 _U_ 22201 _N_ _S_ "LLLAU(LLL)" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkVirtStkOffsets :: Int -> Int -> (a -> PrimKind) -> [a] -> (Int, Int, [(a, Int)], [(a, Int)])
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
find_block :: [VirtualSpBOffset] -> Maybe VirtualSpBOffset
find_block [] = Nothing
find_block (slot:slots)
- | take size (slot:slots) == take size (repeat slot)
+ | take size (slot:slots) == [slot..slot+size-1]
= Just slot
| otherwise
= find_block slots
import CLabelInfo(CLabel)
import CgBindery(CgIdInfo)
import CgMonad(CgInfoDownwards, CgState, CompilationInfo, EndOfBlockInfo, Sequel, StubFlag)
-import Class(Class)
import ClosureInfo(LambdaFormInfo)
import CostCentre(CostCentre)
import HeapOffs(HeapOffset)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Maybes(Labda)
-import NameTypes(FullName)
import PreludePS(_PackedString)
import PrimKind(PrimKind)
import StgSyn(StgAtom)
import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
import UniqFM(UniqFM)
import Unique(Unique)
-data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-}
-data CgInfoDownwards {-# GHC_PRAGMA MkCgInfoDown CompilationInfo (UniqFM CgIdInfo) EndOfBlockInfo #-}
-data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-}
+data CAddrMode
+data CgInfoDownwards
+data CgState
data HeapOffset
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data StgAtom a {-# GHC_PRAGMA StgVarAtom a | StgLitAtom BasicLit #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
+data Id
+data Labda a
+data StgAtom a
+data TyCon
cgTailCall :: StgAtom Id -> [StgAtom Id] -> UniqFM Id -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _S_ "SSL" _N_ _N_ #-}
mkDynamicAlgReturnCode :: TyCon -> CAddrMode -> Sequel -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _S_ "SLS" _N_ _N_ #-}
mkPrimReturnCode :: Sequel -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLL" _N_ _N_ #-}
mkStaticAlgReturnCode :: Id -> Labda CLabel -> Sequel -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _S_ "LLS" _N_ _N_ #-}
performReturn :: AbstractC -> (Sequel -> CgInfoDownwards -> CgState -> CgState) -> UniqFM Id -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 5 _U_ 21221 _N_ _S_ "LSLU(LLU(LLL))L" _N_ _N_ #-}
tailCallBusiness :: Id -> CAddrMode -> LambdaFormInfo -> [CAddrMode] -> UniqFM Id -> AbstractC -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 6 _U_ 22222222 _N_ _S_ "LSLLLL" _N_ _N_ #-}
mkStaticAlgReturnCode con maybe_info_lbl sequel
= -- Generate profiling code if necessary
(case return_convention of
- VectoredReturn _ -> profCtrC SLIT("VEC_RETURN") []
- other -> nopC
+ VectoredReturn sz -> profCtrC SLIT("VEC_RETURN") [mkIntCLit sz]
+ other -> nopC
) `thenC`
-- Set tag if necessary
-- Set the info pointer, and jump
set_info_ptr `thenC`
- absC (CJump (CLbl update_label CodePtrKind))
+ getIntSwitchChkrC `thenFC` \ isw_chkr ->
+ absC (CJump (CLbl (update_label isw_chkr) CodePtrKind))
CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
-- we can go right to the alternative
zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
-- cf AbsCFuns.mkAlgAltsCSwitch
- update_label = case dataReturnConvAlg con of
- ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
- ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
+ update_label isw_chkr
+ = case (dataReturnConvAlg isw_chkr con) of
+ ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
+ ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
return_info = case return_convention of
UnvectoredReturn _ -> DirectReturn
mkDynamicAlgReturnCode tycon dyn_tag sequel
= case ctrlReturnConvAlg tycon of
- VectoredReturn _ ->
+ VectoredReturn sz ->
- profCtrC SLIT("VEC_RETURN") [] `thenC`
+ profCtrC SLIT("VEC_RETURN") [mkIntCLit sz] `thenC`
sequelToAmode sequel `thenFC` \ ret_addr ->
absC (CReturn ret_addr (DynamicVectoredReturn dyn_tag))
-> Code
tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
- = profCtrC SLIT("SET_ACTIVITY") [CLitLit SLIT("ACT_TAILCALL") IntKind] `thenC`
-
- isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
+ = isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
nodeMustPointToIt lf_info `thenFC` \ node_points ->
getEntryConvention fun lf_info
-- Here, lit.3 is built as a re-entrant thing, which you must enter.
-- (OK, the simplifier should have eliminated this, but it's
-- easy to deal with the case anyway.)
-
-
let
join_details_to_code (load_regs_and_profiling_code, join_lbl)
= load_regs_and_profiling_code `mkAbsCStmts`
| (tag, join_details) <- st_alts
]
- -- This alternative is for the unevaluated case; oTHER_TAG is -1
- un_evald_alt = (mkMachInt oTHER_TAG, enter_jump)
-
- enter_jump = CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr])
+ enter_jump
-- Enter Node (we know infoptr will have the info ptr in it)!
-
+ = mkAbstractCs [
+ CCallProfCtrMacro SLIT("RET_SEMI_FAILED")
+ [CMacroExpr IntKind INFO_TAG [CReg infoptr]],
+ CJump (CMacroExpr CodePtrKind ENTRY_CODE [CReg infoptr]) ]
in
-
-- Final switch
absC (mkAbstractCs [
CAssign (CReg infoptr)
import AbsCSyn(CAddrMode)
import CgMonad(CgInfoDownwards, CgState)
pushUpdateFrame :: CAddrMode -> CAddrMode -> (CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _S_ "LLSU(U(LL)LU(LLS))U(LLU(LU(LLLL)L))" _N_ _N_ #-}
import PreludePS(_PackedString)
import PrimOps(PrimOp)
import UniqFM(UniqFM)
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
-data RegRelative {-# GHC_PRAGMA HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset #-}
-data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-}
+data AbstractC
+data RegRelative
+data CgState
data HeapOffset
freeBStkSlot :: Int -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(LU(LLLL)L))" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getHpRelOffset :: HeapOffset -> CgInfoDownwards -> CgState -> (RegRelative, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(LLU(LL)))" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getSpARelOffset :: Int -> CgInfoDownwards -> CgState -> (RegRelative, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(U(LLLL)LL))" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getSpBRelOffset :: Int -> CgInfoDownwards -> CgState -> (RegRelative, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(LU(LLLL)L))" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getVirtAndRealHp :: CgInfoDownwards -> CgState -> ((HeapOffset, HeapOffset), CgState)
- {-# GHC_PRAGMA _A_ 2 _U_ 01 _N_ _S_ "AU(LLU(LLU(LL)))" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 2 XC 6 \ (u0 :: CgInfoDownwards) (u1 :: CgState) -> case u1 of { _ALG_ _ORIG_ CgMonad MkCgState (u2 :: AbstractC) (u3 :: UniqFM CgIdInfo) (u4 :: ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset))) -> case u4 of { _ALG_ _TUP_3 (u5 :: (Int, [(Int, StubFlag)], Int, Int)) (u6 :: (Int, [Int], Int, Int)) (u7 :: (HeapOffset, HeapOffset)) -> case u7 of { _ALG_ _TUP_2 (u8 :: HeapOffset) (u9 :: HeapOffset) -> _!_ _TUP_2 [(HeapOffset, HeapOffset), CgState] [u7, u1]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getVirtSps :: CgInfoDownwards -> CgState -> ((Int, Int), CgState)
- {-# GHC_PRAGMA _A_ 2 _U_ 01 _N_ _S_ "AU(LLU(U(LLLL)U(LLLL)L))" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
initHeapUsage :: (HeapOffset -> CgInfoDownwards -> CgState -> CgState) -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLU(LLU(LLL))" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
setRealAndVirtualSps :: Int -> Int -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 4 _U_ 2201 _N_ _S_ "LLAU(LLU(U(ALAA)U(ALAA)L))" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
setRealHp :: HeapOffset -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(LLU(LA)))" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
setVirtHp :: HeapOffset -> CgInfoDownwards -> CgState -> CgState
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(LLU(LLU(AL)))" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
interface ClosureInfo where
import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
import BasicLit(BasicLit)
-import CLabelInfo(CLabel, mkClosureLabel)
-import CgBindery(CgIdInfo, StableLoc, VolatileLoc)
+import CLabelInfo(CLabel)
+import CgBindery(CgIdInfo)
import CgMonad(CgInfoDownwards, CgState, CompilationInfo, EndOfBlockInfo, FCode(..), StubFlag)
-import Class(Class)
import CmdLineOpts(GlobalSwitch)
import CostCentre(CostCentre)
import HeapOffs(HeapOffset)
-import Id(DataCon(..), Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(DataCon(..), Id)
import Maybes(Labda)
-import NameTypes(FullName)
import PreludePS(_PackedString)
import PrimKind(PrimKind)
import PrimOps(PrimOp)
import SMRep(SMRep, SMSpecRepKind, SMUpdateKind, getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, ltSMRepHdr)
import StgSyn(PlainStgAtom(..), PlainStgExpr(..), PlainStgLiveVars(..), StgAtom, StgBinderInfo, StgBinding, StgCaseAlternatives, StgExpr, UpdateFlag(..))
import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniTyFuns(getUniDataSpecTyCon_maybe)
import UniType(UniType)
import UniqFM(UniqFM)
import UniqSet(UniqSet(..))
import Unique(Unique)
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
-data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-}
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
+data AbstractC
+data CAddrMode
+data MagicId
data CLabel
-data CgIdInfo {-# GHC_PRAGMA MkCgIdInfo Id VolatileLoc StableLoc LambdaFormInfo #-}
-data CgInfoDownwards {-# GHC_PRAGMA MkCgInfoDown CompilationInfo (UniqFM CgIdInfo) EndOfBlockInfo #-}
-data CgState {-# GHC_PRAGMA MkCgState AbstractC (UniqFM CgIdInfo) ((Int, [(Int, StubFlag)], Int, Int), (Int, [Int], Int, Int), (HeapOffset, HeapOffset)) #-}
-data ClosureInfo {-# GHC_PRAGMA MkClosureInfo Id LambdaFormInfo SMRep #-}
-data CompilationInfo {-# GHC_PRAGMA MkCompInfo (GlobalSwitch -> Bool) _PackedString #-}
+data CgIdInfo
+data CgInfoDownwards
+data CgState
+data ClosureInfo
+data CompilationInfo
data EntryConvention = ViaNode | StdEntry CLabel (Labda CLabel) | DirectEntry CLabel Int [MagicId]
type FCode a = CgInfoDownwards -> CgState -> (a, CgState)
data HeapOffset
type DataCon = Id
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data LambdaFormInfo {-# GHC_PRAGMA LFReEntrant Bool Int Bool | LFCon Id Bool | LFTuple Id Bool | LFThunk Bool Bool Bool StandardFormInfo | LFArgument | LFImported | LFLetNoEscape Int (UniqFM Id) | LFBlackHole | LFIndirection #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-}
+data Id
+data Labda a
+data LambdaFormInfo
+data PrimKind
+data SMRep
type PlainStgAtom = StgAtom Id
type PlainStgExpr = StgExpr Id Id
type PlainStgLiveVars = UniqFM Id
-data StandardFormInfo {-# GHC_PRAGMA NonStandardThunk | SelectorThunk Id Id Int | VapThunk Id [StgAtom Id] Bool #-}
-data StgAtom a {-# GHC_PRAGMA StgVarAtom a | StgLitAtom BasicLit #-}
-data StgBinderInfo {-# GHC_PRAGMA NoStgBinderInfo | StgBinderInfo Bool Bool Bool Bool Bool #-}
-data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-}
+data StandardFormInfo
+data StgAtom a
+data StgBinderInfo
+data StgExpr a b
data UpdateFlag = ReEntrant | Updatable | SingleEntry
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data TyCon
+data UniqFM a
type UniqSet a = UniqFM a
allocProfilingMsg :: ClosureInfo -> _PackedString
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
blackHoleClosureInfo :: ClosureInfo -> ClosureInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
blackHoleOnEntry :: Bool -> ClosureInfo -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LU(ALS)" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_ #-}
closureGoodStuffSize :: ClosureInfo -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
closureHdrSize :: ClosureInfo -> HeapOffset
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ HeapOffs totHdrSize _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: ClosureInfo) -> case u0 of { _ALG_ _ORIG_ ClosureInfo MkClosureInfo (u1 :: Id) (u2 :: LambdaFormInfo) (u3 :: SMRep) -> _APP_ _ORIG_ HeapOffs totHdrSize [ u3 ]; _NO_DEFLT_ } _N_ #-}
closureId :: ClosureInfo -> Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(LLLL)AA)" {_A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: UniType) (u2 :: IdInfo) (u3 :: IdDetails) -> _!_ _ORIG_ Id Id [] [u0, u1, u2, u3] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClosureInfo) -> case u0 of { _ALG_ _ORIG_ ClosureInfo MkClosureInfo (u1 :: Id) (u2 :: LambdaFormInfo) (u3 :: SMRep) -> u1; _NO_DEFLT_ } _N_ #-}
closureKind :: ClosureInfo -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
closureLFInfo :: ClosureInfo -> LambdaFormInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: LambdaFormInfo) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClosureInfo) -> case u0 of { _ALG_ _ORIG_ ClosureInfo MkClosureInfo (u1 :: Id) (u2 :: LambdaFormInfo) (u3 :: SMRep) -> u2; _NO_DEFLT_ } _N_ #-}
closureLabelFromCI :: ClosureInfo -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ CLabelInfo mkClosureLabel _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: ClosureInfo) -> case u0 of { _ALG_ _ORIG_ ClosureInfo MkClosureInfo (u1 :: Id) (u2 :: LambdaFormInfo) (u3 :: SMRep) -> _APP_ _ORIG_ CLabelInfo mkClosureLabel [ u1 ]; _NO_DEFLT_ } _N_ #-}
closureNonHdrSize :: ClosureInfo -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ALS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
closurePtrsSize :: ClosureInfo -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
closureReturnsUnboxedType :: ClosureInfo -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LSA)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-}
closureSMRep :: ClosureInfo -> SMRep
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SMRep) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClosureInfo) -> case u0 of { _ALG_ _ORIG_ ClosureInfo MkClosureInfo (u1 :: Id) (u2 :: LambdaFormInfo) (u3 :: SMRep) -> u3; _NO_DEFLT_ } _N_ #-}
closureSemiTag :: ClosureInfo -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
closureSingleEntry :: ClosureInfo -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
closureSize :: ClosureInfo -> HeapOffset
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ALS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
closureSizeWithoutFixedHdr :: ClosureInfo -> HeapOffset
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ALS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
closureType :: ClosureInfo -> Labda (TyCon, [UniType], [Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LSA)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-}
closureTypeDescr :: ClosureInfo -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(ALAS)AA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
closureUpdReqd :: ClosureInfo -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 12 \ (u0 :: LambdaFormInfo) -> case u0 of { _ALG_ _ORIG_ ClosureInfo LFThunk (u1 :: Bool) (u2 :: Bool) (u3 :: Bool) (u4 :: StandardFormInfo) -> u3; _ORIG_ ClosureInfo LFBlackHole -> _!_ True [] []; (u5 :: LambdaFormInfo) -> _!_ False [] [] } _N_} _N_ _N_ #-}
-dataConLiveness :: ClosureInfo -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+dataConLiveness :: ((Int -> GlobalSwitch) -> Labda Int) -> ClosureInfo -> Int
entryLabelFromCI :: ClosureInfo -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LSL)" {_A_ 3 _U_ 211 _N_ _N_ _N_ _N_} _N_ _N_ #-}
fastLabelFromCI :: ClosureInfo -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
fitsMinUpdSize :: ClosureInfo -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ALS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
funInfoTableRequired :: Id -> StgBinderInfo -> LambdaFormInfo -> Bool
- {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LSL" _N_ _N_ #-}
getEntryConvention :: Id -> LambdaFormInfo -> [PrimKind] -> CgInfoDownwards -> CgState -> (EntryConvention, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-}
-mkClosureLabel :: Id -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
getSMInfoStr :: SMRep -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getSMInitHdrStr :: SMRep -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getSMUpdInplaceHdrStr :: SMRep -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getStandardFormThunkInfo :: LambdaFormInfo -> Labda [StgAtom Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-getUniDataSpecTyCon_maybe :: UniType -> Labda (TyCon, [UniType], [Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
infoTableLabelFromCI :: ClosureInfo -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LSL)" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isConstantRep :: SMRep -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isPhantomRep :: SMRep -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: SMRep) -> case u0 of { _ALG_ _ORIG_ SMRep PhantomRep -> _!_ True [] []; (u1 :: SMRep) -> _!_ False [] [] } _N_ #-}
isSpecRep :: SMRep -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: SMRep) -> case u0 of { _ALG_ _ORIG_ SMRep SpecialisedRep (u1 :: SMSpecRepKind) (u2 :: Int) (u3 :: Int) (u4 :: SMUpdateKind) -> _!_ True [] []; (u5 :: SMRep) -> _!_ False [] [] } _N_ #-}
isStaticClosure :: ClosureInfo -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: SMRep) -> case u0 of { _ALG_ _ORIG_ SMRep StaticRep (u1 :: Int) (u2 :: Int) -> _!_ True [] []; (u3 :: SMRep) -> _!_ False [] [] } _N_} _N_ _N_ #-}
layOutDynClosure :: Id -> (a -> PrimKind) -> [a] -> LambdaFormInfo -> (ClosureInfo, [(a, HeapOffset)])
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
layOutDynCon :: Id -> (a -> PrimKind) -> [a] -> (ClosureInfo, [(a, HeapOffset)])
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
layOutPhantomClosure :: Id -> LambdaFormInfo -> ClosureInfo
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
layOutStaticClosure :: Id -> (a -> PrimKind) -> [a] -> LambdaFormInfo -> (ClosureInfo, [(a, HeapOffset)])
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
layOutStaticNoFVClosure :: Id -> LambdaFormInfo -> ClosureInfo
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
ltSMRepHdr :: SMRep -> SMRep -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
maybeSelectorInfo :: ClosureInfo -> Labda (Id, Int)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkClosureLFInfo :: Bool -> [Id] -> UpdateFlag -> [Id] -> StgExpr Id Id -> LambdaFormInfo
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _S_ "LLLSL" _N_ _N_ #-}
mkConLFInfo :: Id -> LambdaFormInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LLLS)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkLFArgument :: LambdaFormInfo
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ ClosureInfo LFArgument [] [] _N_ #-}
mkLFImported :: Id -> LambdaFormInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(SAAAAAAAAA)A)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkLFLetNoEscape :: Int -> UniqFM Id -> LambdaFormInfo
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: UniqFM Id) -> _!_ _ORIG_ ClosureInfo LFLetNoEscape [] [u0, u1] _N_ #-}
mkVirtHeapOffsets :: SMRep -> (a -> PrimKind) -> [a] -> (Int, Int, [(a, HeapOffset)])
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
noUpdVapRequired :: StgBinderInfo -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: StgBinderInfo) -> case u0 of { _ALG_ _ORIG_ StgSyn NoStgBinderInfo -> _!_ False [] []; _ORIG_ StgSyn StgBinderInfo (u1 :: Bool) (u2 :: Bool) (u3 :: Bool) (u4 :: Bool) (u5 :: Bool) -> u4; _NO_DEFLT_ } _N_ #-}
nodeMustPointToIt :: LambdaFormInfo -> CgInfoDownwards -> CgState -> (Bool, CgState)
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-}
slopSize :: ClosureInfo -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ALS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
slowFunEntryCodeRequired :: Id -> StgBinderInfo -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-}
staticClosureRequired :: Id -> StgBinderInfo -> LambdaFormInfo -> Bool
- {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LSL" _N_ _N_ #-}
stdVapRequired :: StgBinderInfo -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: StgBinderInfo) -> case u0 of { _ALG_ _ORIG_ StgSyn NoStgBinderInfo -> _!_ False [] []; _ORIG_ StgSyn StgBinderInfo (u1 :: Bool) (u2 :: Bool) (u3 :: Bool) (u4 :: Bool) (u5 :: Bool) -> u3; _NO_DEFLT_ } _N_ #-}
-- This last one is really only for completeness;
-- it isn't actually used for anything interesting
- | LFIndirection
+ {- | LFIndirection -}
data StandardFormInfo -- Tells whether this thunk has one of a small number
-- of standard forms
-> FCode EntryConvention
getEntryConvention id lf_info arg_kinds
- = nodeMustPointToIt lf_info `thenFC` \ node_points ->
- isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
+ = nodeMustPointToIt lf_info `thenFC` \ node_points ->
+ isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
+ getIntSwitchChkrC `thenFC` \ isw_chkr ->
returnFC (
if (node_points && is_concurrent) then ViaNode else
else
DirectEntry (mkFastEntryLabel id arity) arity arg_regs
where
- (arg_regs, _) = assignRegs live_regs (take arity arg_kinds)
+ (arg_regs, _) = assignRegs isw_chkr live_regs (take arity arg_kinds)
live_regs = if node_points then [node] else []
LFCon con zero_arity
LFLetNoEscape arity _
-> ASSERT(arity == length arg_kinds)
- DirectEntry (mkFastEntryLabel id arity) arity arg_regs
+ DirectEntry (mkStdEntryLabel id) arity arg_regs
where
- (arg_regs, _) = assignRegs live_regs arg_kinds
+ (arg_regs, _) = assignRegs isw_chkr live_regs arg_kinds
live_regs = if node_points then [node] else []
)
= case lf_info of
LFCon data_con _ -> getDataConTag data_con - fIRST_TAG
LFTuple _ _ -> 0
- LFIndirection -> fromInteger iND_TAG
+ --UNUSED: LFIndirection -> fromInteger iND_TAG
_ -> fromInteger oTHER_TAG
\end{code}
-- Ditto for selectors
-}
- other -> if isStaticRep rep
+ other -> {-NO: if isStaticRep rep
then mkStaticInfoTableLabel id
- else mkInfoTableLabel id
+ else -} mkInfoTableLabel id
mkConInfoPtr :: Id -> SMRep -> CLabel
mkConInfoPtr id rep =
LFTuple _ _ -> SLIT("ALLOC_CON")
LFThunk _ _ _ _ -> SLIT("ALLOC_THK")
LFBlackHole -> SLIT("ALLOC_BH")
- LFIndirection -> panic "ALLOC_IND"
+ --UNUSED: LFIndirection -> panic "ALLOC_IND"
LFImported -> panic "ALLOC_IMP"
\end{code}
\begin{code}
-dataConLiveness (MkClosureInfo con _ PhantomRep)
- = case dataReturnConvAlg con of
+dataConLiveness isw_chkr (MkClosureInfo con _ PhantomRep)
+ = case (dataReturnConvAlg isw_chkr con) of
ReturnInRegs regs -> mkLiveRegsBitMask regs
ReturnInHeap -> panic "dataConLiveness:PhantomRep in heap???"
-dataConLiveness _ = mkLiveRegsBitMask [node]
+dataConLiveness _ _ = mkLiveRegsBitMask [node]
\end{code}
%************************************************************************
LFTuple _ _ -> "CON_K"
LFThunk _ _ _ _ -> "THK_K"
LFBlackHole -> "THK_K" -- consider BHs as thunks for the moment... (ToDo?)
- LFIndirection -> panic "IND_KIND"
+ --UNUSED: LFIndirection -> panic "IND_KIND"
LFImported -> panic "IMP_KIND"
closureTypeDescr :: ClosureInfo -> String
import CmdLineOpts(GlobalSwitch, SwitchResult)
import CostCentre(CostCentre)
import FiniteMap(FiniteMap)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Maybes(Labda)
import PreludePS(_PackedString)
import PrimOps(PrimOp)
import TyCon(TyCon)
import UniType(UniType)
import UniqFM(UniqFM)
-import Unique(Unique)
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
-data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data AbstractC
+data FiniteMap a b
+data Id
+data StgBinding a b
+data UniqFM a
codeGen :: _PackedString -> ([CostCentre], [CostCentre]) -> [_PackedString] -> (GlobalSwitch -> SwitchResult) -> [TyCon] -> FiniteMap TyCon [[Labda UniType]] -> [StgBinding Id Id] -> AbstractC
- {-# GHC_PRAGMA _A_ 7 _U_ 2112112 _N_ _S_ "LU(LL)LSLLL" _N_ _N_ #-}
import CgCon ( cgTopRhsCon )
import CgConTbls ( genStaticConBits, TCE(..), UniqFM )
import ClosureInfo ( LambdaFormInfo, mkClosureLFInfo )
-import CmdLineOpts ( GlobalSwitch(..), switchIsOn, stringSwitchSet, SwitchResult )
+import CmdLineOpts
import FiniteMap ( FiniteMap )
import Maybes ( Maybe(..) )
+import Pretty -- debugging only
import PrimKind ( getKindSize )
import Util
\end{code}
codeGen mod_name (local_CCs, extern_CCs) import_names sw_lookup_fn gen_tycons tycon_specs stg_pgm
= let
- switch_is_on = switchIsOn sw_lookup_fn
+ switch_is_on = switchIsOn sw_lookup_fn
+ int_switch_set = intSwitchSet sw_lookup_fn
doing_profiling = switch_is_on SccProfilingOn
compiling_prelude = switch_is_on CompilingPrelude
splitting = switch_is_on (EnsureSplittableC (panic "codeGen:esc"))
+
+ cinfo = MkCompInfo switch_is_on int_switch_set mod_name
in
+
+{- OLD:
+ pprTrace "codeGen:" (ppCat [
+ (case (switch_is_on StgDoLetNoEscapes) of
+ False -> ppStr "False?"
+ True -> ppStr "True?"
+ ),
+ (case (int_switch_set ReturnInRegsThreshold) of
+ Nothing -> ppStr "Nothing!"
+ Just n -> ppCat [ppStr "Just", ppInt n]
+ ),
+ (case (int_switch_set UnfoldingUseThreshold) of
+ Nothing -> ppStr "Nothing!"
+ Just n -> ppCat [ppStr "Just", ppInt n]
+ ),
+ (case (int_switch_set UnfoldingCreationThreshold) of
+ Nothing -> ppStr "Nothing!"
+ Just n -> ppCat [ppStr "Just", ppInt n]
+ )
+ ]) $
+-}
if not doing_profiling then
- let
- cinfo = MkCompInfo switch_is_on mod_name
- in
mkAbstractCs [
genStaticConBits cinfo gen_tycons tycon_specs,
initC cinfo (cgTopBindings splitting stg_pgm) ]
-- into the code-generator, as are the imported-modules' names.)
--
-- Note: we don't register/etc if compiling Prelude bits.
- let
- cinfo = MkCompInfo switch_is_on mod_name
- in
+
mkAbstractCs [
if compiling_prelude
then AbsCNop
data SMSpecRepKind = SpecRep | ConstantRep | CharLikeRep | IntLikeRep
data SMUpdateKind = SMNormalForm | SMSingleEntry | SMUpdatable
getSMInfoStr :: SMRep -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getSMInitHdrStr :: SMRep -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getSMUpdInplaceHdrStr :: SMRep -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
ltSMRepHdr :: SMRep -> SMRep -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq SMRep
- {-# GHC_PRAGMA _M_ SMRep {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(SMRep -> SMRep -> Bool), (SMRep -> SMRep -> Bool)] [_CONSTM_ Eq (==) (SMRep), _CONSTM_ Eq (/=) (SMRep)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Ord SMRep
- {-# GHC_PRAGMA _M_ SMRep {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq SMRep}}, (SMRep -> SMRep -> Bool), (SMRep -> SMRep -> Bool), (SMRep -> SMRep -> Bool), (SMRep -> SMRep -> Bool), (SMRep -> SMRep -> SMRep), (SMRep -> SMRep -> SMRep), (SMRep -> SMRep -> _CMP_TAG)] [_DFUN_ Eq (SMRep), _CONSTM_ Ord (<) (SMRep), _CONSTM_ Ord (<=) (SMRep), _CONSTM_ Ord (>=) (SMRep), _CONSTM_ Ord (>) (SMRep), _CONSTM_ Ord max (SMRep), _CONSTM_ Ord min (SMRep), _CONSTM_ Ord _tagCmp (SMRep)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: SMRep) (u1 :: SMRep) -> _APP_ _CONSTM_ Ord (<=) (SMRep) [ u1, u0 ] _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: SMRep) (u1 :: SMRep) -> _APP_ _CONSTM_ Ord (<) (SMRep) [ u1, u0 ] _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Outputable SMRep
- {-# GHC_PRAGMA _M_ SMRep {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (SMRep) _N_
- ppr = _A_ 2 _U_ 0220 _N_ _S_ "AL" {_A_ 1 _U_ 220 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Text SMRep
- {-# GHC_PRAGMA _M_ SMRep {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(SMRep, [Char])]), (Int -> SMRep -> [Char] -> [Char]), ([Char] -> [([SMRep], [Char])]), ([SMRep] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (SMRep), _CONSTM_ Text showsPrec (SMRep), _CONSTM_ Text readList (SMRep), _CONSTM_ Text showList (SMRep)] _N_
- readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(SMRep, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 3 _U_ 012 _N_ _S_ "ASL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
-- Used for mutable tuples
Int -- # ptr words
+{- Mattson review:
+
+To: simonpj@dcs.gla.ac.uk, partain@dcs.gla.ac.uk
+Cc: kh@dcs.gla.ac.uk, trinder@dcs.gla.ac.uk, areid@dcs.gla.ac.uk
+Subject: Correct me if I'm wrong...
+Date: Fri, 17 Feb 1995 18:09:00 +0000
+From: Jim Mattson <mattson@dcs.gla.ac.uk>
+
+BigTupleRep == TUPLE
+
+ Never generated by the compiler, and only used in the RTS when
+ mutuples don't require special attention at GC time (e.g. 2s)
+ When it is used, it is a primitive object (never entered).
+ May be mutable...probably should never be used in the parallel
+ system, since we need to distinguish mutables from immutables when
+ deciding whether to copy or move closures across processors.
+
+DataRep == DATA (aka MutableByteArray & ByteArray)
+ Never generated by the compiler, and only used in the RTS for
+ ArrayOfData. Always a primitive object (never entered). May
+ be mutable...though we don't distinguish between mutable and
+ immutable data arrays in the sequential world, it would probably
+ be useful in the parallel world to know when it is safe to just
+ copy one of these. I believe the hooks are in place for changing
+ the InfoPtr on a MutableByteArray when it's frozen to a ByteArray
+ if we want to do so.
+
+DynamicRep == DYN
+ Never generated by the compiler, and only used in the RTS for
+ PAPs and the Stable Pointer table. PAPs are non-primitive,
+ non-updatable, normal-form objects, but the SPT is a primitive,
+ mutable object. At the moment, there is no SPT in the parallel
+ world. Presumably, it would be possible to have an SPT on each
+ processor, and we could identify a stable pointer as a (processor,
+ SPT-entry) pair, but would it be worth it?
+
+MuTupleRep == MUTUPLE
+ Never generated by the compiler, and only used in the RTS when
+ mutuples *do* require special attention at GC time.
+ When it is used, it is a primitive object (never entered).
+ Always mutable...there is an IMMUTUPLE in the RTS, but no
+ corresponding type in the compiler.
+
+--jim
+-}
+
instance Eq SMRep where
(SpecialisedRep k1 a1 b1 _) == (SpecialisedRep k2 a2 b2 _) = (tagOf_SMSpecRepKind k1) _EQ_ (tagOf_SMSpecRepKind k2)
&& a1 == a2 && b1 == b2
tagOf_SMRep (MuTupleRep _) = ILIT(9)
instance Text SMRep where
- showsPrec d rep rest
- = (case rep of
+ showsPrec d rep
+ = showString (case rep of
StaticRep _ _ -> "STATIC"
SpecialisedRep kind _ _ SMNormalForm -> "SPEC_N"
SpecialisedRep kind _ _ SMSingleEntry -> "SPEC_S"
GenericRep _ _ SMNormalForm -> "GEN_N"
GenericRep _ _ SMSingleEntry -> "GEN_S"
GenericRep _ _ SMUpdatable -> "GEN_U"
- BigTupleRep _ -> "TUPLE"
- DataRep _ -> "DATA"
- DynamicRep -> "DYN"
- BlackHoleRep -> "BH"
- PhantomRep -> "INREGS"
- MuTupleRep _ -> "MUTUPLE") ++ rest
+ BigTupleRep _ -> "TUPLE"
+ DataRep _ -> "DATA"
+ DynamicRep -> "DYN"
+ BlackHoleRep -> "BH"
+ PhantomRep -> "INREGS"
+ MuTupleRep _ -> "MUTUPLE")
instance Outputable SMRep where
ppr sty rep = ppStr (show rep)
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface AnnCoreSyn where
import BasicLit(BasicLit)
-import Class(Class)
import CoreSyn(CoreAtom, CoreExpr)
-import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
-import Maybes(Labda)
-import NameTypes(FullName, ShortName)
+import CostCentre(CostCentre)
+import Id(Id)
import Outputable(NamedThing, Outputable)
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
import PrimKind(PrimKind)
import PrimOps(PrimOp)
-import TyCon(TyCon, cmpTyCon)
-import TyVar(TyVar, TyVarTemplate, cmpTyVar)
-import UniType(UniType, cmpUniType)
-import Unique(Unique)
+import TyCon(TyCon)
+import TyVar(TyVar)
+import UniType(UniType)
data AnnCoreBinding a b c = AnnCoNonRec a (c, AnnCoreExpr' a b c) | AnnCoRec [(a, (c, AnnCoreExpr' a b c))]
data AnnCoreCaseAlternatives a b c = AnnCoAlgAlts [(Id, [a], (c, AnnCoreExpr' a b c))] (AnnCoreCaseDefault a b c) | AnnCoPrimAlts [(BasicLit, (c, AnnCoreExpr' a b c))] (AnnCoreCaseDefault a b c)
data AnnCoreCaseDefault a b c = AnnCoNoDefault | AnnCoBindDefault a (c, AnnCoreExpr' a b c)
type AnnCoreExpr a b c = (c, AnnCoreExpr' a b c)
data AnnCoreExpr' a b c = AnnCoVar b | AnnCoLit BasicLit | AnnCoCon Id [UniType] [CoreAtom b] | AnnCoPrim PrimOp [UniType] [CoreAtom b] | AnnCoLam [a] (c, AnnCoreExpr' a b c) | AnnCoTyLam TyVar (c, AnnCoreExpr' a b c) | AnnCoApp (c, AnnCoreExpr' a b c) (CoreAtom b) | AnnCoTyApp (c, AnnCoreExpr' a b c) UniType | AnnCoCase (c, AnnCoreExpr' a b c) (AnnCoreCaseAlternatives a b c) | AnnCoLet (AnnCoreBinding a b c) (c, AnnCoreExpr' a b c) | AnnCoSCC CostCentre (c, AnnCoreExpr' a b c)
-data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-}
-data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-cmpTyCon :: TyCon -> TyCon -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-cmpTyVar :: TyVar -> TyVar -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-cmpUniType :: Bool -> UniType -> UniType -> Int#
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
+data BasicLit
+data CostCentre
+data Id
+data PrimOp
+data TyCon
+data TyVar
+data UniType
deAnnotate :: (a, AnnCoreExpr' b c a) -> CoreExpr b c
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Eq BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool)] [_CONSTM_ Eq (==) (BasicLit), _CONSTM_ Eq (/=) (BasicLit)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq PrimOp
- {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimOp -> PrimOp -> Bool), (PrimOp -> PrimOp -> Bool)] [_CONSTM_ Eq (==) (PrimOp), _CONSTM_ Eq (/=) (PrimOp)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: PrimOp) (u1 :: PrimOp) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u0 ] of { _PRIM_ (u2 :: Int#) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u1 ] of { _PRIM_ (u3 :: Int#) -> _#_ eqInt# [] [u2, u3] } } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Eq TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool)] [_CONSTM_ Eq (==) (TyCon), _CONSTM_ Eq (/=) (TyCon)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool)] [_CONSTM_ Eq (==) (TyVar), _CONSTM_ Eq (/=) (TyVar)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq UniType
- {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UniType -> UniType -> Bool), (UniType -> UniType -> Bool)] [_CONSTM_ Eq (==) (UniType), _CONSTM_ Eq (/=) (UniType)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq BasicLit}}, (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> _CMP_TAG)] [_DFUN_ Eq (BasicLit), _CONSTM_ Ord (<) (BasicLit), _CONSTM_ Ord (<=) (BasicLit), _CONSTM_ Ord (>=) (BasicLit), _CONSTM_ Ord (>) (BasicLit), _CONSTM_ Ord max (BasicLit), _CONSTM_ Ord min (BasicLit), _CONSTM_ Ord _tagCmp (BasicLit)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyCon}}, (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> _CMP_TAG)] [_DFUN_ Eq (TyCon), _CONSTM_ Ord (<) (TyCon), _CONSTM_ Ord (<=) (TyCon), _CONSTM_ Ord (>=) (TyCon), _CONSTM_ Ord (>) (TyCon), _CONSTM_ Ord max (TyCon), _CONSTM_ Ord min (TyCon), _CONSTM_ Ord _tagCmp (TyCon)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVar}}, (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> _CMP_TAG)] [_DFUN_ Eq (TyVar), _CONSTM_ Ord (<) (TyVar), _CONSTM_ Ord (<=) (TyVar), _CONSTM_ Ord (>=) (TyVar), _CONSTM_ Ord (>) (TyVar), _CONSTM_ Ord max (TyVar), _CONSTM_ Ord min (TyVar), _CONSTM_ Ord _tagCmp (TyVar)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance NamedThing TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyCon -> ExportFlag), (TyCon -> Bool), (TyCon -> (_PackedString, _PackedString)), (TyCon -> _PackedString), (TyCon -> [_PackedString]), (TyCon -> SrcLoc), (TyCon -> Unique), (TyCon -> Bool), (TyCon -> UniType), (TyCon -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyCon), _CONSTM_ NamedThing isLocallyDefined (TyCon), _CONSTM_ NamedThing getOrigName (TyCon), _CONSTM_ NamedThing getOccurrenceName (TyCon), _CONSTM_ NamedThing getInformingModules (TyCon), _CONSTM_ NamedThing getSrcLoc (TyCon), _CONSTM_ NamedThing getTheUnique (TyCon), _CONSTM_ NamedThing hasType (TyCon), _CONSTM_ NamedThing getType (TyCon), _CONSTM_ NamedThing fromPreludeCore (TyCon)] _N_
- getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getTheUnique = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Unique } [ _NOREP_S_ "NamedThing.TyCon.getTheUnique" ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> Bool) } [ _NOREP_S_ "NamedThing.TyCon.hasType", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> UniType) } [ _NOREP_S_ "NamedThing.TyCon.getType", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
instance NamedThing TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVar -> ExportFlag), (TyVar -> Bool), (TyVar -> (_PackedString, _PackedString)), (TyVar -> _PackedString), (TyVar -> [_PackedString]), (TyVar -> SrcLoc), (TyVar -> Unique), (TyVar -> Bool), (TyVar -> UniType), (TyVar -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVar), _CONSTM_ NamedThing isLocallyDefined (TyVar), _CONSTM_ NamedThing getOrigName (TyVar), _CONSTM_ NamedThing getOccurrenceName (TyVar), _CONSTM_ NamedThing getInformingModules (TyVar), _CONSTM_ NamedThing getSrcLoc (TyVar), _CONSTM_ NamedThing getTheUnique (TyVar), _CONSTM_ NamedThing hasType (TyVar), _CONSTM_ NamedThing getType (TyVar), _CONSTM_ NamedThing fromPreludeCore (TyVar)] _N_
- getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ _ORIG_ Outputable NotExported [] [] _N_,
- isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ True [] [] _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVar" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar UserTyVar (u1 :: Unique) (u2 :: ShortName) -> case u2 of { _ALG_ _ORIG_ NameTypes ShortName (u3 :: _PackedString) (u4 :: SrcLoc) -> u4; _NO_DEFLT_ }; (u5 :: TyVar) -> _ORIG_ SrcLoc mkUnknownSrcLoc } _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar PolySysTyVar (u1 :: Unique) -> u1; _ORIG_ TyVar PrimSysTyVar (u2 :: Unique) -> u2; _ORIG_ TyVar OpenSysTyVar (u3 :: Unique) -> u3; _ORIG_ TyVar UserTyVar (u4 :: Unique) (u5 :: ShortName) -> u4; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ False [] [] _N_ #-}
instance Outputable BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BasicLit) _N_
- ppr = _A_ 0 _U_ 2122 _N_ _N_ _N_ _N_ #-}
instance Outputable PrimOp
- {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ #-}
instance Outputable TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyCon) _N_
- ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVar) _N_
- ppr = _A_ 2 _U_ 1122 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable UniType
- {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface CoreFuns where
import BasicLit(BasicLit)
-import Class(Class)
import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
+import Id(Id)
import IdEnv(IdEnv(..))
-import IdInfo(IdInfo)
import Maybes(Labda)
import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import TyVar(TyVar)
import TyVarEnv(TyVarEnv(..))
import UniType(UniType)
import UniqFM(UniqFM)
import Unique(UniqSM(..), Unique, UniqueSupply)
-data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data CoreAtom a
+data CoreExpr a b
+data Id
type IdEnv a = UniqFM a
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
+data Labda a
type TyVarEnv a = UniqFM a
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data UniType
+data UniqFM a
type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
-data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-}
+data Unique
+data UniqueSupply
atomToExpr :: CoreAtom b -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: CoreAtom u1) -> case u2 of { _ALG_ _ORIG_ CoreSyn CoVarAtom (u3 :: u1) -> _!_ _ORIG_ CoreSyn CoVar [u0, u1] [u3]; _ORIG_ CoreSyn CoLitAtom (u4 :: BasicLit) -> _!_ _ORIG_ CoreSyn CoLit [u0, u1] [u4]; _NO_DEFLT_ } _N_ #-}
bindersOf :: CoreBinding b a -> [b]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
coreExprArity :: (Id -> Labda (CoreExpr a Id)) -> CoreExpr a Id -> Int
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
digForLambdas :: CoreExpr a b -> ([TyVar], [a], CoreExpr a b)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
escErrorMsg :: [Char] -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
exprSmallEnoughToDup :: CoreExpr a Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
instCoreBindings :: UniqueSupply -> [CoreBinding Id Id] -> (UniqueSupply, [CoreBinding Id Id])
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
instCoreExpr :: UniqueSupply -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
isWrapperFor :: CoreExpr Id Id -> Id -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
manifestlyBottom :: CoreExpr a Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
manifestlyWHNF :: CoreExpr a Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
maybeErrorApp :: CoreExpr a Id -> Labda UniType -> Labda (CoreExpr a Id)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ #-}
mkCoApps :: CoreExpr Id Id -> [CoreExpr Id Id] -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id)
- {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-}
mkCoLam :: [a] -> CoreExpr a b -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
mkCoLetAny :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
mkCoLetNoUnboxed :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
mkCoLetUnboxedToCase :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
mkCoLetrecAny :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
mkCoLetrecNoUnboxed :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
mkCoLetsAny :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: [CoreBinding Id Id]) (u1 :: CoreExpr Id Id) -> case u0 of { _ALG_ (:) (u2 :: CoreBinding Id Id) (u3 :: [CoreBinding Id Id]) -> _APP_ _TYAPP_ _TYAPP_ foldr { (CoreBinding Id Id) } { (CoreExpr Id Id) } [ _ORIG_ CoreFuns mkCoLetAny, u1, u0 ]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-}
mkCoLetsNoUnboxed :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: [CoreBinding Id Id]) (u1 :: CoreExpr Id Id) -> case u0 of { _ALG_ (:) (u2 :: CoreBinding Id Id) (u3 :: [CoreBinding Id Id]) -> _APP_ _TYAPP_ _TYAPP_ foldr { (CoreBinding Id Id) } { (CoreExpr Id Id) } [ _ORIG_ CoreFuns mkCoLetNoUnboxed, u1, u0 ]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-}
mkCoLetsUnboxedToCase :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: [CoreBinding Id Id]) (u1 :: CoreExpr Id Id) -> case u0 of { _ALG_ (:) (u2 :: CoreBinding Id Id) (u3 :: [CoreBinding Id Id]) -> _APP_ _TYAPP_ _TYAPP_ foldr { (CoreBinding Id Id) } { (CoreExpr Id Id) } [ _ORIG_ CoreFuns mkCoLetUnboxedToCase, u1, u0 ]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-}
mkCoTyApps :: CoreExpr a b -> [UniType] -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
mkCoTyLam :: [TyVar] -> CoreExpr a b -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
mkCoreIfThenElse :: CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLL" _N_ _N_ #-}
mkErrorCoApp :: UniType -> Id -> [Char] -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
mkFunction :: [TyVar] -> [a] -> CoreExpr a b -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-}
nonErrorRHSs :: CoreCaseAlternatives a Id -> [CoreExpr a Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
pairsFromCoreBinds :: [CoreBinding a b] -> [(a, CoreExpr a b)]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-}
substCoreExpr :: UniqueSupply -> UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id)
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "LSLL" _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: UniqueSupply) (u1 :: UniqFM (CoreExpr Id Id)) (u2 :: UniqFM UniType) (u3 :: CoreExpr Id Id) -> _APP_ _ORIG_ CoreFuns substCoreExprUS [ u1, u2, u3, u0 ] _N_ #-}
substCoreExprUS :: UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id)
- {-# GHC_PRAGMA _A_ 3 _U_ 2222 _N_ _S_ "SLL" _N_ _N_ #-}
typeOfCoreAlts :: CoreCaseAlternatives Id Id -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
typeOfCoreExpr :: CoreExpr Id Id -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
unTagBinders :: CoreExpr (Id, a) b -> CoreExpr Id b
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
unTagBindersAlts :: CoreCaseAlternatives (Id, a) b -> CoreCaseAlternatives Id b
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
import BasicLit(BasicLit)
import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import PlainCore(PlainCoreBinding(..), PlainCoreExpr(..))
import PrimOps(PrimOp)
import SplitUniq(SplitUniqSupply)
import TyVar(TyVar)
import UniType(UniType)
import Unique(Unique)
-data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data CoreBinding a b
+data CoreExpr a b
+data Id
type PlainCoreBinding = CoreBinding Id Id
type PlainCoreExpr = CoreExpr Id Id
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data SplitUniqSupply
+data Unique
applyBindUnlifts :: [CoreExpr Id Id -> CoreExpr Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
bindUnlift :: Id -> Id -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
liftCoreBindings :: SplitUniqSupply -> [CoreBinding Id Id] -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-}
liftExpr :: Id -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
mkLiftedId :: Id -> Unique -> (Id, Id)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
interface CoreLint where
import CmdLineOpts(GlobalSwitch)
import CoreSyn(CoreBinding, CoreExpr)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import PlainCore(PlainCoreBinding(..))
import Pretty(PprStyle)
import SrcLoc(SrcLoc)
-import UniType(UniType)
-import Unique(Unique)
-data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data CoreBinding a b
+data Id
type PlainCoreBinding = CoreBinding Id Id
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data PprStyle
lintCoreBindings :: PprStyle -> [Char] -> Bool -> [CoreBinding Id Id] -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _S_ "LLLS" _N_ _N_ #-}
lintUnfolding :: SrcLoc -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
interface CoreSyn where
import BasicLit(BasicLit)
import CharSeq(CSeq)
-import Class(Class)
import CmdLineOpts(GlobalSwitch)
-import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import CostCentre(CostCentre)
+import Id(Id)
import Maybes(Labda)
-import NameTypes(FullName, ShortName)
import Outputable(Outputable)
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
import PrimKind(PrimKind)
import PrimOps(PrimOp)
import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import TyVar(TyVar)
import UniType(UniType)
-import Unique(Unique)
-data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-}
+data BasicLit
data CoreArg a = TypeArg UniType | ValArg (CoreAtom a)
data CoreAtom a = CoVarAtom a | CoLitAtom BasicLit
data CoreBinding a b = CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)]
data CoreCaseAlternatives a b = CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b)
data CoreCaseDefault a b = CoNoDefault | CoBindDefault a (CoreExpr a b)
data CoreExpr a b = CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b)
-data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data CostCentre
+data Id
+data Labda a
+data PprStyle
+data PrettyRep
+data PrimOp
+data TyCon
+data TyVar
+data UniType
applyToArgs :: CoreExpr a b -> [CoreArg b] -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
collectArgs :: CoreExpr a b -> (CoreExpr a b, [CoreArg b])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
decomposeArgs :: [CoreArg a] -> ([UniType], [CoreAtom a], [CoreArg a])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
mkCoTyApp :: CoreExpr a b -> UniType -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 2 2 XX 3 _/\_ u0 u1 -> \ (u2 :: CoreExpr u0 u1) (u3 :: UniType) -> _!_ _ORIG_ CoreSyn CoTyApp [u0, u1] [u2, u3] _N_ #-}
pprCoreBinding :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreBinding a b -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 2222122 _N_ _S_ "LLLLS" _N_ _N_ #-}
pprCoreExpr :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreExpr a b -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _S_ "LLLLS" _N_ _N_ #-}
instance Outputable a => Outputable (CoreArg a)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (CoreAtom a)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _N_ _N_ #-}
instance (Outputable a, Outputable b) => Outputable (CoreBinding a b)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _F_ _IF_ARGS_ 2 4 XXXX 6 _/\_ u0 u1 -> \ (u2 :: {{Outputable u0}}) (u3 :: {{Outputable u1}}) (u4 :: PprStyle) (u5 :: CoreBinding u0 u1) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ CoreSyn pprCoreBinding { u0 } { u1 } [ u4, u2, u2, u3, u5 ] _N_ #-}
instance (Outputable a, Outputable b) => Outputable (CoreCaseAlternatives a b)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (Outputable a, Outputable b) => Outputable (CoreCaseDefault a b)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (Outputable a, Outputable b) => Outputable (CoreExpr a b)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _F_ _IF_ARGS_ 2 4 XXXX 6 _/\_ u0 u1 -> \ (u2 :: {{Outputable u0}}) (u3 :: {{Outputable u1}}) (u4 :: PprStyle) (u5 :: CoreExpr u0 u1) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ CoreSyn pprCoreExpr { u0 } { u1 } [ u4, u2, u2, u3, u5 ] _N_ #-}
import SimplEnv(UnfoldingGuidance)
import TyCon(TyCon)
calcUnfoldingGuidance :: Bool -> Int -> CoreExpr Id Id -> UnfoldingGuidance
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LLS" _N_ _N_ #-}
mentionedInUnfolding :: (a -> Id) -> CoreExpr a Id -> ([Id], [TyCon], [Class], Bool)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
pprCoreUnfolding :: CoreExpr Id Id -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-}
interface FreeVars where
import AnnCoreSyn(AnnCoreBinding, AnnCoreCaseAlternatives, AnnCoreCaseDefault, AnnCoreExpr', AnnCoreExpr(..))
import BasicLit(BasicLit)
-import Class(Class)
import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import PrimOps(PrimOp)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import TyVar(TyVar)
import UniType(UniType)
import UniqFM(UniqFM)
import UniqSet(IdSet(..), TyVarSet(..), UniqSet(..))
-import Unique(Unique)
-data AnnCoreBinding a b c {-# GHC_PRAGMA AnnCoNonRec a (c, AnnCoreExpr' a b c) | AnnCoRec [(a, (c, AnnCoreExpr' a b c))] #-}
-data AnnCoreCaseAlternatives a b c {-# GHC_PRAGMA AnnCoAlgAlts [(Id, [a], (c, AnnCoreExpr' a b c))] (AnnCoreCaseDefault a b c) | AnnCoPrimAlts [(BasicLit, (c, AnnCoreExpr' a b c))] (AnnCoreCaseDefault a b c) #-}
-data AnnCoreCaseDefault a b c {-# GHC_PRAGMA AnnCoNoDefault | AnnCoBindDefault a (c, AnnCoreExpr' a b c) #-}
+data AnnCoreBinding a b c
+data AnnCoreCaseAlternatives a b c
+data AnnCoreCaseDefault a b c
type AnnCoreExpr a b c = (c, AnnCoreExpr' a b c)
-data AnnCoreExpr' a b c {-# GHC_PRAGMA AnnCoVar b | AnnCoLit BasicLit | AnnCoCon Id [UniType] [CoreAtom b] | AnnCoPrim PrimOp [UniType] [CoreAtom b] | AnnCoLam [a] (c, AnnCoreExpr' a b c) | AnnCoTyLam TyVar (c, AnnCoreExpr' a b c) | AnnCoApp (c, AnnCoreExpr' a b c) (CoreAtom b) | AnnCoTyApp (c, AnnCoreExpr' a b c) UniType | AnnCoCase (c, AnnCoreExpr' a b c) (AnnCoreCaseAlternatives a b c) | AnnCoLet (AnnCoreBinding a b c) (c, AnnCoreExpr' a b c) | AnnCoSCC CostCentre (c, AnnCoreExpr' a b c) #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
+data AnnCoreExpr' a b c
+data CoreExpr a b
type CoreExprWithFVs = (FVInfo, AnnCoreExpr' Id Id FVInfo)
type FVCoreBinding = CoreBinding (Id, UniqFM Id) Id
type FVCoreExpr = CoreExpr (Id, UniqFM Id) Id
data FVInfo = FVInfo (UniqFM Id) (UniqFM TyVar) LeakInfo
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data Id
+data UniType
type IdSet = UniqFM Id
data LeakInfo = MightLeak | LeakFree Int
type TyVarSet = UniqFM TyVar
type UniqSet a = UniqFM a
addTopBindsFVs :: (UniqFM Id -> Id -> Bool) -> [CoreBinding Id Id] -> ([CoreBinding (Id, UniqFM Id) Id], UniqFM Id)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
freeTyVarsOf :: (FVInfo, AnnCoreExpr' Id Id FVInfo) -> UniqFM TyVar
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(ASA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniqFM TyVar) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: (FVInfo, AnnCoreExpr' Id Id FVInfo)) -> case u0 of { _ALG_ _TUP_2 (u1 :: FVInfo) (u2 :: AnnCoreExpr' Id Id FVInfo) -> case u1 of { _ALG_ _ORIG_ FreeVars FVInfo (u3 :: UniqFM Id) (u4 :: UniqFM TyVar) (u5 :: LeakInfo) -> u4; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
freeVars :: CoreExpr Id Id -> (FVInfo, AnnCoreExpr' Id Id FVInfo)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
freeVarsOf :: (FVInfo, AnnCoreExpr' Id Id FVInfo) -> UniqFM Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(SAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniqFM Id) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: (FVInfo, AnnCoreExpr' Id Id FVInfo)) -> case u0 of { _ALG_ _TUP_2 (u1 :: FVInfo) (u2 :: AnnCoreExpr' Id Id FVInfo) -> case u1 of { _ALG_ _ORIG_ FreeVars FVInfo (u3 :: UniqFM Id) (u4 :: UniqFM TyVar) (u5 :: LeakInfo) -> u3; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
interface PlainCore where
import Bag(Bag)
import BasicLit(BasicLit)
-import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
+import BinderInfo(BinderInfo)
import CharSeq(CSeq)
-import Class(Class, ClassOp, cmpClass)
+import Class(Class)
import CmdLineOpts(GlobalSwitch)
import CoreFuns(atomToExpr, bindersOf, coreExprArity, digForLambdas, escErrorMsg, exprSmallEnoughToDup, instCoreBindings, instCoreExpr, isWrapperFor, manifestlyBottom, manifestlyWHNF, maybeErrorApp, mkCoApps, mkCoLam, mkCoLetAny, mkCoLetNoUnboxed, mkCoLetUnboxedToCase, mkCoLetrecAny, mkCoLetrecNoUnboxed, mkCoLetsAny, mkCoLetsNoUnboxed, mkCoLetsUnboxedToCase, mkCoTyApps, mkCoTyLam, mkCoreIfThenElse, mkErrorCoApp, mkFunction, nonErrorRHSs, pairsFromCoreBinds, squashableDictishCcExpr, substCoreExpr, substCoreExprUS, typeOfCoreAlts, typeOfCoreExpr)
import CoreSyn(CoreArg(..), CoreAtom(..), CoreBinding(..), CoreCaseAlternatives(..), CoreCaseDefault(..), CoreExpr(..), applyToArgs, collectArgs, decomposeArgs, mkCoTyApp, pprCoreExpr)
import CoreUnfold(calcUnfoldingGuidance, mentionedInUnfolding, pprCoreUnfolding)
-import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC)
+import CostCentre(CostCentre)
import FreeVars(FVCoreBinding(..), FVCoreExpr(..), addTopBindsFVs)
-import Id(Id, IdDetails)
+import Id(Id)
import IdEnv(IdEnv(..))
-import IdInfo(ArgUsageInfo, ArityInfo, DeforestInfo, Demand, DemandInfo, FBTypeInfo, IdInfo, SpecEnv, StrictnessInfo, UpdateInfo)
-import InstEnv(InstTemplate)
+import IdInfo(Demand, IdInfo)
import Maybes(Labda)
-import NameTypes(FullName, Provenance, ShortName)
+import NameTypes(FullName)
import Outputable(ExportFlag, NamedThing(..), Outputable(..))
import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind)
import PrimOps(PrimOp)
-import SimplEnv(UnfoldingDetails, UnfoldingGuidance)
-import SplitUniq(SplitUniqSupply)
+import SimplEnv(UnfoldingGuidance)
import SrcLoc(SrcLoc)
import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import TyVar(TyVar)
import TyVarEnv(TyVarEnv(..), TypeEnv(..))
-import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType, cmpUniType)
+import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType)
import UniqFM(UniqFM)
import UniqSet(IdSet(..), UniqSet(..))
-import Unique(UniqSM(..), Unique, UniqueSupply, initUs)
+import Unique(UniqSM(..), Unique, UniqueSupply)
class NamedThing a where
getExportFlag :: a -> ExportFlag
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-}
isLocallyDefined :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-}
getOrigName :: a -> (_PackedString, _PackedString)
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-}
getOccurrenceName :: a -> _PackedString
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-}
getInformingModules :: a -> [_PackedString]
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-}
getSrcLoc :: a -> SrcLoc
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-}
getTheUnique :: a -> Unique
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-}
hasType :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-}
getType :: a -> UniType
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-}
fromPreludeCore :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-}
class Outputable a where
ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_
- {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-}
-data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-}
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
+data Bag a
+data BasicLit
+data BinderInfo
+data Class
data CoreArg a = TypeArg UniType | ValArg (CoreAtom a)
data CoreAtom a = CoVarAtom a | CoLitAtom BasicLit
data CoreBinding a b = CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)]
data CoreCaseAlternatives a b = CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b)
data CoreCaseDefault a b = CoNoDefault | CoBindDefault a (CoreExpr a b)
data CoreExpr a b = CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b)
-data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-}
+data CostCentre
type FVCoreBinding = CoreBinding (Id, UniqFM Id) Id
type FVCoreExpr = CoreExpr (Id, UniqFM Id) Id
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
type IdEnv a = UniqFM a
-data Demand {-# GHC_PRAGMA WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum #-}
-data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-}
-data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-}
+data Demand
+data IdInfo
+data Labda a
+data FullName
+data ExportFlag
type PlainCoreArg = CoreArg Id
type PlainCoreAtom = CoreAtom Id
type PlainCoreBinding = CoreBinding Id Id
type PlainCoreCaseDefault = CoreCaseDefault Id Id
type PlainCoreExpr = CoreExpr Id Id
type PlainCoreProgram = [CoreBinding Id Id]
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
-data UnfoldingGuidance {-# GHC_PRAGMA UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
+data PrettyRep
+data PrimOp
+data UnfoldingGuidance
+data SrcLoc
+data TyCon
+data TyVar
type TyVarEnv a = UniqFM a
type TypeEnv = UniqFM UniType
type SigmaType = UniType
type TauType = UniType
type ThetaType = [(Class, UniType)]
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data UniType
+data UniqFM a
type IdSet = UniqFM Id
type UniqSet a = UniqFM a
type UniqSM a = UniqueSupply -> (UniqueSupply, a)
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
-data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-}
-cmpClass :: Class -> Class -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+data Unique
+data UniqueSupply
atomToExpr :: CoreAtom b -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: CoreAtom u1) -> case u2 of { _ALG_ _ORIG_ CoreSyn CoVarAtom (u3 :: u1) -> _!_ _ORIG_ CoreSyn CoVar [u0, u1] [u3]; _ORIG_ CoreSyn CoLitAtom (u4 :: BasicLit) -> _!_ _ORIG_ CoreSyn CoLit [u0, u1] [u4]; _NO_DEFLT_ } _N_ #-}
bindersOf :: CoreBinding b a -> [b]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
coreExprArity :: (Id -> Labda (CoreExpr a Id)) -> CoreExpr a Id -> Int
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
digForLambdas :: CoreExpr a b -> ([TyVar], [a], CoreExpr a b)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
escErrorMsg :: [Char] -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
exprSmallEnoughToDup :: CoreExpr a Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
instCoreBindings :: UniqueSupply -> [CoreBinding Id Id] -> (UniqueSupply, [CoreBinding Id Id])
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
instCoreExpr :: UniqueSupply -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
isWrapperFor :: CoreExpr Id Id -> Id -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
manifestlyBottom :: CoreExpr a Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
manifestlyWHNF :: CoreExpr a Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
maybeErrorApp :: CoreExpr a Id -> Labda UniType -> Labda (CoreExpr a Id)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ #-}
mkCoApps :: CoreExpr Id Id -> [CoreExpr Id Id] -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id)
- {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-}
mkCoLam :: [a] -> CoreExpr a b -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
mkCoLetAny :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
mkCoLetNoUnboxed :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
mkCoLetUnboxedToCase :: CoreBinding Id Id -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
mkCoLetrecAny :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
mkCoLetrecNoUnboxed :: [(Id, CoreExpr Id Id)] -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
mkCoLetsAny :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: [CoreBinding Id Id]) (u1 :: CoreExpr Id Id) -> case u0 of { _ALG_ (:) (u2 :: CoreBinding Id Id) (u3 :: [CoreBinding Id Id]) -> _APP_ _TYAPP_ _TYAPP_ foldr { (CoreBinding Id Id) } { (CoreExpr Id Id) } [ _ORIG_ CoreFuns mkCoLetAny, u1, u0 ]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-}
mkCoLetsNoUnboxed :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: [CoreBinding Id Id]) (u1 :: CoreExpr Id Id) -> case u0 of { _ALG_ (:) (u2 :: CoreBinding Id Id) (u3 :: [CoreBinding Id Id]) -> _APP_ _TYAPP_ _TYAPP_ foldr { (CoreBinding Id Id) } { (CoreExpr Id Id) } [ _ORIG_ CoreFuns mkCoLetNoUnboxed, u1, u0 ]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-}
mkCoLetsUnboxedToCase :: [CoreBinding Id Id] -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: [CoreBinding Id Id]) (u1 :: CoreExpr Id Id) -> case u0 of { _ALG_ (:) (u2 :: CoreBinding Id Id) (u3 :: [CoreBinding Id Id]) -> _APP_ _TYAPP_ _TYAPP_ foldr { (CoreBinding Id Id) } { (CoreExpr Id Id) } [ _ORIG_ CoreFuns mkCoLetUnboxedToCase, u1, u0 ]; _NIL_ -> u1; _NO_DEFLT_ } _N_ #-}
mkCoTyApps :: CoreExpr a b -> [UniType] -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
mkCoTyLam :: [TyVar] -> CoreExpr a b -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
mkCoreIfThenElse :: CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id -> CoreExpr a Id
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLL" _N_ _N_ #-}
mkErrorCoApp :: UniType -> Id -> [Char] -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
mkFunction :: [TyVar] -> [a] -> CoreExpr a b -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-}
nonErrorRHSs :: CoreCaseAlternatives a Id -> [CoreExpr a Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
pairsFromCoreBinds :: [CoreBinding a b] -> [(a, CoreExpr a b)]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-pprBigCoreBinder :: PprStyle -> Id -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
-pprPlainCoreBinding :: PprStyle -> CoreBinding Id Id -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
-pprTypedCoreBinder :: PprStyle -> Id -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
squashableDictishCcExpr :: CostCentre -> CoreExpr a b -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-}
substCoreExpr :: UniqueSupply -> UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> (UniqueSupply, CoreExpr Id Id)
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "LSLL" _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: UniqueSupply) (u1 :: UniqFM (CoreExpr Id Id)) (u2 :: UniqFM UniType) (u3 :: CoreExpr Id Id) -> _APP_ _ORIG_ CoreFuns substCoreExprUS [ u1, u2, u3, u0 ] _N_ #-}
substCoreExprUS :: UniqFM (CoreExpr Id Id) -> UniqFM UniType -> CoreExpr Id Id -> UniqueSupply -> (UniqueSupply, CoreExpr Id Id)
- {-# GHC_PRAGMA _A_ 3 _U_ 2222 _N_ _S_ "SLL" _N_ _N_ #-}
typeOfCoreAlts :: CoreCaseAlternatives Id Id -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
typeOfCoreExpr :: CoreExpr Id Id -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
applyToArgs :: CoreExpr a b -> [CoreArg b] -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
collectArgs :: CoreExpr a b -> (CoreExpr a b, [CoreArg b])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
decomposeArgs :: [CoreArg a] -> ([UniType], [CoreAtom a], [CoreArg a])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
mkCoTyApp :: CoreExpr a b -> UniType -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 2 2 XX 3 _/\_ u0 u1 -> \ (u2 :: CoreExpr u0 u1) (u3 :: UniType) -> _!_ _ORIG_ CoreSyn CoTyApp [u0, u1] [u2, u3] _N_ #-}
pprCoreExpr :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreExpr a b -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _S_ "LLLLS" _N_ _N_ #-}
calcUnfoldingGuidance :: Bool -> Int -> CoreExpr Id Id -> UnfoldingGuidance
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LLS" _N_ _N_ #-}
mentionedInUnfolding :: (a -> Id) -> CoreExpr a Id -> ([Id], [TyCon], [Class], Bool)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
pprCoreUnfolding :: CoreExpr Id Id -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-}
addTopBindsFVs :: (UniqFM Id -> Id -> Bool) -> [CoreBinding Id Id] -> ([CoreBinding (Id, UniqFM Id) Id], UniqFM Id)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
-cmpUniType :: Bool -> UniType -> UniType -> Int#
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
-initUs :: UniqueSupply -> (UniqueSupply -> (UniqueSupply, a)) -> (UniqueSupply, a)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _F_ _IF_ARGS_ 1 2 XX 2 _/\_ u0 -> \ (u1 :: UniqueSupply) (u2 :: UniqueSupply -> (UniqueSupply, u0)) -> _APP_ u2 [ u1 ] _N_ #-}
+pprBigCoreBinder :: PprStyle -> Id -> Int -> Bool -> PrettyRep
+pprPlainCoreBinding :: PprStyle -> CoreBinding Id Id -> Int -> Bool -> PrettyRep
+pprTypedCoreBinder :: PprStyle -> Id -> Int -> Bool -> PrettyRep
instance Eq Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Class -> Class -> Bool), (Class -> Class -> Bool)] [_CONSTM_ Eq (==) (Class), _CONSTM_ Eq (/=) (Class)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ eqInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Eq (/=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Eq Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq Demand
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Demand -> Demand -> Bool), (Demand -> Demand -> Bool)] [_CONSTM_ Eq (==) (Demand), _CONSTM_ Eq (/=) (Demand)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq UniType
- {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UniType -> UniType -> Bool), (UniType -> UniType -> Bool)] [_CONSTM_ Eq (==) (UniType), _CONSTM_ Eq (/=) (UniType)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Ord Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Class}}, (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Class), (Class -> Class -> Class), (Class -> Class -> _CMP_TAG)] [_DFUN_ Eq (Class), _CONSTM_ Ord (<) (Class), _CONSTM_ Ord (<=) (Class), _CONSTM_ Ord (>=) (Class), _CONSTM_ Ord (>) (Class), _CONSTM_ Ord max (Class), _CONSTM_ Ord min (Class), _CONSTM_ Ord _tagCmp (Class)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ ltInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ leInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord Demand
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Demand}}, (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Bool), (Demand -> Demand -> Demand), (Demand -> Demand -> Demand), (Demand -> Demand -> _CMP_TAG)] [_DFUN_ Eq (Demand), _CONSTM_ Ord (<) (Demand), _CONSTM_ Ord (<=) (Demand), _CONSTM_ Ord (>=) (Demand), _CONSTM_ Ord (>) (Demand), _CONSTM_ Ord max (Demand), _CONSTM_ Ord min (Demand), _CONSTM_ Ord _tagCmp (Demand)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Class -> ExportFlag), (Class -> Bool), (Class -> (_PackedString, _PackedString)), (Class -> _PackedString), (Class -> [_PackedString]), (Class -> SrcLoc), (Class -> Unique), (Class -> Bool), (Class -> UniType), (Class -> Bool)] [_CONSTM_ NamedThing getExportFlag (Class), _CONSTM_ NamedThing isLocallyDefined (Class), _CONSTM_ NamedThing getOrigName (Class), _CONSTM_ NamedThing getOccurrenceName (Class), _CONSTM_ NamedThing getInformingModules (Class), _CONSTM_ NamedThing getSrcLoc (Class), _CONSTM_ NamedThing getTheUnique (Class), _CONSTM_ NamedThing hasType (Class), _CONSTM_ NamedThing getType (Class), _CONSTM_ NamedThing fromPreludeCore (Class)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(LLAAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [ub, uc]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(ALSAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAAAS)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ug; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Unique) } [ _NOREP_S_ "NamedThing.Class.getTheUnique", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Bool) } [ _NOREP_S_ "NamedThing.Class.hasType", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> UniType) } [ _NOREP_S_ "NamedThing.Class.getType", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_,
- getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing FullName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(FullName -> ExportFlag), (FullName -> Bool), (FullName -> (_PackedString, _PackedString)), (FullName -> _PackedString), (FullName -> [_PackedString]), (FullName -> SrcLoc), (FullName -> Unique), (FullName -> Bool), (FullName -> UniType), (FullName -> Bool)] [_CONSTM_ NamedThing getExportFlag (FullName), _CONSTM_ NamedThing isLocallyDefined (FullName), _CONSTM_ NamedThing getOrigName (FullName), _CONSTM_ NamedThing getOccurrenceName (FullName), _CONSTM_ NamedThing getInformingModules (FullName), _CONSTM_ NamedThing getSrcLoc (FullName), _CONSTM_ NamedThing getTheUnique (FullName), _CONSTM_ NamedThing hasType (FullName), _CONSTM_ NamedThing getType (FullName), _CONSTM_ NamedThing fromPreludeCore (FullName)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAEAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u4; _NO_DEFLT_ } _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ThisModule -> _!_ True [] []; _ORIG_ NameTypes InventedInThisModule -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LLAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [u1, u2]; _NO_DEFLT_ } _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(ALSAAA)" {_A_ 2 _U_ 11 _N_ _N_ _F_ _IF_ARGS_ 0 2 XC 10 \ (u0 :: _PackedString) (u1 :: Provenance) -> case u1 of { _ALG_ _ORIG_ NameTypes OtherPrelude (u2 :: _PackedString) -> u2; _ORIG_ NameTypes OtherModule (u3 :: _PackedString) (u4 :: [_PackedString]) -> u3; (u5 :: Provenance) -> u0 } _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ExportedByPreludeCore -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_ #-}
instance (Outputable a, Outputable b) => Outputable (a, b)
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-}
instance Outputable Bool
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_
- ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Class) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(AU(LLLLAA)AAAAAAAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable a => Outputable (CoreArg a)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (CoreAtom a)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _N_ _N_ #-}
instance (Outputable a, Outputable b) => Outputable (CoreBinding a b)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _F_ _IF_ARGS_ 2 4 XXXX 6 _/\_ u0 u1 -> \ (u2 :: {{Outputable u0}}) (u3 :: {{Outputable u1}}) (u4 :: PprStyle) (u5 :: CoreBinding u0 u1) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ CoreSyn pprCoreBinding { u0 } { u1 } [ u4, u2, u2, u3, u5 ] _N_ #-}
instance (Outputable a, Outputable b) => Outputable (CoreCaseAlternatives a b)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (Outputable a, Outputable b) => Outputable (CoreCaseDefault a b)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (Outputable a, Outputable b) => Outputable (CoreExpr a b)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _F_ _IF_ARGS_ 2 4 XXXX 6 _/\_ u0 u1 -> \ (u2 :: {{Outputable u0}}) (u3 :: {{Outputable u1}}) (u4 :: PprStyle) (u5 :: CoreExpr u0 u1) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ CoreSyn pprCoreExpr { u0 } { u1 } [ u4, u2, u2, u3, u5 ] _N_ #-}
instance Outputable Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance Outputable Demand
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Demand) _N_
- ppr = _A_ 2 _U_ 0220 _N_ _S_ "AL" {_A_ 1 _U_ 220 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable FullName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (FullName) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LLLLAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable UniType
- {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ #-}
instance Outputable a => Outputable [a]
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Text Demand
- {-# GHC_PRAGMA _M_ IdInfo {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Demand, [Char])]), (Int -> Demand -> [Char] -> [Char]), ([Char] -> [([Demand], [Char])]), ([Demand] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Demand), _CONSTM_ Text showsPrec (Demand), _CONSTM_ Text readList (Demand), _CONSTM_ Text showList (Demand)] _N_
- readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(Demand, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 3 _U_ 222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Demand) (u2 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> Demand -> [Char] -> [Char]) } [ _NOREP_S_ "%DPreludeCore.Text.showsPrec\"", u0, u1, u2 ] _N_,
- readList = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- showList = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
instance Text Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_
- readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_,
- showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface TaggedCore where
import BasicLit(BasicLit)
-import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
-import CharSeq(CSeq)
-import Class(Class)
+import BinderInfo(BinderInfo)
import CmdLineOpts(GlobalSwitch)
import CoreFuns(unTagBinders, unTagBindersAlts)
import CoreSyn(CoreArg(..), CoreAtom(..), CoreBinding(..), CoreCaseAlternatives(..), CoreCaseDefault(..), CoreExpr(..), applyToArgs, collectArgs, decomposeArgs)
-import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
-import Maybes(Labda)
-import NameTypes(FullName, ShortName)
+import CostCentre(CostCentre)
+import Id(Id)
import Outputable(ExportFlag, NamedThing(..), Outputable(..))
import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind)
+import Pretty(PprStyle, Pretty(..), PrettyRep)
import PrimOps(PrimOp)
import SrcLoc(SrcLoc)
import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import TyVar(TyVar)
import UniType(UniType)
import Unique(Unique)
class NamedThing a where
getExportFlag :: a -> ExportFlag
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-}
isLocallyDefined :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-}
getOrigName :: a -> (_PackedString, _PackedString)
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-}
getOccurrenceName :: a -> _PackedString
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-}
getInformingModules :: a -> [_PackedString]
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-}
getSrcLoc :: a -> SrcLoc
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-}
getTheUnique :: a -> Unique
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-}
hasType :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-}
getType :: a -> UniType
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-}
fromPreludeCore :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-}
class Outputable a where
ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_
- {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-}
-data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-}
-data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
+data BasicLit
+data BinderInfo
+data GlobalSwitch
data CoreArg a = TypeArg UniType | ValArg (CoreAtom a)
data CoreAtom a = CoVarAtom a | CoLitAtom BasicLit
data CoreBinding a b = CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)]
data CoreCaseAlternatives a b = CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b)
data CoreCaseDefault a b = CoNoDefault | CoBindDefault a (CoreExpr a b)
data CoreExpr a b = CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b)
-data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data CostCentre
+data Id
+data ExportFlag
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
+data PrettyRep
+data PrimOp
type SimplifiableBinder = (Id, BinderInfo)
type SimplifiableCoreAtom = CoreAtom Id
type SimplifiableCoreBinding = CoreBinding (Id, BinderInfo) Id
type SimplifiableCoreCaseAlternatives = CoreCaseAlternatives (Id, BinderInfo) Id
type SimplifiableCoreCaseDefault = CoreCaseDefault (Id, BinderInfo) Id
type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
+data SrcLoc
type TaggedBinder a = (Id, a)
type TaggedCoreAtom a = CoreAtom Id
type TaggedCoreBinding a = CoreBinding (Id, a) Id
type TaggedCoreCaseAlternatives a = CoreCaseAlternatives (Id, a) Id
type TaggedCoreCaseDefault a = CoreCaseDefault (Id, a) Id
type TaggedCoreExpr a = CoreExpr (Id, a) Id
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data TyCon
+data TyVar
+data UniType
+data Unique
unTagBinders :: CoreExpr (Id, a) b -> CoreExpr Id b
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
unTagBindersAlts :: CoreCaseAlternatives (Id, a) b -> CoreCaseAlternatives Id b
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
applyToArgs :: CoreExpr a b -> [CoreArg b] -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
collectArgs :: CoreExpr a b -> (CoreExpr a b, [CoreArg b])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
decomposeArgs :: [CoreArg a] -> ([UniType], [CoreAtom a], [CoreArg a])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
instance (Outputable a, Outputable b) => Outputable (a, b)
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-}
instance Outputable BinderInfo
- {-# GHC_PRAGMA _M_ BinderInfo {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BinderInfo) _N_
- ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable Bool
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_
- ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable a => Outputable (CoreArg a)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable a => Outputable (CoreAtom a)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _N_ _N_ #-}
instance (Outputable a, Outputable b) => Outputable (CoreBinding a b)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _F_ _IF_ARGS_ 2 4 XXXX 6 _/\_ u0 u1 -> \ (u2 :: {{Outputable u0}}) (u3 :: {{Outputable u1}}) (u4 :: PprStyle) (u5 :: CoreBinding u0 u1) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ CoreSyn pprCoreBinding { u0 } { u1 } [ u4, u2, u2, u3, u5 ] _N_ #-}
instance (Outputable a, Outputable b) => Outputable (CoreCaseAlternatives a b)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (Outputable a, Outputable b) => Outputable (CoreCaseDefault a b)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (Outputable a, Outputable b) => Outputable (CoreExpr a b)
- {-# GHC_PRAGMA _M_ CoreSyn {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _F_ _IF_ARGS_ 2 4 XXXX 6 _/\_ u0 u1 -> \ (u2 :: {{Outputable u0}}) (u3 :: {{Outputable u1}}) (u4 :: PprStyle) (u5 :: CoreExpr u0 u1) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ CoreSyn pprCoreExpr { u0 } { u1 } [ u4, u2, u2, u3, u5 ] _N_ #-}
instance Outputable a => Outputable [a]
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-}
import HsMatches(Match)
import HsPat(TypecheckedPat)
import HsTypes(PolyType)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Inst(Inst)
import PreludePS(_PackedString)
import SplitUniq(SplitUniqSupply)
import SrcLoc(SrcLoc)
import TyVar(TyVar)
import UniType(UniType)
-import Unique(Unique)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-}
-data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-}
-data DsMatchContext {-# GHC_PRAGMA DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc | NoMatchContext #-}
-data DsMatchKind {-# GHC_PRAGMA FunMatch Id | CaseMatch | LambdaMatch | PatBindMatch #-}
-data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-}
-data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-}
-data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
+data Bag a
+data GlobalSwitch
+data SwitchResult
+data CoreBinding a b
+data DsMatchContext
+data DsMatchKind
+data Binds a b
+data Expr a b
+data TypecheckedPat
+data Id
+data SplitUniqSupply
deSugar :: SplitUniqSupply -> (GlobalSwitch -> SwitchResult) -> _PackedString -> (Binds Id TypecheckedPat, Binds Id TypecheckedPat, Binds Id TypecheckedPat, [(Inst, Expr Id TypecheckedPat)]) -> ([CoreBinding Id Id], Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 4 _U_ 1221 _N_ _S_ "LLLU(LLLL)" _N_ _N_ #-}
import TyVar(TyVar)
import UniqFM(UniqFM)
dsBinds :: Binds Id TypecheckedPat -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([CoreBinding Id Id], Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-}
dsInstBinds :: [TyVar] -> [(Inst, Expr Id TypecheckedPat)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([(Id, CoreExpr Id Id)], [(Id, CoreExpr Id Id)]), Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
import UniType(UniType)
import UniqFM(UniqFM)
dsCCall :: _PackedString -> [CoreExpr Id Id] -> Bool -> Bool -> UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 11 _U_ 22222122222 _N_ _S_ "LLLLSU(ALS)LLLLL" _N_ _N_ #-}
import SrcLoc(SrcLoc)
import UniqFM(UniqFM)
dsExpr :: Expr Id TypecheckedPat -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 1 _U_ 2222222 _N_ _S_ "S" _N_ _N_ #-}
import UniType(UniType)
import UniqFM(UniqFM)
dsGRHSs :: UniType -> DsMatchKind -> [TypecheckedPat] -> [GRHS Id TypecheckedPat] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 10 _U_ 2221222222 _N_ _S_ "LLLS" _N_ _N_ #-}
dsGuarded :: GRHSsAndBinds Id TypecheckedPat -> SrcLoc -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 2 _U_ 12222222 _N_ _S_ "SL" _N_ _N_ #-}
import SrcLoc(SrcLoc)
import UniqFM(UniqFM)
dsListComp :: CoreExpr Id Id -> [Qual Id TypecheckedPat] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 2 _U_ 22222222 _N_ _N_ _N_ _N_ #-}
import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
import HsPat(TypecheckedPat)
-import Id(DataCon(..), Id, IdDetails, mkIdWithNewUniq, mkSysLocal)
-import IdEnv(lookupIdEnv)
-import IdInfo(IdInfo)
+import Id(DataCon(..), Id)
import Maybes(Labda)
-import NameTypes(ShortName)
-import Outputable(NamedThing)
import PlainCore(PlainCoreExpr(..))
import PreludePS(_PackedString)
import Pretty(PprStyle, PrettyRep)
import PrimOps(PrimOp)
-import SplitUniq(SplitUniqSupply, getSUnique, splitUniqSupply)
-import SrcLoc(SrcLoc, unpackSrcLoc)
-import TyCon(TyCon)
+import SplitUniq(SplitUniqSupply)
+import SrcLoc(SrcLoc)
import TyVar(TyVar, TyVarTemplate)
import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType)
-import UniqFM(UniqFM, lookupUFM)
-import Unique(UniqSM(..), Unique, UniqueSupply, mkUniqueGrimily, mkUniqueSupplyGrimily)
+import UniqFM(UniqFM)
+import Unique(UniqSM(..), UniqueSupply)
infixr 9 `thenDs`
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
+data GlobalSwitch
+data SwitchResult
+data CoreExpr a b
type DataCon = Id
type DsIdEnv = UniqFM (CoreExpr Id Id)
type DsM a = SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
data DsMatchContext = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc | NoMatchContext
data DsMatchKind = FunMatch Id | CaseMatch | LambdaMatch | PatBindMatch
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
type PlainCoreExpr = CoreExpr Id Id
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
+data SplitUniqSupply
+data SrcLoc
+data TyVar
+data TyVarTemplate
type SigmaType = UniType
type TauType = UniType
type ThetaType = [(Class, UniType)]
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data UniType
type UniqSM a = UniqueSupply -> (UniqueSupply, a)
andDs :: (a -> a -> a) -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 9 _U_ 111122222 _N_ _S_ "LSSU(ALL)LLLLL" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0 -> u0 -> u0) (u2 :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (u0, Bag DsMatchContext)) (u3 :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (u0, Bag DsMatchContext)) (u4 :: SplitUniqSupply) (u5 :: SrcLoc) (u6 :: GlobalSwitch -> SwitchResult) (u7 :: (_PackedString, _PackedString)) (u8 :: UniqFM (CoreExpr Id Id)) (u9 :: Bag DsMatchContext) -> case u4 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ ub, u5, u6, u7, u8, u9 ] of { _ALG_ _TUP_2 (ud :: u0) (ue :: Bag DsMatchContext) -> case _APP_ u3 [ uc, u5, u6, u7, u8, ue ] of { _ALG_ _TUP_2 (uf :: u0) (ug :: Bag DsMatchContext) -> let {(uh :: u0) = _APP_ u1 [ ud, uf ]} in _!_ _TUP_2 [u0, (Bag DsMatchContext)] [uh, ug]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
cloneTyVarsDs :: [TyVar] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([TyVar], Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 7 _U_ 2200002 _N_ _S_ "LLAAAAL" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
dsShadowError :: DsMatchContext -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((), Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 7 _U_ 2000002 _N_ _S_ "LAAAAAL" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 XXXXXXX 9 \ (u0 :: DsMatchContext) (u1 :: SplitUniqSupply) (u2 :: SrcLoc) (u3 :: GlobalSwitch -> SwitchResult) (u4 :: (_PackedString, _PackedString)) (u5 :: UniqFM (CoreExpr Id Id)) (u6 :: Bag DsMatchContext) -> let {(u7 :: ()) = _!_ _TUP_0 [] []} in let {(u8 :: Bag DsMatchContext) = _APP_ _TYAPP_ _ORIG_ Bag snocBag { DsMatchContext } [ u6, u0 ]} in _!_ _TUP_2 [(), (Bag DsMatchContext)] [u7, u8] _N_ #-}
duplicateLocalDs :: Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Id, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 7 _U_ 1100002 _N_ _S_ "LLAAAAL" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
extendEnvDs :: [(Id, CoreExpr Id Id)] -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 8 _U_ 11122222 _N_ _S_ "SSU(ALL)LLLLL" _N_ _N_ #-}
getModuleAndGroupDs :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((_PackedString, _PackedString), Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 6 _U_ 000202 _N_ _S_ "AAALAL" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: (_PackedString, _PackedString)) (u1 :: Bag DsMatchContext) -> _!_ _TUP_2 [(_PackedString, _PackedString), (Bag DsMatchContext)] [u0, u1] _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 3 \ (u0 :: SplitUniqSupply) (u1 :: SrcLoc) (u2 :: GlobalSwitch -> SwitchResult) (u3 :: (_PackedString, _PackedString)) (u4 :: UniqFM (CoreExpr Id Id)) (u5 :: Bag DsMatchContext) -> _!_ _TUP_2 [(_PackedString, _PackedString), (Bag DsMatchContext)] [u3, u5] _N_ #-}
-mkIdWithNewUniq :: Id -> Unique -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(ALLL)L" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-mkSysLocal :: _PackedString -> Unique -> UniType -> SrcLoc -> Id
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
-lookupIdEnv :: UniqFM a -> Id -> Labda a
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-getSUnique :: SplitUniqSupply -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> case u1 of { _ALG_ I# (u4 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u4]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getSrcLocDs :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([Char], [Char]), Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 6 _U_ 010002 _N_ _S_ "ASAAAL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getSwitchCheckerDs :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (GlobalSwitch -> Bool, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 6 _U_ 002002 _N_ _S_ "AALAAL" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 8 \ (u0 :: SplitUniqSupply) (u1 :: SrcLoc) (u2 :: GlobalSwitch -> SwitchResult) (u3 :: (_PackedString, _PackedString)) (u4 :: UniqFM (CoreExpr Id Id)) (u5 :: Bag DsMatchContext) -> let {(u7 :: GlobalSwitch -> Bool) = \ (u6 :: GlobalSwitch) -> _APP_ _TYAPP_ _ORIG_ CmdLineOpts switchIsOn { GlobalSwitch } [ u2, u6 ]} in _!_ _TUP_2 [(GlobalSwitch -> Bool), (Bag DsMatchContext)] [u7, u5] _N_ #-}
ifSwitchSetDs :: GlobalSwitch -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 9 _U_ 211222222 _N_ _S_ "LLLLLSLLL" _N_ _N_ #-}
initDs :: SplitUniqSupply -> UniqFM (CoreExpr Id Id) -> (GlobalSwitch -> SwitchResult) -> _PackedString -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (a, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 5 _U_ 22221 _N_ _S_ "LLLLS" _N_ _N_ #-}
listDs :: [SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([a], Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 7 _U_ 1122222 _N_ _S_ "SLLLLLL" _N_ _N_ #-}
lookupEnvDs :: Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Labda (CoreExpr Id Id), Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 7 _U_ 1000022 _N_ _S_ "LAAAALL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 CXXXXXX 9 \ (u0 :: Id) (u1 :: SplitUniqSupply) (u2 :: SrcLoc) (u3 :: GlobalSwitch -> SwitchResult) (u4 :: (_PackedString, _PackedString)) (u5 :: UniqFM (CoreExpr Id Id)) (u6 :: Bag DsMatchContext) -> let {(uc :: Labda (CoreExpr Id Id)) = case u0 of { _ALG_ _ORIG_ Id Id (u7 :: Unique) (u8 :: UniType) (u9 :: IdInfo) (ua :: IdDetails) -> case u7 of { _ALG_ _ORIG_ Unique MkUnique (ub :: Int#) -> _APP_ _TYAPP_ _WRKR_ _ORIG_ IdEnv lookupIdEnv { (CoreExpr Id Id) } [ u5, ub ]; _NO_DEFLT_ }; _NO_DEFLT_ }} in _!_ _TUP_2 [(Labda (CoreExpr Id Id)), (Bag DsMatchContext)] [uc, u6] _N_ #-}
lookupEnvWithDefaultDs :: Id -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 8 _U_ 11000022 _N_ _S_ "LLAAAALL" {_A_ 4 _U_ 1122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupId :: [(Id, a)] -> Id -> a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _F_ _IF_ARGS_ 1 2 XX 4 _/\_ u0 -> \ (u1 :: [(Id, u0)]) (u2 :: Id) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ Util assoc [ (Id), _N_ ] { u0 } [ _NOREP_S_ "lookupId", u1, u2 ] _N_ #-}
-lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
mapAndUnzipDs :: (a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((b, c), Bag DsMatchContext)) -> [a] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([b], [c]), Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
mapDs :: (a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (b, Bag DsMatchContext)) -> [a] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([b], Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
-mkUniqueGrimily :: Int# -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_ #-}
-mkUniqueSupplyGrimily :: SplitUniqSupply -> UniqueSupply
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: SplitUniqSupply) -> _!_ _ORIG_ Unique MkNewSupply [] [u0] _N_ #-}
newFailLocalDs :: UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Id, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 7 _U_ 2120002 _N_ _N_ _N_ _N_ #-}
newSysLocalDs :: UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (Id, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 7 _U_ 2120002 _N_ _N_ _N_ _N_ #-}
newSysLocalsDs :: [UniType] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([Id], Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _N_ _N_ _N_ #-}
newTyVarsDs :: [TyVarTemplate] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([TyVar], Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 7 _U_ 2200002 _N_ _S_ "LLAAAAL" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
putSrcLocDs :: SrcLoc -> (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 8 _U_ 21202222 _N_ _S_ "LSLALLLL" {_A_ 7 _U_ 2122222 _N_ _N_ _F_ _IF_ARGS_ 1 7 XXXXXXX 7 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (u0, Bag DsMatchContext)) (u3 :: SplitUniqSupply) (u4 :: GlobalSwitch -> SwitchResult) (u5 :: (_PackedString, _PackedString)) (u6 :: UniqFM (CoreExpr Id Id)) (u7 :: Bag DsMatchContext) -> _APP_ u2 [ u3, u1, u4, u5, u6, u7 ] _N_} _F_ _IF_ARGS_ 1 8 XXXXXXXX 7 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (u0, Bag DsMatchContext)) (u3 :: SplitUniqSupply) (u4 :: SrcLoc) (u5 :: GlobalSwitch -> SwitchResult) (u6 :: (_PackedString, _PackedString)) (u7 :: UniqFM (CoreExpr Id Id)) (u8 :: Bag DsMatchContext) -> _APP_ u2 [ u3, u1, u5, u6, u7, u8 ] _N_ #-}
returnDs :: a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 7 _U_ 2000002 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: SplitUniqSupply) (u3 :: SrcLoc) (u4 :: GlobalSwitch -> SwitchResult) (u5 :: (_PackedString, _PackedString)) (u6 :: UniqFM (CoreExpr Id Id)) (u7 :: Bag DsMatchContext) -> _!_ _TUP_2 [u0, (Bag DsMatchContext)] [u1, u7] _N_ #-}
-splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-}
thenDs :: (SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)) -> (a -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (b, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (b, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 8 _U_ 11122222 _N_ _S_ "SSU(ALL)LLLLL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (u0, Bag DsMatchContext)) (u3 :: u0 -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (u1, Bag DsMatchContext)) (u4 :: SplitUniqSupply) (u5 :: SrcLoc) (u6 :: GlobalSwitch -> SwitchResult) (u7 :: (_PackedString, _PackedString)) (u8 :: UniqFM (CoreExpr Id Id)) (u9 :: Bag DsMatchContext) -> case u4 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ ub, u5, u6, u7, u8, u9 ] of { _ALG_ _TUP_2 (ud :: u0) (ue :: Bag DsMatchContext) -> _APP_ u3 [ ud, uc, u5, u6, u7, u8, ue ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
uniqSMtoDsM :: (UniqueSupply -> (UniqueSupply, a)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (a, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 7 _U_ 1200002 _N_ _S_ "LLAAAAL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-unpackSrcLoc :: SrcLoc -> (_PackedString, _PackedString)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
zipWithDs :: (a -> b -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (c, Bag DsMatchContext)) -> [a] -> [b] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([c], Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 3 _U_ 211222222 _N_ _S_ "LSS" _N_ _N_ #-}
data EquationInfo = EqnInfo [TypecheckedPat] MatchResult
data MatchResult = MatchResult CanItFail UniType (CoreExpr Id Id -> CoreExpr Id Id) DsMatchContext
combineGRHSMatchResults :: MatchResult -> MatchResult -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 2 _U_ 11222222 _N_ _S_ "U(ELLL)L" {_A_ 5 _U_ 22221222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
combineMatchResults :: MatchResult -> MatchResult -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 2 _U_ 11222222 _N_ _S_ "U(ELLL)L" {_A_ 5 _U_ 22221222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
dsExprToAtom :: CoreExpr Id Id -> (CoreAtom Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 2 _U_ 22222222 _N_ _S_ "SS" _N_ _N_ #-}
mkCoAlgCaseMatchResult :: Id -> [(Id, [Id], MatchResult)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 2 _U_ 12222222 _N_ _S_ "U(LSLL)L" {_A_ 5 _U_ 22222222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkCoAppDs :: CoreExpr Id Id -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 2 _U_ 22222222 _N_ _S_ "LS" _N_ _N_ #-}
mkCoConDs :: Id -> [UniType] -> [CoreExpr Id Id] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 3 _U_ 221222222 _N_ _S_ "LLS" _N_ _N_ #-}
mkCoLetsMatchResult :: [CoreBinding Id Id] -> MatchResult -> MatchResult
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLLL)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkCoPrimCaseMatchResult :: Id -> [(BasicLit, MatchResult)] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 8 _U_ 22120002 _N_ _S_ "LLU(ALA)LLLLL" _N_ _N_ #-}
mkCoPrimDs :: PrimOp -> [UniType] -> [CoreExpr Id Id] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 3 _U_ 221222222 _N_ _S_ "LLS" _N_ _N_ #-}
mkFailurePair :: UniType -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ((CoreExpr Id Id -> CoreBinding Id Id, CoreExpr Id Id), Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 1 _U_ 2222222 _N_ _S_ "S" _N_ _N_ #-}
mkGuardedMatchResult :: CoreExpr Id Id -> MatchResult -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 8 _U_ 21000002 _N_ _S_ "LU(ALLL)AAAAAL" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkSelectorBinds :: [TyVar] -> TypecheckedPat -> [(Id, Id)] -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([(Id, CoreExpr Id Id)], Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 4 _U_ 2222122222 _N_ _S_ "LSSL" _N_ _N_ #-}
mkTupleBind :: [TyVar] -> [Id] -> [(Id, Id)] -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([(Id, CoreExpr Id Id)], Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 4 _U_ 2222222222 _N_ _S_ "LLSL" _N_ _N_ #-}
mkTupleExpr :: [Id] -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
selectMatchVars :: [TypecheckedPat] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> ([Id], Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-}
import UniType(UniType)
import UniqFM(UniqFM)
match :: [Id] -> [EquationInfo] -> [EquationInfo] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 3 _U_ 222222222 _N_ _S_ "SSS" _N_ _N_ #-}
matchSimply :: CoreExpr Id Id -> TypecheckedPat -> UniType -> CoreExpr Id Id -> CoreExpr Id Id -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (CoreExpr Id Id, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 5 _U_ 22222222222 _N_ _S_ "SLLLL" _N_ _N_ #-}
matchWrapper :: DsMatchKind -> [Match Id TypecheckedPat] -> [Char] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (([Id], CoreExpr Id Id), Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 3 _U_ 222222222 _N_ _S_ "LSL" _N_ _N_ #-}
import SrcLoc(SrcLoc)
import UniqFM(UniqFM)
matchConFamily :: [Id] -> [EquationInfo] -> [EquationInfo] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 3 _U_ 122222222 _N_ _S_ "SSL" _N_ _N_ #-}
import SrcLoc(SrcLoc)
import UniqFM(UniqFM)
matchLiterals :: [Id] -> [EquationInfo] -> [EquationInfo] -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> SwitchResult) -> (_PackedString, _PackedString) -> UniqFM (CoreExpr Id Id) -> Bag DsMatchContext -> (MatchResult, Bag DsMatchContext)
- {-# GHC_PRAGMA _A_ 3 _U_ 222222222 _N_ _S_ "SSL" _N_ _N_ #-}
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
interface Core2Def where
import BinderInfo(BinderInfo)
import CmdLineOpts(GlobalSwitch, SwitchResult)
import CoreSyn(CoreBinding, CoreExpr)
import DefSyn(DefBindee, DefProgram(..))
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import PlainCore(PlainCoreProgram(..))
-import UniType(UniType)
import UniqFM(UniqFM)
-import Unique(Unique)
-data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-}
-data DefBindee {-# GHC_PRAGMA DefArgExpr (CoreExpr Id DefBindee) | DefArgVar Id | Label (CoreExpr Id DefBindee) (CoreExpr Id DefBindee) #-}
+data CoreBinding a b
+data DefBindee
type DefProgram = [CoreBinding Id DefBindee]
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
type PlainCoreProgram = [CoreBinding Id Id]
c2d :: UniqFM (CoreExpr Id DefBindee) -> CoreExpr (Id, BinderInfo) Id -> CoreExpr Id DefBindee
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
core2def :: (GlobalSwitch -> SwitchResult) -> [CoreBinding Id Id] -> [CoreBinding Id DefBindee]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ #-}
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
interface Cyclic where
import CoreSyn(CoreExpr)
import DefSyn(DefBindee)
import Id(Id)
import SplitUniq(SplitUniqSupply)
fixupFreeVars :: [Id] -> Id -> CoreExpr Id DefBindee -> ((Id, CoreExpr Id DefBindee), [(Id, CoreExpr Id DefBindee)])
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLS" _N_ _N_ #-}
mkLoops :: CoreExpr Id DefBindee -> SplitUniqSupply -> ([(Id, CoreExpr Id DefBindee)], CoreExpr Id DefBindee)
- {-# GHC_PRAGMA _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: CoreExpr Id DefBindee) (u1 :: SplitUniqSupply) -> _APP_ _TYAPP_ error { (SplitUniqSupply -> ([(Id, CoreExpr Id DefBindee)], CoreExpr Id DefBindee)) } [ _NOREP_S_ "mkLoops", u1 ] _N_ #-}
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
interface Def2Core where
import CoreSyn(CoreBinding, CoreExpr)
import DefSyn(DefBindee, DefBinding(..))
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import PlainCore(PlainCoreProgram(..))
import SplitUniq(SUniqSM(..), SplitUniqSupply)
-import UniType(UniType)
-import Unique(Unique)
-data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-}
-data DefBindee {-# GHC_PRAGMA DefArgExpr (CoreExpr Id DefBindee) | DefArgVar Id | Label (CoreExpr Id DefBindee) (CoreExpr Id DefBindee) #-}
+data CoreBinding a b
+data DefBindee
type DefBinding = CoreBinding Id DefBindee
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
type PlainCoreProgram = [CoreBinding Id Id]
type SUniqSM a = SplitUniqSupply -> a
d2c :: CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "S" _N_ _N_ #-}
def2core :: [CoreBinding Id DefBindee] -> SplitUniqSupply -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "S" _N_ _N_ #-}
defPanic :: [Char] -> [Char] -> CoreExpr Id DefBindee -> SplitUniqSupply -> a
- {-# GHC_PRAGMA _A_ 3 _U_ 1111 _N_ _S_ _!_ _N_ _N_ #-}
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
interface DefExpr where
import CmdLineOpts(SwitchResult)
import CoreSyn(CoreArg, CoreExpr)
import UniType(UniType)
import UniqFM(UniqFM)
tran :: (a -> SwitchResult) -> UniqFM (CoreExpr Id DefBindee) -> UniqFM UniType -> CoreExpr Id DefBindee -> [CoreArg DefBindee] -> SplitUniqSupply -> CoreExpr Id DefBindee
- {-# GHC_PRAGMA _A_ 5 _U_ 222222 _N_ _S_ "LLLSL" _N_ _N_ #-}
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
interface DefSyn where
import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr)
import Id(Id)
type DefExpr = CoreExpr Id DefBindee
type DefProgram = [CoreBinding Id DefBindee]
mkLabel :: CoreExpr Id DefBindee -> CoreExpr Id DefBindee -> CoreExpr Id DefBindee
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
interface DefUtils where
import CoreSyn(CoreAtom, CoreCaseAlternatives, CoreExpr)
import DefSyn(DefBindee)
import UniType(UniType)
data RenameResult = NotRenaming | IsRenaming [(Id, Id)] | InconsistentRenaming [(Id, Id)]
atom2expr :: CoreAtom DefBindee -> CoreExpr Id DefBindee
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
consistent :: [(Id, Id)] -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
deforestable :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAAAAEAAA)A)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: DeforestInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo DoDeforest -> _!_ True [] []; _ORIG_ IdInfo Don'tDeforest -> _!_ False [] []; _NO_DEFLT_ } _N_} _F_ _ALWAYS_ \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ IdInfo IdInfo (u5 :: ArityInfo) (u6 :: DemandInfo) (u7 :: SpecEnv) (u8 :: StrictnessInfo) (u9 :: UnfoldingDetails) (ua :: UpdateInfo) (ub :: DeforestInfo) (uc :: ArgUsageInfo) (ud :: FBTypeInfo) (ue :: SrcLoc) -> case ub of { _ALG_ _ORIG_ IdInfo DoDeforest -> _!_ True [] []; _ORIG_ IdInfo Don'tDeforest -> _!_ False [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
foldrSUs :: (a -> b -> SplitUniqSupply -> b) -> b -> [a] -> SplitUniqSupply -> b
- {-# GHC_PRAGMA _A_ 3 _U_ 2212 _N_ _S_ "LLS" _N_ _N_ #-}
freeTyVars :: CoreExpr Id DefBindee -> [TyVar]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
freeVars :: CoreExpr Id DefBindee -> [Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isArgId :: Id -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(AAAAAAEAAA)L)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkDefLetrec :: [(a, CoreExpr a b)] -> CoreExpr a b -> CoreExpr a b
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
newDefId :: UniType -> SplitUniqSupply -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(ALA)" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-}
newTmpId :: UniType -> SplitUniqSupply -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(ALA)" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rebindExpr :: CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id DefBindee
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "S" _N_ _N_ #-}
renameExprs :: CoreExpr Id DefBindee -> CoreExpr Id DefBindee -> SplitUniqSupply -> RenameResult
- {-# GHC_PRAGMA _A_ 2 _U_ 222 _N_ _S_ "SS" _N_ _N_ #-}
strip :: CoreExpr Id DefBindee -> CoreExpr Id DefBindee
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
stripAtom :: CoreAtom DefBindee -> CoreAtom DefBindee
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
stripCaseAlts :: CoreCaseAlternatives Id DefBindee -> CoreCaseAlternatives Id DefBindee
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
subst :: [(Id, CoreExpr Id DefBindee)] -> CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id DefBindee
- {-# GHC_PRAGMA _A_ 2 _U_ 212 _N_ _S_ "LS" _N_ _N_ #-}
union :: Eq a => [a] -> [a] -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 212 _N_ _N_ _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SS" _N_ _N_ } #-}
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
interface Deforest where
import CmdLineOpts(GlobalSwitch, SwitchResult)
import CoreSyn(CoreBinding)
import Id(Id)
import SplitUniq(SplitUniqSupply)
deforestProgram :: (GlobalSwitch -> SwitchResult) -> [CoreBinding Id Id] -> SplitUniqSupply -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "SLU(ALL)" {_A_ 4 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+{-# GHC_PRAGMA INTERFACE VERSION 3 #-}
interface TreelessForm where
import CmdLineOpts(SwitchResult)
import CoreSyn(CoreExpr)
import Id(Id)
import SplitUniq(SplitUniqSupply)
convertToTreelessForm :: (a -> SwitchResult) -> CoreExpr Id DefBindee -> SplitUniqSupply -> CoreExpr Id DefBindee
- {-# GHC_PRAGMA _A_ 2 _U_ 012 _N_ _S_ "AS" {_A_ 1 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface CE where
import CharSeq(CSeq)
-import Class(Class, ClassOp)
+import Class(Class)
import CmdLineOpts(GlobalSwitch)
import ErrUtils(Error(..))
import Id(Id)
-import InstEnv(InstTemplate)
import Maybes(MaybeErr)
import Name(Name)
import NameTypes(FullName, ShortName)
import PreludePS(_PackedString)
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM, eltsUFM, emptyUFM, plusUFM, singletonDirectlyUFM)
-import Unique(Unique, u2i)
+import UniqFM(UniqFM)
+import Unique(Unique)
type CE = UniqFM Class
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
+data Class
type Error = PprStyle -> Int -> Bool -> PrettyRep
-data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data MaybeErr a b
+data Name
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data PrettyRep
+data UniqFM a
+data Unique
checkClassCycles :: UniqFM Class -> MaybeErr () (PprStyle -> Int -> Bool -> PrettyRep)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
-eltsUFM :: UniqFM a -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
-emptyUFM :: UniqFM a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
lookupCE :: UniqFM Class -> Name -> Class
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
nullCE :: UniqFM Class
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ UniqFM EmptyUFM [Class] [] _N_ #-}
plusCE :: UniqFM Class -> UniqFM Class -> UniqFM Class
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ UniqFM plusUFM { Class } _N_ #-}
-plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
rngCE :: UniqFM Class -> [Class]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ UniqFM eltsUFM { Class } _N_ #-}
-singletonDirectlyUFM :: Unique -> a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-}
-u2i :: Unique -> Int#
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-}
unitCE :: Unique -> Class -> UniqFM Class
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int#) (u1 :: Class) -> _!_ _ORIG_ UniqFM LeafUFM [Class] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: Unique) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [Class] [u2, u1]; _NO_DEFLT_ } _N_ #-}
interface E where
import CE(CE(..))
import Class(Class)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Maybes(Labda)
import Name(Name)
import NameTypes(FullName, ShortName)
import TCE(TCE(..))
import TyCon(TyCon)
import TyVar(TyVar)
-import UniType(UniType)
import UniqFM(UniqFM)
import Unique(Unique)
type CE = UniqFM Class
-data E {-# GHC_PRAGMA MkE (UniqFM TyCon) (UniqFM Id) (UniqFM Id) (UniqFM Class) #-}
+data E
type GVE = [(Name, Id)]
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
type LVE = [(Name, Id)]
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
+data Labda a
+data Name
type TCE = UniqFM TyCon
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data TyVar
+data UniqFM a
getE_CE :: E -> UniqFM Class
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniqFM Class) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: E) -> case u0 of { _ALG_ _ORIG_ E MkE (u1 :: UniqFM TyCon) (u2 :: UniqFM Id) (u3 :: UniqFM Id) (u4 :: UniqFM Class) -> u4; _NO_DEFLT_ } _N_ #-}
getE_GlobalVals :: E -> [Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASLA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getE_TCE :: E -> UniqFM TyCon
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(SAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniqFM TyCon) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: E) -> case u0 of { _ALG_ _ORIG_ E MkE (u1 :: UniqFM TyCon) (u2 :: UniqFM Id) (u3 :: UniqFM Id) (u4 :: UniqFM Class) -> u1; _NO_DEFLT_ } _N_ #-}
growE_LVE :: E -> [(Name, Id)] -> E
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupE_Binder :: E -> Name -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AASA)S" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupE_ClassOpByKey :: E -> Unique -> _PackedString -> Id
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAS)LL" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupE_Value :: E -> Name -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(ALLA)S" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupE_ValueQuietly :: E -> Name -> Labda Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(ALLA)S" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkE :: UniqFM TyCon -> UniqFM Class -> E
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
nullE :: E
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
nullGVE :: [(Name, Id)]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _NIL_ [(Name, Id)] [] _N_ #-}
nullLVE :: [(Name, Id)]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _NIL_ [(Name, Id)] [] _N_ #-}
plusE_CE :: E -> UniqFM Class -> E
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
plusE_GVE :: E -> [(Name, Id)] -> E
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
plusE_TCE :: E -> UniqFM TyCon -> E
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
plusGVE :: [a] -> [a] -> [a]
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludeList (++) _N_ #-}
plusLVE :: [a] -> [a] -> [a]
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludeList (++) _N_ #-}
tvOfE :: E -> [TyVar]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AASA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
unitGVE :: Name -> Id -> [(Name, Id)]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface IdEnv where
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Maybes(Labda(..))
-import Outputable(NamedThing)
-import UniType(UniType)
-import UniqFM(UniqFM, addToUFM, delFromUFM, delListFromUFM, eltsUFM, emptyUFM, filterUFM, listToUFM, lookupUFM, mapUFM, minusUFM, plusUFM, plusUFM_C, singletonUFM)
-import Unique(Unique, u2i)
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+import UniqFM(UniqFM)
+import Unique(Unique)
+data Id
type IdEnv a = UniqFM a
data Labda a = Hamna | Ni a
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data UniqFM a
+data Unique
addOneToIdEnv :: UniqFM a -> Id -> a -> UniqFM a
- {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "SU(U(P)AAA)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-addToUFM :: NamedThing a => UniqFM b -> a -> b -> UniqFM b
- {-# GHC_PRAGMA _A_ 4 _U_ 1222 _N_ _S_ "U(AAAAAASAAA)SLL" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "SU(U(P)AAA)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
combineIdEnvs :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM plusUFM_C _N_ #-}
-delFromUFM :: NamedThing a => UniqFM b -> a -> UniqFM b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
-delListFromUFM :: NamedThing a => UniqFM b -> [a] -> UniqFM b
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ } #-}
delManyFromIdEnv :: UniqFM a -> [Id] -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM delListFromUFM [ (Id), _N_ ] _N_ #-}
delOneFromIdEnv :: UniqFM a -> Id -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-eltsUFM :: UniqFM a -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
-emptyUFM :: UniqFM a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
-filterUFM :: (a -> Bool) -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
growIdEnv :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM plusUFM _N_ #-}
growIdEnvList :: UniqFM a -> [(Id, a)] -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
isNullIdEnv :: UniqFM a -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-listToUFM :: NamedThing a => [(a, b)] -> UniqFM b
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-}
lookupIdEnv :: UniqFM a -> Id -> Labda a
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupNoFailIdEnv :: UniqFM a -> Id -> a
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
mapIdEnv :: (a -> b) -> UniqFM a -> UniqFM b
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM mapUFM _N_ #-}
-mapUFM :: (a -> b) -> UniqFM a -> UniqFM b
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
-minusUFM :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
mkIdEnv :: [(Id, a)] -> UniqFM a
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM listToUFM [ (Id), _N_ ] _N_ #-}
modifyIdEnv :: UniqFM a -> (a -> a) -> Id -> UniqFM a
- {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "SLU(U(P)AAA)" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
nullIdEnv :: UniqFM a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
-plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-plusUFM_C :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
rngIdEnv :: UniqFM a -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM eltsUFM _N_ #-}
-singletonUFM :: NamedThing a => a -> b -> UniqFM b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LL" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 2 3 XXX 6 _/\_ u0 u1 -> \ (u2 :: u0 -> Unique) (u3 :: u0) (u4 :: u1) -> case _APP_ u2 [ u3 ] of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [u5, u4]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 2 3 CXX 7 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: u0) (u4 :: u1) -> case case u2 of { _ALG_ _TUP_10 (u5 :: u0 -> ExportFlag) (u6 :: u0 -> Bool) (u7 :: u0 -> (_PackedString, _PackedString)) (u8 :: u0 -> _PackedString) (u9 :: u0 -> [_PackedString]) (ua :: u0 -> SrcLoc) (ub :: u0 -> Unique) (uc :: u0 -> Bool) (ud :: u0 -> UniType) (ue :: u0 -> Bool) -> _APP_ ub [ u3 ]; _NO_DEFLT_ } of { _ALG_ _ORIG_ Unique MkUnique (uf :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [uf, u4]; _NO_DEFLT_ } _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-}
-u2i :: Unique -> Int#
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-}
unitIdEnv :: Id -> a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
import HsMatches(Match)
import HsPat(InPat, TypecheckedPat)
import HsTypes(PolyType)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo, SpecEnv, SpecInfo)
+import Id(Id)
+import IdInfo(SpecEnv, SpecInfo)
import Inst(Inst, InstOrigin, OverloadedLit)
import Maybes(Labda, MaybeErr)
import Name(Name)
-import NameTypes(FullName, ShortName)
import PreludePS(_PackedString)
-import PrimKind(PrimKind)
import PrimOps(PrimOp)
import SplitUniq(SplitUniqSupply)
import SrcLoc(SrcLoc)
import TyVar(TyVar, TyVarTemplate)
import UniType(UniType)
import Unique(Unique)
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
+data Class
type ClassInstEnv = [(UniType, InstTemplate)]
-data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
-data InstOrigin {-# GHC_PRAGMA OccurrenceOf Id SrcLoc | InstanceDeclOrigin SrcLoc | LiteralOrigin Literal SrcLoc | ArithSeqOrigin (ArithSeqInfo Name (InPat Name)) SrcLoc | SignatureOrigin | ClassDeclOrigin SrcLoc | DerivingOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class Bool TyCon SrcLoc | InstanceSpecOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class UniType SrcLoc | DefaultDeclOrigin SrcLoc | ValSpecOrigin Name SrcLoc | CCallOrigin SrcLoc [Char] (Labda (Expr Name (InPat Name))) | LitLitOrigin SrcLoc [Char] | UnknownOrigin #-}
-data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-}
-data InstTy {-# GHC_PRAGMA DictTy Class UniType | MethodTy Id [UniType] #-}
+data ClassOp
+data CoreExpr a b
+data Expr a b
+data Id
+data Inst
+data InstOrigin
+data InstTemplate
+data InstTy
type InstanceMapper = Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
+data Labda a
type MatchEnv a b = [(a, b)]
-data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-}
+data MaybeErr a b
type MethodInstInfo = (Id, [UniType], InstTemplate)
-data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-}
-data SpecInfo {-# GHC_PRAGMA SpecInfo [Labda UniType] Int Id #-}
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data TypecheckedPat
+data SpecInfo
+data SplitUniqSupply
+data TyCon
+data TyVarTemplate
+data UniType
addClassInst :: Class -> [(UniType, InstTemplate)] -> UniType -> Id -> [TyVarTemplate] -> [(Class, UniType)] -> SrcLoc -> MaybeErr [(UniType, InstTemplate)] (Class, (UniType, SrcLoc), (UniType, SrcLoc))
- {-# GHC_PRAGMA _A_ 7 _U_ 2222112 _N_ _S_ "LSLLLLL" _N_ _N_ #-}
lookupClassInstAtSimpleType :: Class -> UniType -> Labda Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAAAAAAASA)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupInst :: SplitUniqSupply -> Inst -> Labda (Expr Id TypecheckedPat, [Inst])
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
lookupNoBindInst :: SplitUniqSupply -> Inst -> Labda [Inst]
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-}
nullMEnv :: [(a, b)]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 2 0 X 1 _/\_ u0 u1 -> _!_ _NIL_ [(u0, u1)] [] _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface LIE where
-import Class(Class)
-import Id(Id)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import UniType(UniType)
-import Unique(Unique)
-data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
-data LIE {-# GHC_PRAGMA MkLIE [Inst] #-}
+import Inst(Inst)
+data Inst
+data LIE
mkLIE :: [Inst] -> LIE
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Inst]) -> _!_ _ORIG_ LIE MkLIE [] [u0] _N_ #-}
nullLIE :: LIE
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
plusLIE :: LIE -> LIE -> LIE
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(L)U(L)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
unMkLIE :: LIE -> [Inst]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [Inst]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: LIE) -> case u0 of { _ALG_ _ORIG_ LIE MkLIE (u1 :: [Inst]) -> u1; _NO_DEFLT_ } _N_ #-}
unitLIE :: Inst -> LIE
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface TCE where
import CharSeq(CSeq)
-import Class(Class)
import ErrUtils(Error(..))
import Id(Id)
-import Maybes(Labda, MaybeErr)
+import Maybes(MaybeErr)
import Name(Name)
import NameTypes(FullName, ShortName)
import PreludePS(_PackedString)
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind)
import SrcLoc(SrcLoc)
import TyCon(TyCon)
-import TyVar(TyVarTemplate)
-import UniType(UniType)
-import UniqFM(UniqFM, eltsUFM, emptyUFM, plusUFM, singletonDirectlyUFM)
-import Unique(Unique, u2i)
+import UniqFM(UniqFM)
+import Unique(Unique)
type Error = PprStyle -> Int -> Bool -> PrettyRep
-data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
+data MaybeErr a b
+data Name
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
+data PrettyRep
+data SrcLoc
type TCE = UniqFM TyCon
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data TyCon
+data UniqFM a
checkTypeCycles :: UniqFM TyCon -> MaybeErr () (PprStyle -> Int -> Bool -> PrettyRep)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
-eltsUFM :: UniqFM a -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
-emptyUFM :: UniqFM a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
lookupTCE :: UniqFM TyCon -> Name -> TyCon
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
nullTCE :: UniqFM TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ UniqFM EmptyUFM [TyCon] [] _N_ #-}
plusTCE :: UniqFM TyCon -> UniqFM TyCon -> UniqFM TyCon
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ UniqFM plusUFM { TyCon } _N_ #-}
-plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
rngTCE :: UniqFM TyCon -> [TyCon]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ UniqFM eltsUFM { TyCon } _N_ #-}
-singletonDirectlyUFM :: Unique -> a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-}
-u2i :: Unique -> Int#
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-}
unitTCE :: Unique -> TyCon -> UniqFM TyCon
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int#) (u1 :: TyCon) -> _!_ _ORIG_ UniqFM LeafUFM [TyCon] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: Unique) (u1 :: TyCon) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [TyCon] [u2, u1]; _NO_DEFLT_ } _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface TVE where
-import Class(Class)
import Id(Id)
import Maybes(Labda)
import Name(Name)
import NameTypes(FullName, ShortName)
import PreludePS(_PackedString)
import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import TyVar(TyVarTemplate)
import UniType(UniType)
-import UniqFM(UniqFM, eltsUFM, emptyUFM, plusUFM, singletonDirectlyUFM)
-import Unique(Unique, u2i)
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
+import UniqFM(UniqFM)
+import Unique(Unique)
+data Labda a
+data Name
type TVE = UniqFM UniType
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-eltsUFM :: UniqFM a -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
-emptyUFM :: UniqFM a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
+data TyVarTemplate
+data UniType
+data UniqFM a
lookupTVE :: UniqFM UniType -> Name -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ #-}
lookupTVE_NoFail :: UniqFM a -> Name -> Labda a
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ #-}
mkTVE :: [Name] -> (UniqFM UniType, [TyVarTemplate], [UniType])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
nullTVE :: UniqFM UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ UniqFM EmptyUFM [UniType] [] _N_ #-}
plusTVE :: UniqFM UniType -> UniqFM UniType -> UniqFM UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ UniqFM plusUFM { UniType } _N_ #-}
-plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-singletonDirectlyUFM :: Unique -> a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-}
-u2i :: Unique -> Int#
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-}
unitTVE :: Unique -> a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface TyVarEnv where
import Maybes(Labda(..))
-import NameTypes(ShortName)
-import Outputable(NamedThing)
import TyVar(TyVar)
import UniType(UniType)
-import UniqFM(UniqFM, addToUFM, delFromUFM, delListFromUFM, eltsUFM, emptyUFM, listToUFM, lookupUFM, mapUFM, minusUFM, plusUFM, plusUFM_C, singletonUFM)
-import Unique(Unique, u2i)
+import UniqFM(UniqFM)
+import Unique(Unique)
data Labda a = Hamna | Ni a
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
+data TyVar
type TyVarEnv a = UniqFM a
type TypeEnv = UniqFM UniType
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data UniqFM a
+data Unique
addOneToTyVarEnv :: UniqFM a -> TyVar -> a -> UniqFM a
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM addToUFM [ (TyVar), _N_ ] _N_ #-}
-addToUFM :: NamedThing a => UniqFM b -> a -> b -> UniqFM b
- {-# GHC_PRAGMA _A_ 4 _U_ 1222 _N_ _S_ "U(AAAAAASAAA)SLL" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "SU(U(P)AAA)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
-delFromUFM :: NamedThing a => UniqFM b -> a -> UniqFM b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
-delListFromUFM :: NamedThing a => UniqFM b -> [a] -> UniqFM b
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ } #-}
-eltsUFM :: UniqFM a -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
-emptyUFM :: UniqFM a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
growTyVarEnvList :: UniqFM a -> [(TyVar, a)] -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
isNullTyVarEnv :: UniqFM a -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-listToUFM :: NamedThing a => [(a, b)] -> UniqFM b
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-}
lookupTyVarEnv :: UniqFM a -> TyVar -> Labda a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM lookupUFM [ (TyVar), _N_ ] _N_ #-}
-lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
-mapUFM :: (a -> b) -> UniqFM a -> UniqFM b
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
-minusUFM :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
mkTyVarEnv :: [(TyVar, a)] -> UniqFM a
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _SPEC_ _ORIG_ UniqFM listToUFM [ (TyVar), _N_ ] _N_ #-}
nullTyVarEnv :: UniqFM a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
-plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-plusUFM_C :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
-singletonUFM :: NamedThing a => a -> b -> UniqFM b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LL" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 2 3 XXX 6 _/\_ u0 u1 -> \ (u2 :: u0 -> Unique) (u3 :: u0) (u4 :: u1) -> case _APP_ u2 [ u3 ] of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [u5, u4]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 2 3 CXX 7 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: u0) (u4 :: u1) -> case case u2 of { _ALG_ _TUP_10 (u5 :: u0 -> ExportFlag) (u6 :: u0 -> Bool) (u7 :: u0 -> (_PackedString, _PackedString)) (u8 :: u0 -> _PackedString) (u9 :: u0 -> [_PackedString]) (ua :: u0 -> SrcLoc) (ub :: u0 -> Unique) (uc :: u0 -> Bool) (ud :: u0 -> UniType) (ue :: u0 -> Bool) -> _APP_ ub [ u3 ]; _NO_DEFLT_ } of { _ALG_ _ORIG_ Unique MkUnique (uf :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [uf, u4]; _NO_DEFLT_ } _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-}
-u2i :: Unique -> Int#
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-}
type CmdLineInfo = (GlobalSwitch -> SwitchResult, [CoreToDo], [StgToDo])
data CoreToDo = CoreDoSimplify (SimplifierSwitch -> SwitchResult) | CoreDoArityAnalysis | CoreDoCalcInlinings1 | CoreDoCalcInlinings2 | CoreDoFloatInwards | CoreDoFullLaziness | CoreLiberateCase | CoreDoPrintCore | CoreDoStaticArgs | CoreDoStrictness | CoreDoSpecialising | CoreDoDeforest | CoreDoAutoCostCentres | CoreDoFoldrBuildWorkerWrapper | CoreDoFoldrBuildWWAnal
data GlobalSwitch
- = ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats
+ = ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | NumbersStrict | AllDemanded | ReturnInRegsThreshold Int | VectoredReturnThreshold Int | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats
type MainIO a = _State _RealWorld -> (a, _State _RealWorld)
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data SimplifierSwitch = SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings
+data Labda a
+data SimplifierSwitch = SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings | SimplNoLetFromCase | SimplNoLetFromApp | SimplNoLetFromStrictLet
data StgToDo = StgDoStaticArgs | StgDoUpdateAnalysis | StgDoLambdaLift | StgDoMassageForProfiling | D_stg_stats
data SwitchResult = SwBool Bool | SwString [Char] | SwInt Int
classifyOpts :: [[Char]] -> _State _RealWorld -> ((GlobalSwitch -> SwitchResult, [CoreToDo], [StgToDo]), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
intSwitchSet :: (a -> SwitchResult) -> (Int -> a) -> Labda Int
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-}
stringSwitchSet :: (a -> SwitchResult) -> ([Char] -> a) -> Labda [Char]
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-}
switchIsOn :: (a -> SwitchResult) -> a -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
instance Eq GlobalSwitch
- {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool)] [_CONSTM_ Eq (==) (GlobalSwitch), _CONSTM_ Eq (/=) (GlobalSwitch)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Eq SimplifierSwitch
- {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool)] [_CONSTM_ Eq (==) (SimplifierSwitch), _CONSTM_ Eq (/=) (SimplifierSwitch)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Ord GlobalSwitch
- {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq GlobalSwitch}}, (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> _CMP_TAG)] [_DFUN_ Eq (GlobalSwitch), _CONSTM_ Ord (<) (GlobalSwitch), _CONSTM_ Ord (<=) (GlobalSwitch), _CONSTM_ Ord (>=) (GlobalSwitch), _CONSTM_ Ord (>) (GlobalSwitch), _CONSTM_ Ord max (GlobalSwitch), _CONSTM_ Ord min (GlobalSwitch), _CONSTM_ Ord _tagCmp (GlobalSwitch)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Ord SimplifierSwitch
- {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq SimplifierSwitch}}, (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> Bool), (SimplifierSwitch -> SimplifierSwitch -> SimplifierSwitch), (SimplifierSwitch -> SimplifierSwitch -> SimplifierSwitch), (SimplifierSwitch -> SimplifierSwitch -> _CMP_TAG)] [_DFUN_ Eq (SimplifierSwitch), _CONSTM_ Ord (<) (SimplifierSwitch), _CONSTM_ Ord (<=) (SimplifierSwitch), _CONSTM_ Ord (>=) (SimplifierSwitch), _CONSTM_ Ord (>) (SimplifierSwitch), _CONSTM_ Ord max (SimplifierSwitch), _CONSTM_ Ord min (SimplifierSwitch), _CONSTM_ Ord _tagCmp (SimplifierSwitch)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
| IrrefutableEverything -- (TcPat); doing it any earlier would mean that
-- deriving-generated code wouldn't be irrefutablified.
| AllStrict
+ | NumbersStrict
| AllDemanded
+ | ReturnInRegsThreshold Int
+ | VectoredReturnThreshold Int -- very likely UNUSED
+
-- NOT REALLY USED: | D_dump_type_info -- for Robin Popplestone stuff
| D_dump_rif2hs -- debugging: print out various things
| KeepSpecPragmaIds -- We normally *toss* Ids we can do without
| KeepUnusedBindings
+ | SimplNoLetFromCase -- used when turning off floating entirely
+ | SimplNoLetFromApp -- (for experimentation only) WDP 95/10
+ | SimplNoLetFromStrictLet
{-
| Extra__SimplFlag1
| Extra__SimplFlag2
maybe_uut = starts_with "-funfolding-use-threshold" opt1
maybe_uct = starts_with "-funfolding-creation-threshold" opt1
maybe_uot = starts_with "-funfolding-override-threshold" opt1
+ maybe_rirt = starts_with "-freturn-in-regs-threshold" opt1
maybe_gtn = starts_with "-fglobalise-toplev-names" opt1
starts_with_fasm = maybeToBool maybe_fasm
starts_with_G = maybeToBool maybe_G
starts_with_uut = maybeToBool maybe_uut
starts_with_uct = maybeToBool maybe_uct
starts_with_uot = maybeToBool maybe_uot
+ starts_with_rirt = maybeToBool maybe_rirt
starts_with_gtn = maybeToBool maybe_gtn
(Just after_fasm) = maybe_fasm
(Just after_G) = maybe_G
(Just after_uut) = maybe_uut
(Just after_uct) = maybe_uct
(Just after_uot) = maybe_uot
+ (Just after_rirt) = maybe_rirt
(Just after_gtn) = maybe_gtn
in
case opt1 of -- the non-"just match a string" options are at the end...
"-firrefutable-tuples" -> GLOBAL_SW(IrrefutableTuples)
"-firrefutable-everything" -> GLOBAL_SW(IrrefutableEverything)
"-fall-strict" -> GLOBAL_SW(AllStrict)
+ "-fnumbers-strict" -> GLOBAL_SW(NumbersStrict)
"-fall-demanded" -> GLOBAL_SW(AllDemanded)
"-fsemi-tagging" -> GLOBAL_SW(DoSemiTagging)
"-fauto-sccs-on-individual-cafs" -> GLOBAL_SW(AutoSccsOnIndividualCafs)
--UNUSED: "-fauto-sccs-on-individual-dicts" -> GLOBAL_SW(AutoSccsOnIndividualDicts)
- "-fstg-reduction-counts" -> GLOBAL_SW(DoTickyProfiling)
+ "-fticky-ticky" -> GLOBAL_SW(DoTickyProfiling)
"-dppr-user" -> GLOBAL_SW(PprStyle_User)
"-dppr-debug" -> GLOBAL_SW(PprStyle_Debug)
| starts_with_uct -> GLOBAL_SW(UnfoldingCreationThreshold (read after_uct))
| starts_with_uot -> GLOBAL_SW(UnfoldingOverrideThreshold (read after_uot))
+ | starts_with_rirt -> -- trace ("rirt:"++after_rirt) $
+ GLOBAL_SW(ReturnInRegsThreshold (read after_rirt))
+
| starts_with_gtn -> GLOBAL_SW(EnsureSplittableC after_gtn)
+
_ -> writeMn stderr ("*** WARNING: bad option: "++opt1++"\n") `thenMn` ( \ _ ->
-- NB: the driver is really supposed to handle bad options
IGNORE_ARG() )
"-fmay-delete-conjurable-ids" -> GLOBAL_SIMPL_SW(SimplMayDeleteConjurableIds)
"-fessential-unfoldings-only" -> GLOBAL_SIMPL_SW(EssentialUnfoldingsOnly)
"-fignore-inline-pragma" -> GLOBAL_SIMPL_SW(IgnoreINLINEPragma)
+ "-fno-let-from-case" -> GLOBAL_SIMPL_SW(SimplNoLetFromCase)
+ "-fno-let-from-app" -> GLOBAL_SIMPL_SW(SimplNoLetFromApp)
+ "-fno-let-from-strict-let" -> GLOBAL_SIMPL_SW(SimplNoLetFromStrictLet)
_ | starts_with_msi -> GLOBAL_SIMPL_SW(MaxSimplifierIterations (read after_msi))
| starts_with_suut -> GLOBAL_SIMPL_SW(SimplUnfoldingUseThreshold (read after_suut))
tagOf_Switch IrrefutableTuples = ILIT(52)
tagOf_Switch IrrefutableEverything = ILIT(53)
tagOf_Switch AllStrict = ILIT(54)
-tagOf_Switch AllDemanded = ILIT(55)
+tagOf_Switch NumbersStrict = ILIT(55)
+tagOf_Switch AllDemanded = ILIT(56)
-- NOT REALLY USED: tagOf_Switch D_dump_type_info = ILIT(56)
-tagOf_Switch D_dump_rif2hs = ILIT(57)
-tagOf_Switch D_dump_rn4 = ILIT(58)
-tagOf_Switch D_dump_tc = ILIT(59)
-tagOf_Switch D_dump_deriv = ILIT(60)
-tagOf_Switch D_dump_ds = ILIT(61)
-tagOf_Switch D_dump_simpl = ILIT(62)
-tagOf_Switch D_dump_spec = ILIT(63)
-tagOf_Switch D_dump_occur_anal = ILIT(64)
-tagOf_Switch D_dump_stranal = ILIT(65)
-tagOf_Switch D_dump_stg = ILIT(66)
-tagOf_Switch D_dump_absC = ILIT(67)
-tagOf_Switch D_dump_flatC = ILIT(68)
-tagOf_Switch D_dump_realC = ILIT(69)
-tagOf_Switch D_dump_asm = ILIT(70)
-tagOf_Switch D_dump_core_passes = ILIT(71)
-tagOf_Switch D_dump_core_passes_info = ILIT(72)
-tagOf_Switch D_verbose_core2core = ILIT(73)
-tagOf_Switch D_verbose_stg2stg = ILIT(74)
-tagOf_Switch D_simplifier_stats = ILIT(75) {-note below-}
+tagOf_Switch (ReturnInRegsThreshold _) = ILIT(57)
+tagOf_Switch (VectoredReturnThreshold _)= ILIT(58)
+tagOf_Switch D_dump_rif2hs = ILIT(59)
+tagOf_Switch D_dump_rn4 = ILIT(60)
+tagOf_Switch D_dump_tc = ILIT(61)
+tagOf_Switch D_dump_deriv = ILIT(62)
+tagOf_Switch D_dump_ds = ILIT(63)
+tagOf_Switch D_dump_simpl = ILIT(64)
+tagOf_Switch D_dump_spec = ILIT(65)
+tagOf_Switch D_dump_occur_anal = ILIT(66)
+tagOf_Switch D_dump_stranal = ILIT(67)
+tagOf_Switch D_dump_stg = ILIT(68)
+tagOf_Switch D_dump_absC = ILIT(69)
+tagOf_Switch D_dump_flatC = ILIT(70)
+tagOf_Switch D_dump_realC = ILIT(71)
+tagOf_Switch D_dump_asm = ILIT(72)
+tagOf_Switch D_dump_core_passes = ILIT(73)
+tagOf_Switch D_dump_core_passes_info = ILIT(74)
+tagOf_Switch D_verbose_core2core = ILIT(75)
+tagOf_Switch D_verbose_stg2stg = ILIT(76)
+tagOf_Switch D_simplifier_stats = ILIT(77) {-see note below!-}
{-
tagOf_Switch Extra__Flag1 = ILIT(76)
tagOf_SimplSwitch (SimplUnfoldingCreationThreshold _) = ILIT(23)
tagOf_SimplSwitch KeepSpecPragmaIds = ILIT(24)
tagOf_SimplSwitch KeepUnusedBindings = ILIT(25)
+tagOf_SimplSwitch SimplNoLetFromCase = ILIT(26)
+tagOf_SimplSwitch SimplNoLetFromApp = ILIT(27)
+tagOf_SimplSwitch SimplNoLetFromStrictLet = ILIT(28)
+-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
{-
tagOf_SimplSwitch Extra__SimplFlag1 = ILIT(26)
tagOf_SimplSwitch _ = case (panic "tagOf_SimplSwitch") of -- BUG avoidance
s -> tagOf_SimplSwitch s
-lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch KeepUnusedBindings)
+lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplNoLetFromStrictLet)
\end{code}
%************************************************************************
mk_assoc_elem k@(UnfoldingCreationThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl
mk_assoc_elem k@(UnfoldingOverrideThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl
+ mk_assoc_elem k@(ReturnInRegsThreshold lvl) = IBOX(tagOf_Switch k) := SwInt lvl
+
mk_assoc_elem k = IBOX(tagOf_Switch k) := SwBool True -- I'm here, Mom!
-- cannot have duplicates if we are going to use the array thing
-> Maybe Int
intSwitchSet lookup_fn switch
- = case (lookup_fn (switch (panic "intSwitchSet"))) of
+ = -- pprTrace "intSwitchSet:" (ppInt (IBOX (tagOf_Switch (switch (panic "xxx"))))) $
+ case (lookup_fn (switch (panic "intSwitchSet"))) of
SwInt int -> Just int
_ -> Nothing
\end{code}
import SrcLoc(SrcLoc)
type Error = PprStyle -> Int -> Bool -> PrettyRep
addErrLoc :: SrcLoc -> [Char] -> (PprStyle -> Int -> Bool -> PrettyRep) -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 221222 _N_ _N_ _N_ _N_ #-}
addShortErrLocLine :: SrcLoc -> (PprStyle -> Int -> Bool -> PrettyRep) -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _S_ "SLL" _N_ _N_ #-}
dontAddErrLoc :: [Char] -> (PprStyle -> Int -> Bool -> PrettyRep) -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _N_ _N_ _N_ #-}
pprBagOfErrors :: PprStyle -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
import CmdLineOpts(GlobalSwitch)
import ErrUtils(Error(..), pprBagOfErrors)
import ErrsRn(badClassOpErr, badExportNameErr, badImportNameErr, derivingInIfaceErr, derivingNonStdClassErr, dupNamesErr, dupPreludeNameErr, dupSigDeclErr, duplicateImportsInInterfaceErr, inlineInRecursiveBindsErr, methodBindErr, missingSigErr, shadowedNameErr, unknownNameErr, unknownSigDeclErr, weirdImportExportConstraintErr)
-import ErrsTc(UnifyErrContext(..), UnifyErrInfo(..), ambigErr, badMatchErr, badSpecialisationErr, classCycleErr, confusedNameErr, dataConArityErr, defaultErr, derivingEnumErr, derivingIxErr, derivingWhenInstanceExistsErr, dupInstErr, genCantGenErr, instTypeErr, methodTypeLacksTyVarErr, naughtyCCallContextErr, noInstanceErr, nonBoxedPrimCCallErr, notAsPolyAsSigErr, preludeInstanceErr, reduceErr, sigContextsErr, specCtxtGroundnessErr, specDataNoSpecErr, specDataUnboxedErr, specGroundnessErr, specInstUnspecInstNotFoundErr, topLevelUnboxedDeclErr, tyConArityErr, typeCycleErr, unifyErr, varyingArgsErr)
+import ErrsTc(UnifyErrContext(..), UnifyErrInfo(..), ambigErr, badMatchErr, badSpecialisationErr, classCycleErr, confusedNameErr, dataConArityErr, defaultErr, derivingEnumErr, derivingIxErr, derivingWhenInstanceExistsErr, dupInstErr, genCantGenErr, instTypeErr, lurkingRank2Err, methodTypeLacksTyVarErr, naughtyCCallContextErr, noInstanceErr, nonBoxedPrimCCallErr, notAsPolyAsSigErr, preludeInstanceErr, reduceErr, sigContextsErr, specCtxtGroundnessErr, specDataNoSpecErr, specDataUnboxedErr, specGroundnessErr, specInstUnspecInstNotFoundErr, topLevelUnboxedDeclErr, tyConArityErr, typeCycleErr, underAppliedTyErr, unifyErr, varyingArgsErr)
import GenSpecEtc(SignatureInfo)
import HsBinds(Binds, MonoBinds, ProtoNameMonoBinds(..), RenamedSig(..), Sig)
import HsExpr(ArithSeqInfo, Expr, Qual, RenamedExpr(..), TypecheckedExpr(..))
import HsLit(Literal)
import HsMatches(GRHS, GRHSsAndBinds, Match, RenamedGRHS(..), RenamedGRHSsAndBinds(..), RenamedMatch(..))
import HsPat(InPat, ProtoNamePat(..), RenamedPat(..), TypecheckedPat)
-import HsPragmas(ClassOpPragmas, GenPragmas, ImpStrictness, ImpUnfolding)
-import HsTypes(MonoType, PolyType)
-import Id(Id, IdDetails)
-import IdInfo(DeforestInfo, IdInfo, UpdateInfo)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import InstEnv(InstTemplate)
+import HsPragmas(ClassOpPragmas, GenPragmas)
+import HsTypes(PolyType)
+import Id(Id)
+import Inst(Inst)
import Maybes(Labda)
import Name(Name)
import NameTypes(FullName, ShortName)
import PreludePS(_PackedString)
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind)
import ProtoName(ProtoName)
import SimplEnv(UnfoldingGuidance)
import SrcLoc(SrcLoc)
import TyVar(TyVar, TyVarTemplate)
import UniType(TauType(..), UniType)
import Unique(Unique)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
-data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-}
+data Bag a
+data Class
+data ClassOp
type Error = PprStyle -> Int -> Bool -> PrettyRep
data UnifyErrContext
= PredCtxt (Expr Name (InPat Name)) | AppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | TooManyArgsCtxt (Expr Name (InPat Name)) | FunAppCtxt (Expr Name (InPat Name)) (Labda Id) (Expr Name (InPat Name)) UniType UniType Int | OpAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionLAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionRAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | CaseCtxt (Expr Name (InPat Name)) [Match Name (InPat Name)] | BranchCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | ListCtxt [Expr Name (InPat Name)] | PatCtxt (InPat Name) | CaseBranchesCtxt [Match Name (InPat Name)] | FilterCtxt (Expr Name (InPat Name)) | GeneratorCtxt (InPat Name) (Expr Name (InPat Name)) | GRHSsBranchCtxt [GRHS Name (InPat Name)] | GRHSsGuardCtxt (Expr Name (InPat Name)) | PatMonoBindsCtxt (InPat Name) (GRHSsAndBinds Name (InPat Name)) | FunMonoBindsCtxt Name [Match Name (InPat Name)] | MatchCtxt UniType UniType | ArithSeqCtxt (Expr Name (InPat Name)) | CCallCtxt [Char] [Expr Name (InPat Name)] | AmbigDictCtxt [Inst] | SigCtxt Id UniType | MethodSigCtxt Name UniType | ExprSigCtxt (Expr Name (InPat Name)) UniType | ValSpecSigCtxt Name UniType SrcLoc | ValSpecSpecIdCtxt Name UniType Name SrcLoc | BindSigCtxt [Id] | SuperClassSigCtxt | CaseBranchCtxt (Match Name (InPat Name)) | Rank2ArgCtxt (Expr Id TypecheckedPat) UniType
data UnifyErrInfo = UnifyMisMatch UniType UniType | TypeRec TyVar UniType | UnifyListMisMatch [UniType] [UniType]
-data SignatureInfo {-# GHC_PRAGMA TySigInfo Id [TyVar] [Inst] UniType SrcLoc | ValSpecInfo Name UniType (Labda Name) SrcLoc | ValInlineInfo Name UnfoldingGuidance SrcLoc | ValDeforestInfo Name SrcLoc | ValMagicUnfoldingInfo Name _PackedString SrcLoc #-}
-data MonoBinds a b {-# GHC_PRAGMA EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc #-}
+data SignatureInfo
+data MonoBinds a b
type ProtoNameMonoBinds = MonoBinds ProtoName (InPat ProtoName)
type RenamedSig = Sig Name
-data Sig a {-# GHC_PRAGMA Sig a (PolyType a) (GenPragmas a) SrcLoc | ClassOpSig a (PolyType a) (ClassOpPragmas a) SrcLoc | SpecSig a (PolyType a) (Labda a) SrcLoc | InlineSig a UnfoldingGuidance SrcLoc | DeforestSig a SrcLoc | MagicUnfoldingSig a _PackedString SrcLoc #-}
-data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-}
+data Sig a
+data Expr a b
type RenamedExpr = Expr Name (InPat Name)
type TypecheckedExpr = Expr Id TypecheckedPat
-data IE {-# GHC_PRAGMA IEVar _PackedString | IEThingAbs _PackedString | IEThingAll _PackedString | IEConWithCons _PackedString [_PackedString] | IEClsWithOps _PackedString [_PackedString] | IEModuleContents _PackedString #-}
-data GRHS a b {-# GHC_PRAGMA GRHS (Expr a b) (Expr a b) SrcLoc | OtherwiseGRHS (Expr a b) SrcLoc #-}
-data GRHSsAndBinds a b {-# GHC_PRAGMA GRHSsAndBindsIn [GRHS a b] (Binds a b) | GRHSsAndBindsOut [GRHS a b] (Binds a b) UniType #-}
-data Match a b {-# GHC_PRAGMA PatMatch b (Match a b) | GRHSMatch (GRHSsAndBinds a b) #-}
+data IE
+data GRHS a b
+data GRHSsAndBinds a b
+data Match a b
type RenamedGRHS = GRHS Name (InPat Name)
type RenamedGRHSsAndBinds = GRHSsAndBinds Name (InPat Name)
type RenamedMatch = Match Name (InPat Name)
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
+data InPat a
type ProtoNamePat = InPat ProtoName
type RenamedPat = InPat Name
-data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-}
-data GenPragmas a {-# GHC_PRAGMA NoGenPragmas | GenPragmas (Labda Int) (Labda UpdateInfo) DeforestInfo (ImpStrictness a) (ImpUnfolding a) [([Labda (MonoType a)], Int, GenPragmas a)] #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data TypecheckedPat
+data GenPragmas a
+data Id
+data Inst
+data Labda a
+data Name
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
+data PrettyRep
+data ProtoName
+data SrcLoc
+data TyCon
+data TyVar
+data TyVarTemplate
type TauType = UniType
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data UniType
pprBagOfErrors :: PprStyle -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
badClassOpErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
badExportNameErr :: [Char] -> [Char] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-}
badImportNameErr :: [Char] -> [Char] -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 1222222 _N_ _N_ _N_ _N_ #-}
derivingInIfaceErr :: ProtoName -> [ProtoName] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
derivingNonStdClassErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
dupNamesErr :: [Char] -> [(ProtoName, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _S_ "LSL" _N_ _N_ #-}
dupPreludeNameErr :: [Char] -> (ProtoName, SrcLoc) -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _S_ "LU(LS)L" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
dupSigDeclErr :: [Sig Name] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-}
duplicateImportsInInterfaceErr :: [Char] -> [ProtoName] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 00222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 5 XXXXX 5 \ (u0 :: [Char]) (u1 :: [ProtoName]) (u2 :: PprStyle) (u3 :: Int) (u4 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (PprStyle -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "duplicateImportsInInterfaceErr: NOT DONE YET?", u2, u3, u4 ] _N_ #-}
inlineInRecursiveBindsErr :: [(Name, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _S_ "S" _N_ _N_ #-}
methodBindErr :: MonoBinds ProtoName (InPat ProtoName) -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-}
missingSigErr :: SrcLoc -> ProtoName -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "SLL" _N_ _N_ #-}
shadowedNameErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-}
unknownNameErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
unknownSigDeclErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
weirdImportExportConstraintErr :: ProtoName -> IE -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
ambigErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 1222 _N_ _S_ "S" _N_ _N_ #-}
badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_ #-}
badSpecialisationErr :: [Char] -> [Char] -> Int -> [Labda UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 12002222 _N_ _S_ "LLAAL" {_A_ 3 _U_ 122222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
classCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 1022 _N_ _N_ _N_ _N_ #-}
confusedNameErr :: [Char] -> Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
dataConArityErr :: Id -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 2222222 _N_ _N_ _N_ _N_ #-}
defaultErr :: [Inst] -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _N_ _N_ _N_ #-}
derivingEnumErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-}
derivingIxErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-}
derivingWhenInstanceExistsErr :: Class -> TyCon -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 22222 _N_ _N_ _N_ _N_ #-}
dupInstErr :: (Class, (UniType, SrcLoc), (UniType, SrcLoc)) -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 1222 _N_ _S_ "U(LU(LL)U(AL))L" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
genCantGenErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 1222 _N_ _S_ "S" _N_ _N_ #-}
instTypeErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-}
+lurkingRank2Err :: Name -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
methodTypeLacksTyVarErr :: TyVarTemplate -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
naughtyCCallContextErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-}
noInstanceErr :: Inst -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-}
nonBoxedPrimCCallErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
notAsPolyAsSigErr :: UniType -> [TyVar] -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 0222222 _N_ _S_ "ALLLL" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
preludeInstanceErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
reduceErr :: [Inst] -> UnifyErrContext -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-}
sigContextsErr :: [SignatureInfo] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 11222 _N_ _S_ "SLL" _N_ _N_ #-}
specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
specGroundnessErr :: UnifyErrContext -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _S_ "SLL" _N_ _N_ #-}
specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
topLevelUnboxedDeclErr :: Id -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-}
tyConArityErr :: Name -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 2222222 _N_ _N_ _N_ _N_ #-}
typeCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 1022 _N_ _N_ _N_ _N_ #-}
+underAppliedTyErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
varyingArgsErr :: Name -> [Match Name (InPat Name)] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 20222 _N_ _S_ "LAL" {_A_ 2 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instTypeErr,
-- methodInstErr, UNUSED
methodBindErr,
+ lurkingRank2Err,
methodTypeLacksTyVarErr,
-- missingClassOpErr, UNUSED
naughtyCCallContextErr,
specInstUnspecInstNotFoundErr,
topLevelUnboxedDeclErr,
tyConArityErr,
+ underAppliedTyErr,
unifyErr,
varyingArgsErr,
#ifdef DPH
import ProtoName(ProtoName)
import SrcLoc(SrcLoc)
badClassOpErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
badExportNameErr :: [Char] -> [Char] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-}
badImportNameErr :: [Char] -> [Char] -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 1222222 _N_ _N_ _N_ _N_ #-}
derivingInIfaceErr :: ProtoName -> [ProtoName] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
derivingNonStdClassErr :: Name -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
dupNamesErr :: [Char] -> [(ProtoName, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _S_ "LSL" _N_ _N_ #-}
dupPreludeNameErr :: [Char] -> (ProtoName, SrcLoc) -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 21222 _N_ _S_ "LU(LS)L" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
dupSigDeclErr :: [Sig Name] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-}
duplicateImportsInInterfaceErr :: [Char] -> [ProtoName] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 00222 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 5 XXXXX 5 \ (u0 :: [Char]) (u1 :: [ProtoName]) (u2 :: PprStyle) (u3 :: Int) (u4 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (PprStyle -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "duplicateImportsInInterfaceErr: NOT DONE YET?", u2, u3, u4 ] _N_ #-}
inlineInRecursiveBindsErr :: [(Name, SrcLoc)] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _S_ "S" _N_ _N_ #-}
methodBindErr :: MonoBinds ProtoName (InPat ProtoName) -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-}
missingSigErr :: SrcLoc -> ProtoName -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "SLL" _N_ _N_ #-}
shadowedNameErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-}
unknownNameErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
unknownSigDeclErr :: [Char] -> ProtoName -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
weirdImportExportConstraintErr :: ProtoName -> IE -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
= PredCtxt (Expr Name (InPat Name)) | AppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | TooManyArgsCtxt (Expr Name (InPat Name)) | FunAppCtxt (Expr Name (InPat Name)) (Labda Id) (Expr Name (InPat Name)) UniType UniType Int | OpAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionLAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionRAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | CaseCtxt (Expr Name (InPat Name)) [Match Name (InPat Name)] | BranchCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | ListCtxt [Expr Name (InPat Name)] | PatCtxt (InPat Name) | CaseBranchesCtxt [Match Name (InPat Name)] | FilterCtxt (Expr Name (InPat Name)) | GeneratorCtxt (InPat Name) (Expr Name (InPat Name)) | GRHSsBranchCtxt [GRHS Name (InPat Name)] | GRHSsGuardCtxt (Expr Name (InPat Name)) | PatMonoBindsCtxt (InPat Name) (GRHSsAndBinds Name (InPat Name)) | FunMonoBindsCtxt Name [Match Name (InPat Name)] | MatchCtxt UniType UniType | ArithSeqCtxt (Expr Name (InPat Name)) | CCallCtxt [Char] [Expr Name (InPat Name)] | AmbigDictCtxt [Inst] | SigCtxt Id UniType | MethodSigCtxt Name UniType | ExprSigCtxt (Expr Name (InPat Name)) UniType | ValSpecSigCtxt Name UniType SrcLoc | ValSpecSpecIdCtxt Name UniType Name SrcLoc | BindSigCtxt [Id] | SuperClassSigCtxt | CaseBranchCtxt (Match Name (InPat Name)) | Rank2ArgCtxt (Expr Id TypecheckedPat) UniType
data UnifyErrInfo = UnifyMisMatch UniType UniType | TypeRec TyVar UniType | UnifyListMisMatch [UniType] [UniType]
ambigErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 1222 _N_ _S_ "S" _N_ _N_ #-}
badMatchErr :: UniType -> UniType -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_ #-}
badSpecialisationErr :: [Char] -> [Char] -> Int -> [Labda UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 12002222 _N_ _S_ "LLAAL" {_A_ 3 _U_ 122222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
classCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 1022 _N_ _N_ _N_ _N_ #-}
confusedNameErr :: [Char] -> Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
dataConArityErr :: Id -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 2222222 _N_ _N_ _N_ _N_ #-}
defaultErr :: [Inst] -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _N_ _N_ _N_ #-}
derivingEnumErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-}
derivingIxErr :: TyCon -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-}
derivingWhenInstanceExistsErr :: Class -> TyCon -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 22222 _N_ _N_ _N_ _N_ #-}
dupInstErr :: (Class, (UniType, SrcLoc), (UniType, SrcLoc)) -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 1222 _N_ _S_ "U(LU(LL)U(AL))L" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
genCantGenErr :: [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 1222 _N_ _S_ "S" _N_ _N_ #-}
instTypeErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-}
+lurkingRank2Err :: Name -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
methodTypeLacksTyVarErr :: TyVarTemplate -> [Char] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
naughtyCCallContextErr :: Name -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-}
noInstanceErr :: Inst -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 2222 _N_ _N_ _N_ _N_ #-}
nonBoxedPrimCCallErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
notAsPolyAsSigErr :: UniType -> [TyVar] -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 0222222 _N_ _S_ "ALLLL" {_A_ 4 _U_ 222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
preludeInstanceErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
reduceErr :: [Inst] -> UnifyErrContext -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _N_ _N_ _N_ #-}
sigContextsErr :: [SignatureInfo] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
specCtxtGroundnessErr :: UnifyErrContext -> [Inst] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 11222 _N_ _S_ "SLL" _N_ _N_ #-}
specDataNoSpecErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
specDataUnboxedErr :: Name -> [UniType] -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
specGroundnessErr :: UnifyErrContext -> [UniType] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _S_ "SLL" _N_ _N_ #-}
specInstUnspecInstNotFoundErr :: Class -> UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _N_ _N_ _N_ #-}
topLevelUnboxedDeclErr :: Id -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-}
tyConArityErr :: Name -> Int -> Int -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 2222222 _N_ _N_ _N_ _N_ #-}
typeCycleErr :: [[(Int -> Bool -> PrettyRep, SrcLoc)]] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 1022 _N_ _N_ _N_ _N_ #-}
+underAppliedTyErr :: UniType -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LLSL" _N_ _N_ #-}
varyingArgsErr :: Name -> [Match Name (InPat Name)] -> PprStyle -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 20222 _N_ _S_ "LAL" {_A_ 2 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
dupInstErr,
genCantGenErr,
instTypeErr,
+ lurkingRank2Err,
methodTypeLacksTyVarErr,
naughtyCCallContextErr,
noInstanceErr,
topLevelUnboxedDeclErr,
tyConArityErr,
typeCycleErr,
+ underAppliedTyErr,
unifyErr,
varyingArgsErr
) where
)
----------------------------------------------------------------
+lurkingRank2Err :: Name -> UniType -> SrcLoc -> Error
+lurkingRank2Err name ty locn
+ = addErrLoc locn "Illegal use of a non-Hindley-Milner variable" ( \ sty ->
+ ppAboves [
+ ppBesides [ppStr "The variable is `", ppr sty name, ppStr "'."],
+ ppStr "Its type does not have all its for-alls at the top",
+ ppBesides [ppStr "(the type is `", ppr sty ty, ppStr "'),"],
+ ppStr "nor is it a full application of a rank-2-typed variable.",
+ ppStr "(Most common cause: `_runST' or `_build' not applied to an argument.)"])
+
+----------------------------------------------------------------
{- UNUSED:
methodInstErr :: (ClassOp, (UniType, SrcLoc), (UniType, SrcLoc)) -> Error
methodInstErr (class_op, info1, info2) sty
----------------------------------------------------------------
specGroundnessErr :: UnifyErrContext -> [UniType] -> Error
+specGroundnessErr (ValSpecSigCtxt name spec_ty locn) arg_tys
+ = addShortErrLocLine locn ( \ sty ->
+ ppHang (
+ ppSep [ppStr "In the SPECIALIZE pragma for `", ppr sty name,
+ ppStr "'... not all type variables were specialised",
+ ppStr "to type variables or ground types (nothing in between, please!):"])
+ 4 (ppAboves (map (ppr sty) arg_tys))
+ )
+
specGroundnessErr (ValSpecSpecIdCtxt name spec_ty spec locn) arg_tys
= addShortErrLocLine locn ( \ sty ->
ppHang (
| True = ppCat [ppInt n, ppStr "arguments"]
----------------------------------------------------------------
+underAppliedTyErr :: UniType -> SrcLoc -> Error
+underAppliedTyErr ty locn
+ = addErrLoc locn "A for-all type has been applied to too few arguments" ( \ sty ->
+ ppAboves [
+ ppBesides [ppStr "The type is `", ppr sty ty, ppStr "';"],
+ ppStr "This might be because of a GHC bug; feel free to report",
+ ppStr "it to glasgow-haskell-bugs@dcs.glasgow.ac.uk."])
+
+----------------------------------------------------------------
unifyErr :: UnifyErrInfo -> UnifyErrContext -> SrcLoc -> Error
unifyErr unify_err_info unify_err_context locn
speakNth 4 = ppStr "fourth"
speakNth 5 = ppStr "fifth"
speakNth 6 = ppStr "sixth"
-speakNth n = ppBesides [ ppInt n, ppStr "th" ] -- Wrong for eg "31th"
- -- but who cares?
+speakNth n = ppBesides [ ppInt n, ppStr st_nd_rd_th ]
+ where
+ st_nd_rd_th | n_rem_10 == 1 = "st"
+ | n_rem_10 == 2 = "nd"
+ | n_rem_10 == 3 = "rd"
+ | otherwise = "th"
+
+ n_rem_10 = n `rem` 10
\end{code}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Main where
mainPrimIO :: _State _RealWorld -> ((), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _N_ _N_ _N_ _N_ _N_ #-}
-- of the Glorious Glasgow Haskell compiler!
-- **********************************************
#ifndef DPH
- doDump Verbose "Glasgow Haskell Compiler, version 0.26" "" `thenMn_`
+ doDump Verbose "Glasgow Haskell Compiler, version 0.27" "" `thenMn_`
#else
- doDump Verbose "Data Parallel Haskell Compiler, version 0.06 (Glasgow 0.26)" ""
+ doDump Verbose "Data Parallel Haskell Compiler, version 0.06 (Glasgow 0.27)" ""
`thenMn_`
#endif {- Data Parallel Haskell -}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface MainMonad where
import PreludeArray(_ByteArray)
-import PreludePrimIO(appendChanPrimIO, appendFilePrimIO, getArgsPrimIO, readChanPrimIO)
-import SplitUniq(SplitUniqSupply, mkSplitUniqSupply)
+import SplitUniq(SplitUniqSupply)
import Stdio(_FILE(..), fclose, fopen, fwrite)
infixr 9 `thenMn`
infixr 9 `thenMn_`
type MainIO a = _State _RealWorld -> (a, _State _RealWorld)
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
+data SplitUniqSupply
data _FILE = _FILE Addr#
-appendChanPrimIO :: [Char] -> [Char] -> _State _RealWorld -> ((), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
-appendFilePrimIO :: [Char] -> [Char] -> _State _RealWorld -> ((), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
exitMn :: Int -> _State _RealWorld -> ((), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
fclose :: _FILE -> _State _RealWorld -> (Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
fopen :: [Char] -> [Char] -> _State _RealWorld -> (_FILE, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
fwrite :: _ByteArray Int -> Int -> Int -> _FILE -> _State _RealWorld -> (Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 5 _U_ 11111 _N_ _S_ "U(AP)U(P)U(P)U(P)U(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getArgsMn :: _State _RealWorld -> ([[Char]], _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePrimIO getArgsPrimIO _N_ #-}
-getArgsPrimIO :: _State _RealWorld -> ([[Char]], _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
getSplitUniqSupplyMn :: Char -> _State _RealWorld -> (SplitUniqSupply, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-readChanPrimIO :: [Char] -> _State _RealWorld -> ([Char], _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
-mkSplitUniqSupply :: Char -> _State _RealWorld -> (SplitUniqSupply, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
readMn :: [Char] -> _State _RealWorld -> ([Char], _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: [Char]) (u1 :: _State _RealWorld) -> _APP_ _ORIG_ PreludePrimIO readChanPrimIO [ u0, u1 ] _N_ #-}
returnMn :: a -> _State _RealWorld -> (a, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [u0, (_State _RealWorld)] [u1, u2]; _NO_DEFLT_ } _N_ #-}
thenMn :: (_State _RealWorld -> (a, _State _RealWorld)) -> (a -> _State _RealWorld -> (b, _State _RealWorld)) -> _State _RealWorld -> (b, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: u0 -> _State _RealWorld -> (u1, _State _RealWorld)) (u4 :: _State _RealWorld) -> case _APP_ u2 [ u4 ] of { _ALG_ _TUP_2 (u5 :: u0) (u6 :: _State _RealWorld) -> _APP_ u3 [ u5, u6 ]; _NO_DEFLT_ } _N_ #-}
thenMn_ :: (_State _RealWorld -> (a, _State _RealWorld)) -> (_State _RealWorld -> (b, _State _RealWorld)) -> _State _RealWorld -> (b, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _State _RealWorld -> (u1, _State _RealWorld)) (u4 :: _State _RealWorld) -> case _APP_ u2 [ u4 ] of { _ALG_ _TUP_2 (u5 :: u0) (u6 :: _State _RealWorld) -> _APP_ u3 [ u6 ]; _NO_DEFLT_ } _N_ #-}
writeMn :: [Char] -> [Char] -> _State _RealWorld -> ((), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: [Char]) (u1 :: [Char]) (u2 :: _State _RealWorld) -> _APP_ _ORIG_ PreludePrimIO appendChanPrimIO [ u0, u1, u2 ] _N_ #-}
instance Eq _FILE
- {-# GHC_PRAGMA _M_ Stdio {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_FILE -> _FILE -> Bool), (_FILE -> _FILE -> Bool)] [_CONSTM_ Eq (==) (_FILE), _CONSTM_ Eq (/=) (_FILE)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Addr#) (u1 :: Addr#) -> _#_ eqAddr# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: _FILE) (u1 :: _FILE) -> case u0 of { _ALG_ _ORIG_ Stdio _FILE (u2 :: Addr#) -> case u1 of { _ALG_ _ORIG_ Stdio _FILE (u3 :: Addr#) -> _#_ eqAddr# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Addr#) (u1 :: Addr#) -> case _#_ eqAddr# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: _FILE) (u1 :: _FILE) -> case u0 of { _ALG_ _ORIG_ Stdio _FILE (u2 :: Addr#) -> case u1 of { _ALG_ _ORIG_ Stdio _FILE (u3 :: Addr#) -> case _#_ eqAddr# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance _CCallable _FILE
- {-# GHC_PRAGMA _M_ Stdio {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _TUP_0 [] [] _N_ #-}
instance _CReturnable _FILE
- {-# GHC_PRAGMA _M_ Stdio {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _TUP_0 [] [] _N_ #-}
import HsBinds(MonoBinds, Sig)
import HsDecls(FixityDecl)
import HsPat(InPat)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Maybes(Labda)
import Name(Name)
import NameTypes(FullName, ShortName)
import UniType(UniType)
import UniqFM(UniqFM)
import Unique(Unique)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
+data Bag a
type CE = UniqFM Class
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data FixityDecl a {-# GHC_PRAGMA InfixL a Int | InfixR a Int | InfixN a Int #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-}
+data GlobalSwitch
+data FixityDecl a
+data Id
+data Name
+data PrettyRep
+data StgBinding a b
type TCE = UniqFM TyCon
-data InstInfo {-# GHC_PRAGMA InstInfo Class [TyVarTemplate] UniType [(Class, UniType)] [(Class, UniType)] Id [Id] (MonoBinds Name (InPat Name)) Bool _PackedString SrcLoc [Sig Name] #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data InstInfo
+data UniqFM a
mkInterface :: (GlobalSwitch -> Bool) -> _PackedString -> (_PackedString -> Bool, _PackedString -> Bool) -> UniqFM UnfoldingDetails -> FiniteMap TyCon [[Labda UniType]] -> ([FixityDecl Name], [Id], UniqFM Class, UniqFM TyCon, Bag InstInfo) -> [StgBinding Id Id] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 7 _U_ 222221122 _N_ _S_ "LLLLLU(LSSSL)L" _N_ _N_ #-}
import CLabelInfo(CLabel)
import CharSeq(CSeq)
import ClosureInfo(ClosureInfo)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
import CostCentre(CostCentre)
import HeapOffs(HeapOffset)
import MachDesc(RegLoc, Target)
import Maybes(Labda)
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
import PrimKind(PrimKind)
import PrimOps(PrimOp)
import SMRep(SMRep)
import SplitUniq(SUniqSM(..), SplitUniqSupply)
import Stix(CodeSegment, StixReg, StixTree)
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
-data Target {-# GHC_PRAGMA Target (GlobalSwitch -> SwitchResult) Int (SMRep -> Int) (MagicId -> RegLoc) (StixTree -> StixTree) (PrimKind -> Int) ([MagicId] -> [StixTree]) ([MagicId] -> [StixTree]) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) Int Int StixTree StixTree ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) Bool ([Char] -> [Char]) #-}
+data AbstractC
+data Target
type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
+data SplitUniqSupply
+data StixTree
genCodeAbstractC :: Target -> AbstractC -> SplitUniqSupply -> [[StixTree]]
- {-# GHC_PRAGMA _A_ 2 _U_ 221 _N_ _N_ _N_ _N_ #-}
separated so that register allocation can be performed locally within the chunk.
\begin{code}
+-- hacking with Uncle Will:
+#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
genCodeAbstractC
:: Target
-> AbstractC
-> SUniqSM [[StixTree]]
-genCodeAbstractC target absC =
- mapSUs (genCodeTopAbsC target) (mkAbsCStmtList absC) `thenSUs` \ trees ->
+genCodeAbstractC target_STRICT absC =
+ mapSUs gentopcode (mkAbsCStmtList absC) `thenSUs` \ trees ->
returnSUs ([StComment SLIT("Native Code")] : trees)
-
+ where
+ -- "target" munging things... ---
+ a2stix = amodeToStix target
+ a2stix' = amodeToStix' target
+ volsaves = volatileSaves target
+ volrestores = volatileRestores target
+ p2stix = primToStix target
+ macro_code = macroCode target
+ hp_rel = hpRel target
+ -- real code follows... ---------
\end{code}
Here we handle top-level things, like @CCodeBlock@s and
@CClosureInfoTable@s.
\begin{code}
-
-genCodeTopAbsC
+ {-
+ genCodeTopAbsC
:: Target
-> AbstractC
-> SUniqSM [StixTree]
+ -}
-genCodeTopAbsC target (CCodeBlock label absC) =
- genCodeAbsC target absC `thenSUs` \ code ->
+ gentopcode (CCodeBlock label absC) =
+ gencode absC `thenSUs` \ code ->
returnSUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
-genCodeTopAbsC target stmt@(CStaticClosure label _ _ _) =
- genCodeStaticClosure target stmt `thenSUs` \ code ->
+ gentopcode stmt@(CStaticClosure label _ _ _) =
+ genCodeStaticClosure stmt `thenSUs` \ code ->
returnSUs (StSegment DataSegment : StLabel label : code [])
-genCodeTopAbsC target stmt@(CRetUnVector _ _) = returnSUs []
+ gentopcode stmt@(CRetUnVector _ _) = returnSUs []
-genCodeTopAbsC target stmt@(CFlatRetVector label _) =
- genCodeVecTbl target stmt `thenSUs` \ code ->
+ gentopcode stmt@(CFlatRetVector label _) =
+ genCodeVecTbl stmt `thenSUs` \ code ->
returnSUs (StSegment TextSegment : code [StLabel label])
-genCodeTopAbsC target stmt@(CClosureInfoAndCode cl_info slow Nothing _ _)
+ gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _)
| slow_is_empty
- = genCodeInfoTable target stmt `thenSUs` \ itbl ->
+ = genCodeInfoTable hp_rel a2stix stmt `thenSUs` \ itbl ->
returnSUs (StSegment TextSegment : itbl [])
| otherwise
- = genCodeInfoTable target stmt `thenSUs` \ itbl ->
- genCodeAbsC target slow `thenSUs` \ slow_code ->
+ = genCodeInfoTable hp_rel a2stix stmt `thenSUs` \ itbl ->
+ gencode slow `thenSUs` \ slow_code ->
returnSUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
slow_code [StFunEnd slow_lbl]))
where
slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
slow_lbl = entryLabelFromCI cl_info
-genCodeTopAbsC target stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _) =
--- ToDo: what if this is empty? ------------------------^^^^
- genCodeInfoTable target stmt `thenSUs` \ itbl ->
- genCodeAbsC target slow `thenSUs` \ slow_code ->
- genCodeAbsC target fast `thenSUs` \ fast_code ->
+ gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) =
+ -- ToDo: what if this is empty? ------------------------^^^^
+ genCodeInfoTable hp_rel a2stix stmt `thenSUs` \ itbl ->
+ gencode slow `thenSUs` \ slow_code ->
+ gencode fast `thenSUs` \ fast_code ->
returnSUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
fast_code [StFunEnd fast_lbl])))
slow_lbl = entryLabelFromCI cl_info
fast_lbl = fastLabelFromCI cl_info
-genCodeTopAbsC target absC =
- genCodeAbsC target absC `thenSUs` \ code ->
+ gentopcode absC =
+ gencode absC `thenSUs` \ code ->
returnSUs (StSegment TextSegment : code [])
\end{code}
-Now the individual AbstractC statements.
+Vector tables are trivial!
\begin{code}
+ {-
+ genCodeVecTbl
+ :: Target
+ -> AbstractC
+ -> SUniqSM StixTreeList
+ -}
+ genCodeVecTbl (CFlatRetVector label amodes) =
+ returnSUs (\xs -> vectbl : xs)
+ where
+ vectbl = StData PtrKind (reverse (map a2stix amodes))
+
+\end{code}
+
+Static closures are not so hard either.
-genCodeAbsC
+\begin{code}
+ {-
+ genCodeStaticClosure
:: Target
-> AbstractC
-> SUniqSM StixTreeList
+ -}
+ genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes) =
+ returnSUs (\xs -> table : xs)
+ where
+ table = StData PtrKind (StCLbl info_lbl : body)
+ info_lbl = infoTableLabelFromCI cl_info
+
+ body = if closureUpdReqd cl_info then
+ take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
+ else
+ amodes'
+
+ zeros = StInt 0 : zeros
+
+ amodes' = map amodeZeroVoid amodes
+
+ -- Watch out for VoidKinds...cf. PprAbsC
+ amodeZeroVoid item
+ | getAmodeKind item == VoidKind = StInt 0
+ | otherwise = a2stix item
+
+\end{code}
+
+Now the individual AbstractC statements.
+\begin{code}
+ {-
+ gencode
+ :: Target
+ -> AbstractC
+ -> SUniqSM StixTreeList
+ -}
\end{code}
@AbsCNop@s just disappear.
\begin{code}
-genCodeAbsC target AbsCNop = returnSUs id
+ gencode AbsCNop = returnSUs id
\end{code}
\begin{code}
---UNUSED:genCodeAbsC target (CComment s) = returnSUs (\xs -> StComment s : xs)
+ --UNUSED:gencode (CComment s) = returnSUs (\xs -> StComment s : xs)
\end{code}
\begin{code}
-genCodeAbsC target CSplitMarker = returnSUs id
+ gencode CSplitMarker = returnSUs id
\end{code}
\begin{code}
-genCodeAbsC target (AbsCStmts c1 c2) =
- genCodeAbsC target c1 `thenSUs` \ b1 ->
- genCodeAbsC target c2 `thenSUs` \ b2 ->
+ gencode (AbsCStmts c1 c2) =
+ gencode c1 `thenSUs` \ b1 ->
+ gencode c2 `thenSUs` \ b2 ->
returnSUs (b1 . b2)
\end{code}
\begin{code}
-genCodeAbsC target (CInitHdr cl_info reg_rel _ _) =
+ gencode (CInitHdr cl_info reg_rel _ _) =
let
- lhs = amodeToStix target (CVal reg_rel PtrKind)
+ lhs = a2stix (CVal reg_rel PtrKind)
lbl = infoTableLabelFromCI cl_info
in
returnSUs (\xs -> StAssign PtrKind lhs (StCLbl lbl) : xs)
\begin{code}
-genCodeAbsC target (CAssign lhs rhs)
+ gencode (CAssign lhs rhs)
| getAmodeKind lhs == VoidKind = returnSUs id
| otherwise =
let pk = getAmodeKind lhs
pk' = if mixedTypeLocn lhs && not (isFloatingKind pk) then IntKind else pk
- lhs' = amodeToStix target lhs
- rhs' = amodeToStix' target rhs
+ lhs' = a2stix lhs
+ rhs' = a2stix' rhs
in
returnSUs (\xs -> StAssign pk' lhs' rhs' : xs)
\begin{code}
-genCodeAbsC target (CJump dest) =
- returnSUs (\xs -> StJump (amodeToStix target dest) : xs)
+ gencode (CJump dest) =
+ returnSUs (\xs -> StJump (a2stix dest) : xs)
-genCodeAbsC target (CFallThrough (CLbl lbl _)) =
+ gencode (CFallThrough (CLbl lbl _)) =
returnSUs (\xs -> StFallThrough lbl : xs)
-genCodeAbsC target (CReturn dest DirectReturn) =
- returnSUs (\xs -> StJump (amodeToStix target dest) : xs)
+ gencode (CReturn dest DirectReturn) =
+ returnSUs (\xs -> StJump (a2stix dest) : xs)
-genCodeAbsC target (CReturn table (StaticVectoredReturn n)) =
+ gencode (CReturn table (StaticVectoredReturn n)) =
returnSUs (\xs -> StJump dest : xs)
where
- dest = StInd PtrKind (StIndex PtrKind (amodeToStix target table)
+ dest = StInd PtrKind (StIndex PtrKind (a2stix table)
(StInt (toInteger (-n-1))))
-genCodeAbsC target (CReturn table (DynamicVectoredReturn am)) =
+ gencode (CReturn table (DynamicVectoredReturn am)) =
returnSUs (\xs -> StJump dest : xs)
where
- dest = StInd PtrKind (StIndex PtrKind (amodeToStix target table) dyn_off)
- dyn_off = StPrim IntSubOp [StPrim IntNegOp [amodeToStix target am], StInt 1]
+ dest = StInd PtrKind (StIndex PtrKind (a2stix table) dyn_off)
+ dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1]
\end{code}
\begin{code}
-genCodeAbsC target (COpStmt results op args liveness_mask vols)
+ gencode (COpStmt results op args liveness_mask vols)
-- ToDo (ADR?): use that liveness mask
| primOpNeedsWrapper op =
let
- saves = volatileSaves target vols
- restores = volatileRestores target vols
+ saves = volsaves vols
+ restores = volrestores vols
in
- primToStix target (nonVoid results) op (nonVoid args)
+ p2stix (nonVoid results) op (nonVoid args)
`thenSUs` \ code ->
returnSUs (\xs -> saves ++ code (restores ++ xs))
- | otherwise = primToStix target (nonVoid results) op (nonVoid args)
+ | otherwise = p2stix (nonVoid results) op (nonVoid args)
where
nonVoid = filter ((/= VoidKind) . getAmodeKind)
\begin{code}
-genCodeAbsC target (CSwitch discrim alts deflt)
+ gencode (CSwitch discrim alts deflt)
= case alts of
- [] -> genCodeAbsC target deflt
+ [] -> gencode deflt
[(tag,alt_code)] -> case maybe_empty_deflt of
- Nothing -> genCodeAbsC target alt_code
- Just dc -> mkIfThenElse target discrim tag alt_code dc
+ Nothing -> gencode alt_code
+ Just dc -> mkIfThenElse discrim tag alt_code dc
[(tag1@(MachInt i1 _), alt_code1),
(tag2@(MachInt i2 _), alt_code2)]
| deflt_is_empty && i1 == 0 && i2 == 1
- -> mkIfThenElse target discrim tag1 alt_code1 alt_code2
+ -> mkIfThenElse discrim tag1 alt_code1 alt_code2
| deflt_is_empty && i1 == 1 && i2 == 0
- -> mkIfThenElse target discrim tag2 alt_code2 alt_code1
+ -> mkIfThenElse discrim tag2 alt_code2 alt_code1
-- If the @discrim@ is simple, then this unfolding is safe.
- other | simple_discrim -> mkSimpleSwitches target discrim alts deflt
+ other | simple_discrim -> mkSimpleSwitches discrim alts deflt
-- Otherwise, we need to do a bit of work.
other -> getSUnique `thenSUs` \ u ->
- genCodeAbsC target (AbsCStmts
+ gencode (AbsCStmts
(CAssign (CTemp u pk) discrim)
(CSwitch (CTemp u pk) alts deflt))
\begin{code}
-genCodeAbsC target (CMacroStmt macro args) = macroCode target macro args
+ gencode (CMacroStmt macro args) = macro_code macro args
-genCodeAbsC target (CCallProfCtrMacro macro _) =
+ gencode (CCallProfCtrMacro macro _) =
returnSUs (\xs -> StComment macro : xs)
-genCodeAbsC target (CCallProfCCMacro macro _) =
+ gencode (CCallProfCCMacro macro _) =
returnSUs (\xs -> StComment macro : xs)
\end{code}
\begin{code}
-intTag :: BasicLit -> Integer
-intTag (MachChar c) = toInteger (ord c)
-intTag (MachInt i _) = i
-intTag _ = panic "intTag"
+ intTag :: BasicLit -> Integer
+ intTag (MachChar c) = toInteger (ord c)
+ intTag (MachInt i _) = i
+ intTag _ = panic "intTag"
-fltTag :: BasicLit -> Rational
+ fltTag :: BasicLit -> Rational
-fltTag (MachFloat f) = f
-fltTag (MachDouble d) = d
-fltTag _ = panic "fltTag"
+ fltTag (MachFloat f) = f
+ fltTag (MachDouble d) = d
+ fltTag _ = panic "fltTag"
-mkSimpleSwitches
+ {-
+ mkSimpleSwitches
:: Target
-> CAddrMode -> [(BasicLit,AbstractC)] -> AbstractC
-> SUniqSM StixTreeList
-
-mkSimpleSwitches target am alts absC =
+ -}
+ mkSimpleSwitches am alts absC =
getUniqLabelNCG `thenSUs` \ udlbl ->
getUniqLabelNCG `thenSUs` \ ujlbl ->
- let am' = amodeToStix target am
+ let am' = a2stix am
joinedAlts = map (\ (tag,code) -> (tag, mkJoin code ujlbl)) alts
sortedAlts = naturalMergeSortLe leAlt joinedAlts
-- naturalMergeSortLe, because we often get sorted alts to begin with
in
(
if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
- mkJumpTable target am' sortedAlts lowTag highTag udlbl
+ mkJumpTable am' sortedAlts lowTag highTag udlbl
else
- mkBinaryTree target am' floating sortedAlts choices lowest highest udlbl
+ mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
)
`thenSUs` \ alt_code ->
- genCodeAbsC target absC `thenSUs` \ dflt_code ->
+ gencode absC `thenSUs` \ dflt_code ->
returnSUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
with a jump to the join point.
\begin{code}
-
-mkJumpTable
+ {-
+ mkJumpTable
:: Target
-> StixTree -- discriminant
-> [(BasicLit, AbstractC)] -- alternatives
-> Integer -- high tag
-> CLabel -- default label
-> SUniqSM StixTreeList
+ -}
-mkJumpTable target am alts lowTag highTag dflt =
+ mkJumpTable am alts lowTag highTag dflt =
getUniqLabelNCG `thenSUs` \ utlbl ->
mapSUs genLabel alts `thenSUs` \ branches ->
let cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
genLabel x = getUniqLabelNCG `thenSUs` \ lbl -> returnSUs (lbl, x)
mkBranch (lbl,(_,alt)) =
- genCodeAbsC target alt `thenSUs` \ alt_code ->
+ gencode alt `thenSUs` \ alt_code ->
returnSUs (\xs -> StLabel lbl : alt_code xs)
mkTable _ [] tbl = reverse tbl
alternatives should already finish with a jump to the join point.
\begin{code}
-
-mkBinaryTree
+ {-
+ mkBinaryTree
:: Target
-> StixTree -- discriminant
-> Bool -- floating point?
-> BasicLit -- high tag
-> CLabel -- default code label
-> SUniqSM StixTreeList
+ -}
-mkBinaryTree target am floating [(tag,alt)] _ lowTag highTag udlbl
- | rangeOfOne = genCodeAbsC target alt
+ mkBinaryTree am floating [(tag,alt)] _ lowTag highTag udlbl
+ | rangeOfOne = gencode alt
| otherwise =
- let tag' = amodeToStix target (CLit tag)
+ let tag' = a2stix (CLit tag)
cmpOp = if floating then DoubleNeOp else IntNeOp
test = StPrim cmpOp [am, tag']
cjmp = StCondJump udlbl test
in
- genCodeAbsC target alt `thenSUs` \ alt_code ->
+ gencode alt `thenSUs` \ alt_code ->
returnSUs (\xs -> cjmp : alt_code xs)
where
rangeOfOne = not floating && intTag lowTag + 1 >= intTag highTag
-- When there is only one possible tag left in range, we skip the comparison
-mkBinaryTree target am floating alts choices lowTag highTag udlbl =
+ mkBinaryTree am floating alts choices lowTag highTag udlbl =
getUniqLabelNCG `thenSUs` \ uhlbl ->
- let tag' = amodeToStix target (CLit splitTag)
+ let tag' = a2stix (CLit splitTag)
cmpOp = if floating then DoubleGeOp else IntGeOp
test = StPrim cmpOp [am, tag']
cjmp = StCondJump uhlbl test
in
- mkBinaryTree target am floating alts_lo half lowTag splitTag udlbl
+ mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
`thenSUs` \ lo_code ->
- mkBinaryTree target am floating alts_hi (choices - half) splitTag highTag udlbl
+ mkBinaryTree am floating alts_hi (choices - half) splitTag highTag udlbl
`thenSUs` \ hi_code ->
returnSUs (\xs -> cjmp : lo_code (StLabel uhlbl : hi_code xs))
\end{code}
\begin{code}
-
-mkIfThenElse
+ {-
+ mkIfThenElse
:: Target
-> CAddrMode -- discriminant
-> BasicLit -- tag
-> AbstractC -- if-part
-> AbstractC -- else-part
-> SUniqSM StixTreeList
+ -}
-mkIfThenElse target discrim tag alt deflt =
+ mkIfThenElse discrim tag alt deflt =
getUniqLabelNCG `thenSUs` \ ujlbl ->
getUniqLabelNCG `thenSUs` \ utlbl ->
- let discrim' = amodeToStix target discrim
- tag' = amodeToStix target (CLit tag)
+ let discrim' = a2stix discrim
+ tag' = a2stix (CLit tag)
cmpOp = if (isFloatingKind (getAmodeKind discrim)) then DoubleNeOp else IntNeOp
test = StPrim cmpOp [discrim', tag']
cjmp = StCondJump utlbl test
dest = StLabel utlbl
join = StLabel ujlbl
in
- genCodeAbsC target (mkJoin alt ujlbl) `thenSUs` \ alt_code ->
- genCodeAbsC target deflt `thenSUs` \ dflt_code ->
+ gencode (mkJoin alt ujlbl) `thenSUs` \ alt_code ->
+ gencode deflt `thenSUs` \ dflt_code ->
returnSUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
mkJoin :: AbstractC -> CLabel -> AbstractC
mkJoin code lbl
| mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrKind))
| otherwise = code
-
\end{code}
%---------------------------------------------------------------------------
isEmptyAbsC = not . maybeToBool . nonemptyAbsC
================= End of old, quadratic, algorithm -}
\end{code}
-
-Vector tables are trivial!
-
-\begin{code}
-
-genCodeVecTbl
- :: Target
- -> AbstractC
- -> SUniqSM StixTreeList
-
-genCodeVecTbl target (CFlatRetVector label amodes) =
- returnSUs (\xs -> vectbl : xs)
- where
- vectbl = StData PtrKind (reverse (map (amodeToStix target) amodes))
-
-\end{code}
-
-Static closures are not so hard either.
-
-\begin{code}
-
-genCodeStaticClosure
- :: Target
- -> AbstractC
- -> SUniqSM StixTreeList
-
-genCodeStaticClosure target (CStaticClosure _ cl_info cost_centre amodes) =
- returnSUs (\xs -> table : xs)
- where
- table = StData PtrKind (StCLbl info_lbl : body)
- info_lbl = infoTableLabelFromCI cl_info
-
- body = if closureUpdReqd cl_info then
- take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
- else
- amodes'
-
- zeros = StInt 0 : zeros
-
- amodes' = map amodeZeroVoid amodes
-
- -- Watch out for VoidKinds...cf. PprAbsC
- amodeZeroVoid item
- | getAmodeKind item == VoidKind = StInt 0
- | otherwise = amodeToStix target item
-
-\end{code}
-
type AlphaCode = OrdList AlphaInstr
data AlphaInstr
= LD Size Reg Addr | LDA Reg Addr | LDAH Reg Addr | LDGP Reg Addr | LDI Size Reg Imm | ST Size Reg Addr | CLR Reg | ABS Size RI Reg | NEG Size Bool RI Reg | ADD Size Bool Reg RI Reg | SADD Size Size Reg RI Reg | SUB Size Bool Reg RI Reg | SSUB Size Size Reg RI Reg | MUL Size Bool Reg RI Reg | DIV Size Bool Reg RI Reg | REM Size Bool Reg RI Reg | 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 | CMP Cond Reg RI Reg | 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 | BI Cond Reg Imm | BF Cond Reg Imm | BR Imm | JMP Reg Addr Int | BSR Imm Int | JSR Reg Addr Int | LABEL CLabel | FUNBEGIN CLabel | FUNEND CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm]
-data AlphaRegs {-# GHC_PRAGMA SRegs BitSet BitSet #-}
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
-data Reg {-# GHC_PRAGMA FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind #-}
-data BitSet {-# GHC_PRAGMA MkBS Word# #-}
+data AlphaRegs
+data MagicId
+data Reg
+data BitSet
data CLabel
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
+data CSeq
data Cond = EQ | LT | LE | ULT | ULE | NE | GT | GE | ALWAYS | NEVER
-data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
+data FiniteMap a b
data Imm = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq
-data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data CodeSegment {-# GHC_PRAGMA DataSegment | TextSegment #-}
+data OrdList a
+data PrimKind
+data CodeSegment
data RI = RIReg Reg | RIImm Imm
data Size = B | BU | W | WU | L | Q | FF | DF | GF | SF | TF
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data UniqFM a
type UniqSet a = UniqFM a
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Unique
argRegs :: [(Reg, Reg)]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
baseRegOffset :: MagicId -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
callerSaves :: MagicId -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
f0 :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
freeRegs :: [Reg]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
gp :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [29#] _N_ #-}
kindToSize :: PrimKind -> Size
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-}
printLabeledCodes :: PprStyle -> [AlphaInstr] -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
pv :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
ra :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [26#] _N_ #-}
reservedRegs :: [Int]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
sp :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [30#] _N_ #-}
stgRegMap :: MagicId -> Labda Reg
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
strImmLab :: [Char] -> Imm
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
v0 :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
zero :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [31#] _N_ #-}
instance MachineCode AlphaInstr
- {-# GHC_PRAGMA _M_ AlphaCode {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 6 _!_ _TUP_5 [(AlphaInstr -> RegUsage), (AlphaInstr -> RegLiveness -> RegLiveness), (AlphaInstr -> (Reg -> Reg) -> AlphaInstr), (Reg -> Reg -> OrdList AlphaInstr), (Reg -> Reg -> OrdList AlphaInstr)] [_CONSTM_ MachineCode regUsage (AlphaInstr), _CONSTM_ MachineCode regLiveness (AlphaInstr), _CONSTM_ MachineCode patchRegs (AlphaInstr), _CONSTM_ MachineCode spillReg (AlphaInstr), _CONSTM_ MachineCode loadReg (AlphaInstr)] _N_
- regUsage = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
- regLiveness = _A_ 2 _U_ 11 _N_ _S_ "SU(LU(LL))" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_,
- patchRegs = _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_,
- spillReg = _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_,
- loadReg = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
instance MachineRegisters AlphaRegs
- {-# GHC_PRAGMA _M_ AlphaCode {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 7 _!_ _TUP_6 [([Int] -> AlphaRegs), (PrimKind -> AlphaRegs -> [Int]), (AlphaRegs -> Int# -> AlphaRegs), (AlphaRegs -> [Int] -> AlphaRegs), (AlphaRegs -> Int# -> AlphaRegs), (AlphaRegs -> [Int] -> AlphaRegs)] [_CONSTM_ MachineRegisters mkMRegs (AlphaRegs), _CONSTM_ MachineRegisters possibleMRegs (AlphaRegs), _CONSTM_ MachineRegisters useMReg (AlphaRegs), _CONSTM_ MachineRegisters useMRegs (AlphaRegs), _CONSTM_ MachineRegisters freeMReg (AlphaRegs), _CONSTM_ MachineRegisters freeMRegs (AlphaRegs)] _N_
- mkMRegs = _A_ 1 _U_ 1 _N_ _N_ _N_ _N_,
- possibleMRegs = _A_ 2 _U_ 11 _N_ _S_ "EU(LL)" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_,
- useMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_,
- useMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_,
- freeMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_,
- freeMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_ #-}
| FUNEND CLabel
| COMMENT FAST_STRING
| SEGMENT CodeSegment
- | ASCII Bool String
+ | ASCII Bool String -- needs backslash conversion?
| DATA Size [Imm]
type AlphaCode = OrdList AlphaInstr
baseRegOffset Hp = OFFSET_Hp
baseRegOffset HpLim = OFFSET_HpLim
baseRegOffset LivenessReg = OFFSET_Liveness
-baseRegOffset ActivityReg = OFFSET_Activity
+--baseRegOffset ActivityReg = OFFSET_Activity
#ifdef DEBUG
baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg"
callerSaves LivenessReg = True
#endif
#ifdef CALLER_SAVES_Activity
-callerSaves ActivityReg = True
+--callerSaves ActivityReg = True
#endif
#ifdef CALLER_SAVES_StdUpdRetVec
callerSaves StdUpdRetVecReg = True
stgRegMap LivenessReg = Just (FixedReg ILIT(REG_Liveness))
#endif
#ifdef REG_Activity
-stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity))
+--stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity))
#endif
#ifdef REG_StdUpdRetVec
stgRegMap StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec))
freeReg ILIT(REG_Liveness) = _FALSE_
#endif
#ifdef REG_Activity
-freeReg ILIT(REG_Activity) = _FALSE_
+--freeReg ILIT(REG_Activity) = _FALSE_
#endif
#ifdef REG_StdUpdRetVec
freeReg ILIT(REG_StdUpdRetVec) = _FALSE_
import PrimKind(PrimKind)
import PrimOps(PrimOp)
import SMRep(SMRep, SMSpecRepKind, SMUpdateKind)
+import SplitUniq(SplitUniqSupply)
import Stix(CodeSegment, StixReg, StixTree)
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
-data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-}
-data RegLoc {-# GHC_PRAGMA Save StixTree | Always StixTree #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-}
-data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
-mkAlpha :: (GlobalSwitch -> SwitchResult) -> Target
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
+data MagicId
+data SwitchResult
+data RegLoc
+data PprStyle
+data PrimKind
+data SMRep
+data StixTree
+mkAlpha :: (GlobalSwitch -> SwitchResult) -> (Target, PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq, Bool, [Char] -> [Char])
\begin{code}
vsaves switches vols =
- map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,ActivityReg] ++ vols))
+ map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols))
where
save x = StAssign (kindFromMagicId x) loc reg
where reg = StReg (StixMagicId x)
vrests switches vols =
map restore ((filter callerSaves)
- ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,ActivityReg,StkStubReg,StdUpdRetVecReg] ++ vols))
+ ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,{-ActivityReg,-}StkStubReg,StdUpdRetVecReg] ++ vols))
where
restore x = StAssign (kindFromMagicId x) reg loc
where reg = StReg (StixMagicId x)
\begin{code}
-mkAlpha :: (GlobalSwitch -> SwitchResult) -> Target
+mkAlpha :: (GlobalSwitch -> SwitchResult)
+ -> (Target,
+ (PprStyle -> [[StixTree]] -> SUniqSM Unpretty), -- codeGen
+ Bool, -- underscore
+ (String -> String)) -- fmtAsmLbl
mkAlpha switches =
- let fhs' = fhs switches
+ let
+ fhs' = fhs switches
vhs' = vhs switches
alphaReg' = alphaReg switches
vsaves' = vsaves switches
dhs' = dhs switches
ps = genPrimCode target
mc = genMacroCode target
- hc = doHeapCheck target
- target = mkTarget switches fhs' vhs' alphaReg' id size vsaves' vrests'
- hprel as as' csz isz mhs' dhs' ps mc hc
- alphaCodeGen False mungeLabel
- in target
-
+ hc = doHeapCheck --UNUSED NOW: target
+ target = mkTarget {-switches-} fhs' vhs' alphaReg' {-id-} size
+ hprel as as'
+ (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc)
+ {-alphaCodeGen False mungeLabel-}
+ in
+ (target, alphaCodeGen, False, mungeLabel)
\end{code}
The alpha assembler likes temporary labels to look like \tr{$L123}
import PrimOps(PrimOp)
import SplitUniq(SplitUniqSupply)
import Stix(CodeSegment, StixReg, StixTree)
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
-data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
+data CSeq
+data PprStyle
+data StixTree
alphaCodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 211 _N_ _S_ "LS" _N_ _N_ #-}
IntSubOp -> trivialCode (SUB Q False) args
IntMulOp -> trivialCode (MUL Q False) args
IntQuotOp -> trivialCode (DIV Q False) args
- IntDivOp -> call SLIT("stg_div") IntKind
IntRemOp -> trivialCode (REM Q False) args
IntNegOp -> trivialUCode (NEG Q False) args
IntAbsOp -> trivialUCode (ABS Q) args
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface AsmCodeGen where
-import AbsCSyn(AbstractC, CAddrMode, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import BasicLit(BasicLit)
-import CLabelInfo(CLabel)
-import ClosureInfo(ClosureInfo)
+import AbsCSyn(AbstractC)
import CmdLineOpts(GlobalSwitch, SwitchResult)
-import CostCentre(CostCentre)
-import Maybes(Labda)
-import PreludePS(_PackedString)
-import PrimOps(PrimOp)
import SplitUniq(SUniqSM(..), SplitUniqSupply)
import Stdio(_FILE)
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-}
+data AbstractC
+data GlobalSwitch
+data SwitchResult
type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
+data SplitUniqSupply
dumpRealAsm :: (GlobalSwitch -> SwitchResult) -> AbstractC -> SplitUniqSupply -> [Char]
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "SLU(ALL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
writeRealAsm :: (GlobalSwitch -> SwitchResult) -> _FILE -> AbstractC -> SplitUniqSupply -> _State _RealWorld -> ((), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 5 _U_ 21212 _N_ _S_ "SU(P)LU(ALL)L" {_A_ 5 _U_ 22212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import MachDesc
import Maybes ( Maybe(..) )
import Outputable
-#if alpha_dec_osf1_TARGET
+#if alpha_TARGET_ARCH
import AlphaDesc ( mkAlpha )
-#else
+#endif
+#if i386_TARGET_ARCH
+import I386Desc ( mkI386 )
+#endif
#if sparc_TARGET_ARCH
import SparcDesc ( mkSparc )
#endif
-#endif
import Stix
import SplitUniq
import Unique
let
stix = map (map (genericOpt target)) treelists
in
- codeGen target sty stix
+ codeGen {-target-} sty stix
where
- sty = PprForAsm (switchIsOn flags) (underscore target) (fmtAsmLbl target)
+ sty = PprForAsm (switchIsOn flags) (underscore {-target-}) (fmtAsmLbl {-target-})
- target = case stringSwitchSet flags AsmTarget of
+ (target, codeGen, underscore, fmtAsmLbl)
+ = case stringSwitchSet flags AsmTarget of
#if ! OMIT_NATIVE_CODEGEN
-#if sparc_sun_sunos4_TARGET
+# if alpha_TARGET_ARCH
+ Just _ {-???"alpha-dec-osf1"-} -> mkAlpha flags
+# endif
+# if i386_TARGET_ARCH
+ Just _ {-???"i386_unknown_linuxaout"-} -> mkI386 True flags
+# endif
+# if sparc_sun_sunos4_TARGET
Just _ {-???"sparc-sun-sunos4"-} -> mkSparc True flags
-#endif
-#if sparc_sun_solaris2_TARGET
+# endif
+# if sparc_sun_solaris2_TARGET
Just _ {-???"sparc-sun-solaris2"-} -> mkSparc False flags
-#endif
-#if alpha_TARGET_ARCH
- Just _ {-???"alpha-dec-osf1"-} -> mkAlpha flags
-#endif
+# endif
#endif
_ -> error
("ERROR:Trying to generate assembly language for an unsupported architecture\n"++
For most nodes, just optimize the children.
\begin{code}
+-- hacking with Uncle Will:
+#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
-genericOpt target (StInd pk addr) =
+genericOpt target_STRICT (StInd pk addr) =
StInd pk (genericOpt target addr)
genericOpt target (StAssign pk dst src) =
IntSubOp -> StInt (x - y)
IntMulOp -> StInt (x * y)
IntQuotOp -> StInt (x `quot` y)
- IntDivOp -> StInt (x `div` y)
IntRemOp -> StInt (x `rem` y)
IntGtOp -> StInt (if x > y then 1 else 0)
IntGeOp -> StInt (if x >= y then 1 else 0)
primOpt op args@[x, y@(StInt 1)] =
case op of
IntMulOp -> x
- IntDivOp -> x
IntQuotOp -> x
IntRemOp -> StInt 0
_ -> StPrim op args
import CLabelInfo(CLabel)
import FiniteMap(FiniteMap)
import OrdList(OrdList)
-import Outputable(NamedThing)
+import Outputable(NamedThing, Outputable)
import PrimKind(PrimKind)
import UniqFM(UniqFM)
import UniqSet(UniqSet(..))
import Unique(Unique)
class MachineCode a where
regUsage :: a -> RegUsage
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(SAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> RegUsage) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> RegUsage) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.regUsage\"", u2 ] _N_ #-}
regLiveness :: a -> RegLiveness -> RegLiveness
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(ASAAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> RegLiveness -> RegLiveness) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: u0) (u3 :: RegLiveness) -> _APP_ _TYAPP_ patError# { (u0 -> RegLiveness -> RegLiveness) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.regLiveness\"", u2, u3 ] _N_ #-}
patchRegs :: a -> (Reg -> Reg) -> a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AASAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> (Reg -> Reg) -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: u0) (u3 :: Reg -> Reg) -> _APP_ _TYAPP_ patError# { (u0 -> (Reg -> Reg) -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.patchRegs\"", u2, u3 ] _N_ #-}
spillReg :: Reg -> Reg -> OrdList a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAASA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: Reg -> Reg -> OrdList u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: Reg) (u3 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Reg -> OrdList u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.spillReg\"", u2, u3 ] _N_ #-}
loadReg :: Reg -> Reg -> OrdList a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAAAS)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: Reg -> Reg -> OrdList u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> RegUsage, u0 -> RegLiveness -> RegLiveness, u0 -> (Reg -> Reg) -> u0, Reg -> Reg -> OrdList u0, Reg -> Reg -> OrdList u0)) -> case u1 of { _ALG_ _TUP_5 (u2 :: u0 -> RegUsage) (u3 :: u0 -> RegLiveness -> RegLiveness) (u4 :: u0 -> (Reg -> Reg) -> u0) (u5 :: Reg -> Reg -> OrdList u0) (u6 :: Reg -> Reg -> OrdList u0) -> u6; _NO_DEFLT_ } _N_
- {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineCode u0}}) (u2 :: Reg) (u3 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Reg -> OrdList u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineCode.loadReg\"", u2, u3 ] _N_ #-}
class MachineRegisters a where
mkMRegs :: [Int] -> a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(SAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: [Int] -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: [Int]) -> _APP_ _TYAPP_ patError# { ([Int] -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.mkMRegs\"", u2 ] _N_ #-}
possibleMRegs :: PrimKind -> a -> [Int]
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(ASAAAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PrimKind -> u0 -> [Int]) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: PrimKind) (u3 :: u0) -> _APP_ _TYAPP_ patError# { (PrimKind -> u0 -> [Int]) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.possibleMRegs\"", u2, u3 ] _N_ #-}
useMReg :: a -> Int# -> a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Int# -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: u0) (u3 :: Int#) -> _APP_ _TYAPP_ patError# { (u0 -> Int# -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.useMReg\"", u2, u3 ] _N_ #-}
useMRegs :: a -> [Int] -> a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAASAA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> [Int] -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: u0) (u3 :: [Int]) -> _APP_ _TYAPP_ patError# { (u0 -> [Int] -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.useMRegs\"", u2, u3 ] _N_ #-}
freeMReg :: a -> Int# -> a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAAASA)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Int# -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u6; _NO_DEFLT_ } _N_
- {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: u0) (u3 :: Int#) -> _APP_ _TYAPP_ patError# { (u0 -> Int# -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.freeMReg\"", u2, u3 ] _N_ #-}
freeMRegs :: a -> [Int] -> a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> [Int] -> u0) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: ([Int] -> u0, PrimKind -> u0 -> [Int], u0 -> Int# -> u0, u0 -> [Int] -> u0, u0 -> Int# -> u0, u0 -> [Int] -> u0)) -> case u1 of { _ALG_ _TUP_6 (u2 :: [Int] -> u0) (u3 :: PrimKind -> u0 -> [Int]) (u4 :: u0 -> Int# -> u0) (u5 :: u0 -> [Int] -> u0) (u6 :: u0 -> Int# -> u0) (u7 :: u0 -> [Int] -> u0) -> u7; _NO_DEFLT_ } _N_
- {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{MachineRegisters u0}}) (u2 :: u0) (u3 :: [Int]) -> _APP_ _TYAPP_ patError# { (u0 -> [Int] -> u0) } [ _NOREP_S_ "%DAsmRegAlloc.MachineRegisters.freeMRegs\"", u2, u3 ] _N_ #-}
data CLabel
-data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
+data FiniteMap a b
data FutureLive = FL (UniqFM Reg) (FiniteMap CLabel (UniqFM Reg))
-data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
+data OrdList a
+data PrimKind
data Reg = FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind
data RegLiveness = RL (UniqFM Reg) FutureLive
data RegUsage = RU (UniqFM Reg) (UniqFM Reg)
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data UniqFM a
type UniqSet a = UniqFM a
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Unique
extractMappedRegNos :: [Reg] -> [Int]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkReg :: Unique -> PrimKind -> Reg
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: PrimKind) -> _!_ _ORIG_ AsmRegAlloc UnmappedReg [] [u0, u1] _N_ #-}
+runHairyRegAllocate :: (MachineRegisters a, MachineCode b) => a -> [Int] -> OrdList b -> [b]
runRegAllocate :: (MachineRegisters a, MachineCode b) => a -> [Int] -> OrdList b -> [b]
- {-# GHC_PRAGMA _A_ 5 _U_ 22221 _N_ _S_ "LLLLS" _N_ _SPECIALISE_ [ AlphaRegs, AlphaInstr ] 2 { _A_ 0 _U_ 221 _N_ _N_ _N_ _N_ } #-}
instance Eq Reg
- {-# GHC_PRAGMA _M_ AsmRegAlloc {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Reg -> Reg -> Bool), (Reg -> Reg -> Bool)] [_CONSTM_ Eq (==) (Reg), _CONSTM_ Eq (/=) (Reg)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord Reg
- {-# GHC_PRAGMA _M_ AsmRegAlloc {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Reg}}, (Reg -> Reg -> Bool), (Reg -> Reg -> Bool), (Reg -> Reg -> Bool), (Reg -> Reg -> Bool), (Reg -> Reg -> Reg), (Reg -> Reg -> Reg), (Reg -> Reg -> _CMP_TAG)] [_DFUN_ Eq (Reg), _CONSTM_ Ord (<) (Reg), _CONSTM_ Ord (<=) (Reg), _CONSTM_ Ord (>=) (Reg), _CONSTM_ Ord (>) (Reg), _CONSTM_ Ord max (Reg), _CONSTM_ Ord min (Reg), _CONSTM_ Ord _tagCmp (Reg)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance NamedThing Reg
- {-# GHC_PRAGMA _M_ AsmRegAlloc {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Reg -> ExportFlag), (Reg -> Bool), (Reg -> (_PackedString, _PackedString)), (Reg -> _PackedString), (Reg -> [_PackedString]), (Reg -> SrcLoc), (Reg -> Unique), (Reg -> Bool), (Reg -> UniType), (Reg -> Bool)] [_CONSTM_ NamedThing getExportFlag (Reg), _CONSTM_ NamedThing isLocallyDefined (Reg), _CONSTM_ NamedThing getOrigName (Reg), _CONSTM_ NamedThing getOccurrenceName (Reg), _CONSTM_ NamedThing getInformingModules (Reg), _CONSTM_ NamedThing getSrcLoc (Reg), _CONSTM_ NamedThing getTheUnique (Reg), _CONSTM_ NamedThing hasType (Reg), _CONSTM_ NamedThing getType (Reg), _CONSTM_ NamedThing fromPreludeCore (Reg)] _N_
- getExportFlag = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u0 ] _N_,
- isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u0 ] _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u0 ] _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u0 ] _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_,
- getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u0 ] _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Reg) -> _APP_ _TYAPP_ patError# { (Reg -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u0 ] _N_ #-}
+instance Outputable Reg
instance Text Reg
- {-# GHC_PRAGMA _M_ AsmRegAlloc {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Reg, [Char])]), (Int -> Reg -> [Char] -> [Char]), ([Char] -> [([Reg], [Char])]), ([Reg] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Reg), _CONSTM_ Text showsPrec (Reg), _CONSTM_ Text readList (Reg), _CONSTM_ Text showList (Reg)] _N_
- readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(Reg, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 2 _U_ 012 _N_ _S_ "AS" {_A_ 1 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
FutureLive(..), RegLiveness(..), RegUsage(..), Reg(..),
MachineRegisters(..), MachineCode(..),
- mkReg, runRegAllocate,
+ mkReg, runRegAllocate, runHairyRegAllocate,
extractMappedRegNos,
-- And, for self-sufficiency
#if ! OMIT_NATIVE_CODEGEN
-#if sparc_TARGET_ARCH
-import SparcCode -- ( SparcInstr, SparcRegs ) -- for specializing
+# if alpha_TARGET_ARCH
+import AlphaCode -- ( AlphaInstr, AlphaRegs ) -- for specializing
{-# SPECIALIZE
- runRegAllocate :: SparcRegs -> [Int] -> (OrdList SparcInstr) -> [SparcInstr]
+ runRegAllocate :: AlphaRegs -> [Int] -> (OrdList AlphaInstr) -> [AlphaInstr]
#-}
-#endif
-#if alpha_TARGET_ARCH
-import AlphaCode -- ( AlphaInstr, AlphaRegs ) -- for specializing
+# endif
+
+# if i386_TARGET_ARCH
+import I386Code -- ( I386Instr, I386Regs ) -- for specializing
{-# SPECIALIZE
- runRegAllocate :: AlphaRegs -> [Int] -> (OrdList AlphaInstr) -> [AlphaInstr]
+ runRegAllocate :: I386Regs -> [Int] -> (OrdList I386Instr) -> [I386Instr]
#-}
-#endif
+# endif
+
+# if sparc_TARGET_ARCH
+import SparcCode -- ( SparcInstr, SparcRegs ) -- for specializing
+
+{-# SPECIALIZE
+ runRegAllocate :: SparcRegs -> [Int] -> (OrdList SparcInstr) -> [SparcInstr]
+ #-}
+# endif
#endif
simpleAlloc = simpleRegAlloc regs [] emptyFM flatInstrs
hairyAlloc = hairyRegAlloc regs reserve_regs flatInstrs
+runHairyRegAllocate -- use only hairy for i386!
+ :: (MachineRegisters a, MachineCode b)
+ => a
+ -> [Int]
+ -> (OrdList b)
+ -> [b]
+
+runHairyRegAllocate regs reserve_regs instrs
+ = hairyRegAlloc regs reserve_regs flatInstrs
+ where
+ flatInstrs = flattenOrdList instrs
\end{code}
Here is the simple register allocator. Just dole out registers until
--- /dev/null
+{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+interface I386Code where
+import AbsCSyn(MagicId)
+import AsmRegAlloc(MachineCode, MachineRegisters, Reg)
+import BitSet(BitSet)
+import CLabelInfo(CLabel)
+import CharSeq(CSeq)
+import FiniteMap(FiniteMap)
+import Maybes(Labda)
+import OrdList(OrdList)
+import PreludePS(_PackedString)
+import Pretty(PprStyle)
+import PrimKind(PrimKind)
+import Stix(CodeSegment)
+import UniqFM(UniqFM)
+import UniqSet(UniqSet(..))
+import Unique(Unique)
+data Addr = Addr (Labda Reg) (Labda (Reg, Int)) Imm | ImmAddr Imm Int
+type Base = Labda Reg
+data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
+data Reg {-# GHC_PRAGMA FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind #-}
+data BitSet {-# GHC_PRAGMA MkBS Word# #-}
+data CLabel
+data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
+data CodeSegment {-# GHC_PRAGMA DataSegment | TextSegment #-}
+data Cond = ALWAYS | GEU | LU | EQ | GT | GE | GU | LT | LE | LEU | NE | NEG | POS
+type Displacement = Imm
+data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
+type I386Code = OrdList I386Instr
+data I386Instr
+ = MOV Size Operand Operand | MOVZX Size Operand Operand | MOVSX Size Operand Operand | LEA Size Operand Operand | ADD Size Operand Operand | SUB Size Operand Operand | IMUL Size Operand Operand | IDIV Size Operand | AND Size Operand Operand | OR Size Operand Operand | XOR Size Operand Operand | NOT Size Operand | NEGI Size Operand | SHL Size Operand Operand | SAR Size Operand Operand | SHR Size Operand Operand | NOP | SAHF | FABS | FADD Size Operand | FADDP | FIADD Size Addr | FCHS | FCOM Size Operand | FCOS | FDIV Size Operand | FDIVP | FIDIV Size Addr | FDIVR Size Operand | FDIVRP | FIDIVR Size Addr | FICOM Size Addr | FILD Size Addr Reg | FIST Size Addr | FLD Size Operand | FLD1 | FLDZ | FMUL Size Operand | FMULP | FIMUL Size Addr | FRNDINT | FSIN | FSQRT | FST Size Operand | FSTP Size Operand | FSUB Size Operand | FSUBP | FISUB Size Addr | FSUBR Size Operand | FSUBRP | FISUBR Size Addr | FTST | FCOMP Size Operand | FUCOMPP | FXCH | FNSTSW | FNOP | TEST Size Operand Operand | CMP Size Operand Operand | SETCC Cond Operand | PUSH Size Operand | POP Size Operand | JMP Operand | JXX Cond CLabel | CALL Imm | CLTD | LABEL CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm]
+data I386Regs {-# GHC_PRAGMA SRegs BitSet BitSet #-}
+data Imm = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq | ImmLit CSeq
+type Index = Labda (Reg, Int)
+data Operand = OpReg Reg | OpImm Imm | OpAddr Addr
+data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-}
+data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
+data Size = B | HB | S | L | F | D
+data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+type UniqSet a = UniqFM a
+data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+baseRegOffset :: MagicId -> Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
+callerSaves :: MagicId -> Bool
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 21 \ (u0 :: MagicId) -> case u0 of { _ALG_ _ORIG_ AbsCSyn Hp -> _!_ True [] []; (u1 :: MagicId) -> _!_ False [] [] } _N_ #-}
+eax :: Reg
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [0#] _N_ #-}
+ebp :: Reg
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [6#] _N_ #-}
+ebx :: Reg
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [1#] _N_ #-}
+ecx :: Reg
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [2#] _N_ #-}
+edi :: Reg
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [5#] _N_ #-}
+edx :: Reg
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [3#] _N_ #-}
+esi :: Reg
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [4#] _N_ #-}
+esp :: Reg
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [7#] _N_ #-}
+freeRegs :: [Reg]
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+is13Bits :: Integral a => a -> Bool
+ {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(LU(U(ALASAAAA)AAA)AAAAAAAAAA)" {_A_ 3 _U_ 1112 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Integer ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(PPP)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
+kindToSize :: PrimKind -> Size
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-}
+offset :: Addr -> Int -> Labda Addr
+ {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-}
+printLabeledCodes :: PprStyle -> [I386Instr] -> CSeq
+ {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
+reservedRegs :: [Int]
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _NIL_ [Int] [] _N_ #-}
+spRel :: Int -> Addr
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
+st0 :: Reg
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+st1 :: Reg
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+stgRegMap :: MagicId -> Labda Reg
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
+strImmLit :: [Char] -> Imm
+ {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
+instance MachineCode I386Instr
+ {-# GHC_PRAGMA _M_ I386Code {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 6 _!_ _TUP_5 [(I386Instr -> RegUsage), (I386Instr -> RegLiveness -> RegLiveness), (I386Instr -> (Reg -> Reg) -> I386Instr), (Reg -> Reg -> OrdList I386Instr), (Reg -> Reg -> OrdList I386Instr)] [_CONSTM_ MachineCode regUsage (I386Instr), _CONSTM_ MachineCode regLiveness (I386Instr), _CONSTM_ MachineCode patchRegs (I386Instr), _CONSTM_ MachineCode spillReg (I386Instr), _CONSTM_ MachineCode loadReg (I386Instr)] _N_
+ regUsage = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
+ regLiveness = _A_ 2 _U_ 11 _N_ _S_ "SU(LU(LL))" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_,
+ patchRegs = _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_,
+ spillReg = _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_,
+ loadReg = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
+instance MachineRegisters I386Regs
+ {-# GHC_PRAGMA _M_ I386Code {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 7 _!_ _TUP_6 [([Int] -> I386Regs), (PrimKind -> I386Regs -> [Int]), (I386Regs -> Int# -> I386Regs), (I386Regs -> [Int] -> I386Regs), (I386Regs -> Int# -> I386Regs), (I386Regs -> [Int] -> I386Regs)] [_CONSTM_ MachineRegisters mkMRegs (I386Regs), _CONSTM_ MachineRegisters possibleMRegs (I386Regs), _CONSTM_ MachineRegisters useMReg (I386Regs), _CONSTM_ MachineRegisters useMRegs (I386Regs), _CONSTM_ MachineRegisters freeMReg (I386Regs), _CONSTM_ MachineRegisters freeMRegs (I386Regs)] _N_
+ mkMRegs = _A_ 1 _U_ 1 _N_ _N_ _N_ _N_,
+ possibleMRegs = _A_ 2 _U_ 11 _N_ _S_ "EU(LL)" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_,
+ useMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_,
+ useMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_,
+ freeMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LL)P" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_,
+ freeMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1993-1995
+%
+
+\section[I386Code]{The Native (I386) Machine Code}
+
+\begin{code}
+#define ILIT2(x) ILIT(x)
+#include "HsVersions.h"
+
+module I386Code (
+ Addr(..),
+ Cond(..), Imm(..), Operand(..), Size(..),
+ Base(..), Index(..), Displacement(..),
+ I386Code(..),I386Instr(..),I386Regs,
+ strImmLit, --UNUSED: strImmLab,
+ spRel,
+
+ printLabeledCodes,
+
+ baseRegOffset, stgRegMap, callerSaves,
+
+ is13Bits, offset,
+
+ kindToSize,
+
+ st0, st1, eax, ebx, ecx, edx, esi, edi, ebp, esp,
+
+ freeRegs, reservedRegs,
+
+ -- and, for self-sufficiency ...
+ CLabel, CodeSegment, OrdList, PrimKind, Reg, UniqSet(..),
+ UniqFM, FiniteMap, Unique, MagicId, CSeq, BitSet
+ ) where
+
+IMPORT_Trace
+
+import AbsCSyn ( MagicId(..) )
+import AsmRegAlloc ( MachineCode(..), MachineRegisters(..), FutureLive(..),
+ Reg(..), RegUsage(..), RegLiveness(..)
+ )
+import BitSet
+import CgCompInfo ( mAX_Double_REG, mAX_Float_REG, mAX_Vanilla_REG )
+import CLabelInfo ( CLabel, pprCLabel, externallyVisibleCLabel, charToC )
+import FiniteMap
+import Maybes ( Maybe(..), maybeToBool )
+import OrdList ( OrdList, mkUnitList, flattenOrdList )
+import Outputable
+import PrimKind ( PrimKind(..) )
+import UniqSet
+import Stix
+import Unpretty
+import Util
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[I386Reg]{The Native (I386) Machine Register Table}
+%* *
+%************************************************************************
+
+- All registers except 7 (esp) are available for use.
+- Only ebx, esi, edi and esp are available across a C call (they are callee-saves).
+- Registers 0-7 have 16-bit counterparts (ax, bx etc.)
+- Registers 0-3 have 8 bit counterparts (ah, bh etc.)
+- Registers 8-15 hold extended floating point values.
+
+ToDo: Deal with stg registers that live as offsets from BaseReg!(JSM)
+
+\begin{code}
+
+gReg,fReg :: Int -> Int
+gReg x = x
+fReg x = (8 + x)
+
+st0, st1, st2, st3, st4, st5, st6, st7, eax, ebx, ecx, edx, esp :: Reg
+eax = case (gReg 0) of { IBOX(g0) -> FixedReg g0 }
+ebx = case (gReg 1) of { IBOX(g1) -> FixedReg g1 }
+ecx = case (gReg 2) of { IBOX(g2) -> FixedReg g2 }
+edx = case (gReg 3) of { IBOX(g3) -> FixedReg g3 }
+esi = case (gReg 4) of { IBOX(g4) -> FixedReg g4 }
+edi = case (gReg 5) of { IBOX(g5) -> FixedReg g5 }
+ebp = case (gReg 6) of { IBOX(g6) -> FixedReg g6 }
+esp = case (gReg 7) of { IBOX(g7) -> FixedReg g7 }
+st0 = realReg (fReg 0)
+st1 = realReg (fReg 1)
+st2 = realReg (fReg 2)
+st3 = realReg (fReg 3)
+st4 = realReg (fReg 4)
+st5 = realReg (fReg 5)
+st6 = realReg (fReg 6)
+st7 = realReg (fReg 7)
+
+realReg n@IBOX(i) = if _IS_TRUE_(freeReg i) then MappedReg i else FixedReg i
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[TheI386Code]{The datatype for i386 assembly language}
+%* *
+%************************************************************************
+
+Here is a definition of the I386 assembly language.
+
+\begin{code}
+
+data Imm = ImmInt Int
+ | ImmInteger Integer -- Sigh.
+ | ImmCLbl CLabel -- AbstractC Label (with baggage)
+ | ImmLab Unpretty -- Simple string label (underscored)
+ | ImmLit Unpretty -- Simple string
+ deriving ()
+
+--UNUSED:strImmLab s = ImmLab (uppStr s)
+strImmLit s = ImmLit (uppStr s)
+
+data Cond = ALWAYS
+ | GEU
+ | LU
+ | EQ
+ | GT
+ | GE
+ | GU
+ | LT
+ | LE
+ | LEU
+ | NE
+ | NEG
+ | POS
+ deriving ()
+
+
+data Size = B
+ | HB
+ | S -- unused ?
+ | L
+ | F
+ | D
+ deriving ()
+
+data Operand = OpReg Reg -- register
+ | OpImm Imm -- immediate value
+ | OpAddr Addr -- memory reference
+ deriving ()
+
+data Addr = Addr Base Index Displacement
+ | ImmAddr Imm Int
+ -- deriving Eq
+
+type Base = Maybe Reg
+type Index = Maybe (Reg, Int) -- Int is 2, 4 or 8
+type Displacement = Imm
+
+data I386Instr =
+
+-- Moves.
+
+ MOV Size Operand Operand
+ | MOVZX Size Operand Operand -- size is the size of operand 2
+ | MOVSX Size Operand Operand -- size is the size of operand 2
+
+-- Load effective address (also a very useful three-operand add instruction :-)
+
+ | LEA Size Operand Operand
+
+-- Int Arithmetic.
+
+ | ADD Size Operand Operand
+ | SUB Size Operand Operand
+
+-- Multiplication (signed and unsigned), Division (signed and unsigned),
+-- result in %eax, %edx.
+
+ | IMUL Size Operand Operand
+ | IDIV Size Operand
+
+-- Simple bit-twiddling.
+
+ | AND Size Operand Operand
+ | OR Size Operand Operand
+ | XOR Size Operand Operand
+ | NOT Size Operand
+ | NEGI Size Operand -- NEG instruction (name clash with Cond)
+ | SHL Size Operand Operand -- 1st operand must be an Imm
+ | SAR Size Operand Operand -- 1st operand must be an Imm
+ | SHR Size Operand Operand -- 1st operand must be an Imm
+ | NOP
+
+-- Float Arithmetic. -- ToDo for 386
+
+-- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions
+-- right up until we spit them out.
+
+ | SAHF -- stores ah into flags
+ | FABS
+ | FADD Size Operand -- src
+ | FADDP
+ | FIADD Size Addr -- src
+ | FCHS
+ | FCOM Size Operand -- src
+ | FCOS
+ | FDIV Size Operand -- src
+ | FDIVP
+ | FIDIV Size Addr -- src
+ | FDIVR Size Operand -- src
+ | FDIVRP
+ | FIDIVR Size Addr -- src
+ | FICOM Size Addr -- src
+ | FILD Size Addr Reg -- src, dst
+ | FIST Size Addr -- dst
+ | FLD Size Operand -- src
+ | FLD1
+ | FLDZ
+ | FMUL Size Operand -- src
+ | FMULP
+ | FIMUL Size Addr -- src
+ | FRNDINT
+ | FSIN
+ | FSQRT
+ | FST Size Operand -- dst
+ | FSTP Size Operand -- dst
+ | FSUB Size Operand -- src
+ | FSUBP
+ | FISUB Size Addr -- src
+ | FSUBR Size Operand -- src
+ | FSUBRP
+ | FISUBR Size Addr -- src
+ | FTST
+ | FCOMP Size Operand -- src
+ | FUCOMPP
+ | FXCH
+ | FNSTSW
+ | FNOP
+
+-- Comparison
+
+ | TEST Size Operand Operand
+ | CMP Size Operand Operand
+ | SETCC Cond Operand
+
+-- Stack Operations.
+
+ | PUSH Size Operand
+ | POP Size Operand
+
+-- Jumping around.
+
+ | JMP Operand -- target
+ | JXX Cond CLabel -- target
+ | CALL Imm
+
+-- Other things.
+
+ | CLTD -- sign extend %eax into %edx:%eax
+
+-- Pseudo-ops.
+
+ | LABEL CLabel
+ | COMMENT FAST_STRING
+ | SEGMENT CodeSegment
+ | ASCII Bool String -- needs backslash conversion?
+ | DATA Size [Imm]
+
+type I386Code = OrdList I386Instr
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[TheI386Pretty]{Pretty-printing the I386 Assembly Language}
+%* *
+%************************************************************************
+
+\begin{code}
+
+printLabeledCodes :: PprStyle -> [I386Instr] -> Unpretty
+printLabeledCodes sty codes = uppAboves (map (pprI386Instr sty) codes)
+
+\end{code}
+
+Printing the pieces...
+
+\begin{code}
+
+pprReg :: Size -> Reg -> Unpretty
+
+pprReg s (FixedReg i) = pprI386Reg s i
+pprReg s (MappedReg i) = pprI386Reg s i
+pprReg s other = uppStr (show other) -- should only happen when debugging
+
+pprI386Reg :: Size -> FAST_INT -> Unpretty
+pprI386Reg B i = uppPStr
+ (case i of {
+ ILIT( 0) -> SLIT("%al"); ILIT( 1) -> SLIT("%bl");
+ ILIT( 2) -> SLIT("%cl"); ILIT( 3) -> SLIT("%dl");
+ _ -> SLIT("very naughty I386 byte register")
+ })
+
+pprI386Reg HB i = uppPStr
+ (case i of {
+ ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh");
+ ILIT( 2) -> SLIT("%ch"); ILIT( 3) -> SLIT("%dh");
+ _ -> SLIT("very naughty I386 high byte register")
+ })
+
+pprI386Reg S i = uppPStr
+ (case i of {
+ ILIT( 0) -> SLIT("%ax"); ILIT( 1) -> SLIT("%bx");
+ ILIT( 2) -> SLIT("%cx"); ILIT( 3) -> SLIT("%dx");
+ ILIT( 4) -> SLIT("%si"); ILIT( 5) -> SLIT("%di");
+ ILIT( 6) -> SLIT("%bp"); ILIT( 7) -> SLIT("%sp");
+ _ -> SLIT("very naughty I386 word register")
+ })
+
+pprI386Reg L i = uppPStr
+ (case i of {
+ ILIT( 0) -> SLIT("%eax"); ILIT( 1) -> SLIT("%ebx");
+ ILIT( 2) -> SLIT("%ecx"); ILIT( 3) -> SLIT("%edx");
+ ILIT( 4) -> SLIT("%esi"); ILIT( 5) -> SLIT("%edi");
+ ILIT( 6) -> SLIT("%ebp"); ILIT( 7) -> SLIT("%esp");
+ _ -> SLIT("very naughty I386 double word register")
+ })
+
+pprI386Reg F i = uppPStr
+ (case i of {
+--ToDo: rm these
+ ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
+ ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)");
+ ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
+ ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)");
+ _ -> SLIT("very naughty I386 float register")
+ })
+
+pprI386Reg D i = uppPStr
+ (case i of {
+--ToDo: rm these
+ ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
+ ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)");
+ ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
+ ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)");
+ _ -> SLIT("very naughty I386 float register")
+ })
+
+pprCond :: Cond -> Unpretty -- ToDo
+pprCond x = uppPStr
+ (case x of {
+ GEU -> SLIT("ae"); LU -> SLIT("b");
+ EQ -> SLIT("e"); GT -> SLIT("g");
+ GE -> SLIT("ge"); GU -> SLIT("a");
+ LT -> SLIT("l"); LE -> SLIT("le");
+ LEU -> SLIT("be"); NE -> SLIT("ne");
+ NEG -> SLIT("s"); POS -> SLIT("ns");
+ ALWAYS -> SLIT("mp"); -- hack
+ _ -> error "Spix: iI386Code: unknown conditional!"
+ })
+
+pprDollImm :: PprStyle -> Imm -> Unpretty
+
+pprDollImm sty i = uppBesides [ uppPStr SLIT("$"), pprImm sty i]
+
+pprImm :: PprStyle -> Imm -> Unpretty
+
+pprImm sty (ImmInt i) = uppInt i
+pprImm sty (ImmInteger i) = uppInteger i
+pprImm sty (ImmCLbl l) = pprCLabel sty l
+pprImm sty (ImmLab l) = l
+
+--pprImm (PprForAsm _ False _) (ImmLab s) = s
+--pprImm _ (ImmLab s) = uppBeside (uppChar '_') s
+
+pprImm sty (ImmLit s) = s
+
+pprAddr :: PprStyle -> Addr -> Unpretty
+pprAddr sty (ImmAddr imm off)
+ = uppBesides [pprImm sty imm,
+ if off > 0 then uppChar '+' else uppPStr SLIT(""),
+ if off == 0 then uppPStr SLIT("") else uppInt off
+ ]
+pprAddr sty (Addr Nothing Nothing displacement)
+ = uppBesides [pprDisp sty displacement]
+pprAddr sty (Addr base index displacement)
+ = uppBesides [pprDisp sty displacement,
+ uppChar '(',
+ pprBase base,
+ pprIndex index,
+ uppChar ')'
+ ]
+ where
+ pprBase (Just r) = uppBesides [pprReg L r,
+ case index of
+ Nothing -> uppPStr SLIT("")
+ _ -> uppChar ','
+ ]
+ pprBase _ = uppPStr SLIT("")
+ pprIndex (Just (r,i)) = uppBesides [pprReg L r, uppChar ',', uppInt i]
+ pprIndex _ = uppPStr SLIT("")
+
+pprDisp sty (ImmInt 0) = uppPStr SLIT("")
+--pprDisp sty (ImmInteger 0) = uppPStr SLIT("")
+pprDisp sty d = pprImm sty d
+
+pprOperand :: PprStyle -> Size -> Operand -> Unpretty
+pprOperand sty s (OpReg r) = pprReg s r
+pprOperand sty s (OpImm i) = pprDollImm sty i
+pprOperand sty s (OpAddr ea) = pprAddr sty ea
+
+pprSize :: Size -> Unpretty
+pprSize x = uppPStr
+ (case x of
+ B -> SLIT("b")
+ HB -> SLIT("b")
+ S -> SLIT("w")
+ L -> SLIT("l")
+ F -> SLIT("s")
+ D -> SLIT("l")
+ )
+
+pprSizeOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Unpretty
+pprSizeOp sty name size op1 =
+ uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ pprSize size,
+ uppChar ' ',
+ pprOperand sty size op1
+ ]
+
+pprSizeOpOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Operand -> Unpretty
+pprSizeOpOp sty name size op1 op2 =
+ uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ pprSize size,
+ uppChar ' ',
+ pprOperand sty size op1,
+ uppComma,
+ pprOperand sty size op2
+ ]
+
+pprSizeOpReg :: PprStyle -> FAST_STRING -> Size -> Operand -> Reg -> Unpretty
+pprSizeOpReg sty name size op1 reg =
+ uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ pprSize size,
+ uppChar ' ',
+ pprOperand sty size op1,
+ uppComma,
+ pprReg size reg
+ ]
+
+pprSizeAddr :: PprStyle -> FAST_STRING -> Size -> Addr -> Unpretty
+pprSizeAddr sty name size op =
+ uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ pprSize size,
+ uppChar ' ',
+ pprAddr sty op
+ ]
+
+pprSizeAddrReg :: PprStyle -> FAST_STRING -> Size -> Addr -> Reg -> Unpretty
+pprSizeAddrReg sty name size op dst =
+ uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ pprSize size,
+ uppChar ' ',
+ pprAddr sty op,
+ uppComma,
+ pprReg size dst
+ ]
+
+pprOpOp :: PprStyle -> FAST_STRING -> Size -> Operand -> Operand -> Unpretty
+pprOpOp sty name size op1 op2 =
+ uppBesides [
+ uppChar '\t',
+ uppPStr name,
+ uppChar ' ',
+ pprOperand sty size op1,
+ uppComma,
+ pprOperand sty size op2
+ ]
+
+pprSizeOpOpCoerce :: PprStyle -> FAST_STRING -> Size -> Size -> Operand -> Operand -> Unpretty
+pprSizeOpOpCoerce sty name size1 size2 op1 op2 =
+ uppBesides [ uppChar '\t', uppPStr name, uppChar ' ',
+ pprOperand sty size1 op1,
+ uppComma,
+ pprOperand sty size2 op2
+ ]
+
+pprCondInstr :: PprStyle -> FAST_STRING -> Cond -> Unpretty -> Unpretty
+pprCondInstr sty name cond arg =
+ uppBesides [ uppChar '\t', uppPStr name, pprCond cond, uppChar ' ', arg]
+
+pprI386Instr :: PprStyle -> I386Instr -> Unpretty
+pprI386Instr sty (MOV size (OpReg src) (OpReg dst)) -- hack
+ | src == dst
+ = uppPStr SLIT("")
+pprI386Instr sty (MOV size src dst)
+ = pprSizeOpOp sty SLIT("mov") size src dst
+pprI386Instr sty (MOVZX size src dst) = pprSizeOpOpCoerce sty SLIT("movzx") L size src dst
+pprI386Instr sty (MOVSX size src dst) = pprSizeOpOpCoerce sty SLIT("movxs") L size src dst
+
+-- here we do some patching, since the physical registers are only set late
+-- in the code generation.
+pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
+ | reg1 == reg3
+ = pprSizeOpOp sty SLIT("add") size (OpReg reg2) dst
+pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) (Just (reg2,1)) (ImmInt 0))) dst@(OpReg reg3))
+ | reg2 == reg3
+ = pprSizeOpOp sty SLIT("add") size (OpReg reg1) dst
+pprI386Instr sty (LEA size (OpAddr (Addr src1@(Just reg1) Nothing displ)) dst@(OpReg reg3))
+ | reg1 == reg3
+ = pprI386Instr sty (ADD size (OpImm displ) dst)
+pprI386Instr sty (LEA size src dst) = pprSizeOpOp sty SLIT("lea") size src dst
+
+pprI386Instr sty (ADD size (OpImm (ImmInt (-1))) dst)
+ = pprSizeOp sty SLIT("dec") size dst
+pprI386Instr sty (ADD size (OpImm (ImmInt 1)) dst)
+ = pprSizeOp sty SLIT("inc") size dst
+pprI386Instr sty (ADD size src dst)
+ = pprSizeOpOp sty SLIT("add") size src dst
+pprI386Instr sty (SUB size src dst) = pprSizeOpOp sty SLIT("sub") size src dst
+pprI386Instr sty (IMUL size op1 op2) = pprSizeOpOp sty SLIT("imul") size op1 op2
+pprI386Instr sty (IDIV size op) = pprSizeOp sty SLIT("idiv") size op
+
+pprI386Instr sty (AND size src dst) = pprSizeOpOp sty SLIT("and") size src dst
+pprI386Instr sty (OR size src dst) = pprSizeOpOp sty SLIT("or") size src dst
+pprI386Instr sty (XOR size src dst) = pprSizeOpOp sty SLIT("xor") size src dst
+pprI386Instr sty (NOT size op) = pprSizeOp sty SLIT("not") size op
+pprI386Instr sty (NEGI size op) = pprSizeOp sty SLIT("neg") size op
+pprI386Instr sty (SHL size imm dst) = pprSizeOpOp sty SLIT("shl") size imm dst
+pprI386Instr sty (SAR size imm dst) = pprSizeOpOp sty SLIT("sar") size imm dst
+pprI386Instr sty (SHR size imm dst) = pprSizeOpOp sty SLIT("shr") size imm dst
+
+pprI386Instr sty (CMP size src dst) = pprSizeOpOp sty SLIT("cmp") size src dst
+pprI386Instr sty (TEST size src dst) = pprSizeOpOp sty SLIT("test") size src dst
+pprI386Instr sty (PUSH size op) = pprSizeOp sty SLIT("push") size op
+pprI386Instr sty (POP size op) = pprSizeOp sty SLIT("pop") size op
+
+pprI386Instr sty (NOP) = uppPStr SLIT("\tnop")
+pprI386Instr sty (CLTD) = uppPStr SLIT("\tcltd")
+
+pprI386Instr sty (SETCC cond op) = pprCondInstr sty SLIT("set") cond (pprOperand sty B op)
+
+pprI386Instr sty (JXX cond lab) = pprCondInstr sty SLIT("j") cond (pprCLabel sty lab)
+
+pprI386Instr sty (JMP (OpImm imm)) = uppBeside (uppPStr SLIT("\tjmp ")) (pprImm sty imm)
+pprI386Instr sty (JMP op) = uppBeside (uppPStr SLIT("\tjmp *")) (pprOperand sty L op)
+
+pprI386Instr sty (CALL imm) =
+ uppBesides [ uppPStr SLIT("\tcall "), pprImm sty imm ]
+
+pprI386Instr sty SAHF = uppPStr SLIT("\tsahf")
+pprI386Instr sty FABS = uppPStr SLIT("\tfabs")
+
+pprI386Instr sty (FADD sz src@(OpAddr _))
+ = uppBesides [uppPStr SLIT("\tfadd"), pprSize sz, uppChar ' ', pprOperand sty sz src]
+pprI386Instr sty (FADD sz src)
+ = uppPStr SLIT("\tfadd")
+pprI386Instr sty FADDP
+ = uppPStr SLIT("\tfaddp")
+pprI386Instr sty (FMUL sz src)
+ = uppBesides [uppPStr SLIT("\tfmul"), pprSize sz, uppChar ' ', pprOperand sty sz src]
+pprI386Instr sty FMULP
+ = uppPStr SLIT("\tfmulp")
+pprI386Instr sty (FIADD size op) = pprSizeAddr sty SLIT("fiadd") size op
+pprI386Instr sty FCHS = uppPStr SLIT("\tfchs")
+pprI386Instr sty (FCOM size op) = pprSizeOp sty SLIT("fcom") size op
+pprI386Instr sty FCOS = uppPStr SLIT("\tfcos")
+pprI386Instr sty (FIDIV size op) = pprSizeAddr sty SLIT("fidiv") size op
+pprI386Instr sty (FDIV sz src)
+ = uppBesides [uppPStr SLIT("\tfdiv"), pprSize sz, uppChar ' ', pprOperand sty sz src]
+pprI386Instr sty FDIVP
+ = uppPStr SLIT("\tfdivp")
+pprI386Instr sty (FDIVR sz src)
+ = uppBesides [uppPStr SLIT("\tfdivr"), pprSize sz, uppChar ' ', pprOperand sty sz src]
+pprI386Instr sty FDIVRP
+ = uppPStr SLIT("\tfdivpr")
+pprI386Instr sty (FIDIVR size op) = pprSizeAddr sty SLIT("fidivr") size op
+pprI386Instr sty (FICOM size op) = pprSizeAddr sty SLIT("ficom") size op
+pprI386Instr sty (FILD sz op reg) = pprSizeAddrReg sty SLIT("fild") sz op reg
+pprI386Instr sty (FIST size op) = pprSizeAddr sty SLIT("fist") size op
+pprI386Instr sty (FLD sz (OpImm (ImmCLbl src)))
+ = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppChar ' ',pprCLabel sty src]
+pprI386Instr sty (FLD sz src)
+ = uppBesides [uppPStr SLIT("\tfld"),pprSize sz,uppChar ' ',pprOperand sty sz src]
+pprI386Instr sty FLD1 = uppPStr SLIT("\tfld1")
+pprI386Instr sty FLDZ = uppPStr SLIT("\tfldz")
+pprI386Instr sty (FIMUL size op) = pprSizeAddr sty SLIT("fimul") size op
+pprI386Instr sty FRNDINT = uppPStr SLIT("\tfrndint")
+pprI386Instr sty FSIN = uppPStr SLIT("\tfsin")
+pprI386Instr sty FSQRT = uppPStr SLIT("\tfsqrt")
+pprI386Instr sty (FST sz dst)
+ = uppBesides [uppPStr SLIT("\tfst"), pprSize sz, uppChar ' ', pprOperand sty sz dst]
+pprI386Instr sty (FSTP sz dst)
+ = uppBesides [uppPStr SLIT("\tfstp"), pprSize sz, uppChar ' ', pprOperand sty sz dst]
+pprI386Instr sty (FISUB size op) = pprSizeAddr sty SLIT("fisub") size op
+pprI386Instr sty (FSUB sz src)
+ = uppBesides [uppPStr SLIT("\tfsub"), pprSize sz, uppChar ' ', pprOperand sty sz src]
+pprI386Instr sty FSUBP
+ = uppPStr SLIT("\tfsubp")
+pprI386Instr sty (FSUBR size src)
+ = pprSizeOp sty SLIT("fsubr") size src
+pprI386Instr sty FSUBRP
+ = uppPStr SLIT("\tfsubpr")
+pprI386Instr sty (FISUBR size op)
+ = pprSizeAddr sty SLIT("fisubr") size op
+pprI386Instr sty FTST = uppPStr SLIT("\tftst")
+pprI386Instr sty (FCOMP sz op)
+ = uppBesides [uppPStr SLIT("\tfcomp"), pprSize sz, uppChar ' ', pprOperand sty sz op]
+pprI386Instr sty FUCOMPP = uppPStr SLIT("\tfucompp")
+pprI386Instr sty FXCH = uppPStr SLIT("\tfxch")
+pprI386Instr sty FNSTSW = uppPStr SLIT("\tfnstsw %ax")
+pprI386Instr sty FNOP = uppPStr SLIT("")
+
+pprI386Instr sty (LABEL clab) =
+ uppBesides [
+ if (externallyVisibleCLabel clab) then
+ uppBesides [uppPStr SLIT(".globl "), pprLab, uppChar '\n']
+ else
+ uppNil,
+ pprLab,
+ uppChar ':'
+ ]
+ where pprLab = pprCLabel sty clab
+
+pprI386Instr sty (COMMENT s) = uppBeside (uppPStr SLIT("# ")) (uppPStr s)
+
+pprI386Instr sty (SEGMENT TextSegment)
+ = uppPStr SLIT(".text\n\t.align 4")
+
+pprI386Instr sty (SEGMENT DataSegment)
+ = uppPStr SLIT(".data\n\t.align 2")
+
+pprI386Instr sty (ASCII False str) =
+ uppBesides [
+ uppStr "\t.asciz \"",
+ uppStr str,
+ uppChar '"'
+ ]
+
+pprI386Instr sty (ASCII True str) = uppBeside (uppStr "\t.ascii \"") (asciify str 60)
+ where
+ asciify :: String -> Int -> Unpretty
+ asciify [] _ = uppStr ("\\0\"")
+ asciify s n | n <= 0 = uppBeside (uppStr "\"\n\t.ascii \"") (asciify s 60)
+ asciify ('\\':cs) n = uppBeside (uppStr "\\\\") (asciify cs (n-1))
+ asciify ('\"':cs) n = uppBeside (uppStr "\\\"") (asciify cs (n-1))
+ asciify (c:cs) n | isPrint c = uppBeside (uppChar c) (asciify cs (n-1))
+ asciify [c] _ = uppBeside (uppStr (charToC c)) (uppStr ("\\0\""))
+ asciify (c:(cs@(d:_))) n | isDigit d =
+ uppBeside (uppStr (charToC c)) (asciify cs 0)
+ | otherwise =
+ uppBeside (uppStr (charToC c)) (asciify cs (n-1))
+
+pprI386Instr sty (DATA s xs) = uppInterleave (uppChar '\n') (map pp_item xs)
+ where pp_item x = case s of
+ B -> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
+ HB-> uppBeside (uppPStr SLIT("\t.byte\t")) (pprImm sty x)
+ S -> uppBeside (uppPStr SLIT("\t.word\t")) (pprImm sty x)
+ L -> uppBeside (uppPStr SLIT("\t.long\t")) (pprImm sty x)
+ F -> uppBeside (uppPStr SLIT("\t.long\t")) (pprImm sty x)
+ D -> uppBeside (uppPStr SLIT("\t.double\t")) (pprImm sty x)
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Schedule]{Register allocation information}
+%* *
+%************************************************************************
+
+\begin{code}
+
+data I386Regs = SRegs BitSet BitSet
+
+instance MachineRegisters I386Regs where
+ mkMRegs xs = SRegs (mkBS ints) (mkBS floats')
+ where
+ (ints, floats) = partition (< 8) xs
+ floats' = map (subtract 8) floats
+
+ possibleMRegs FloatKind (SRegs _ floats) = [ x + 8 | x <- listBS floats]
+ possibleMRegs DoubleKind (SRegs _ floats) = [ x + 8 | x <- listBS floats]
+ possibleMRegs _ (SRegs ints _) = listBS ints
+
+ useMReg (SRegs ints floats) n =
+ if n _LT_ ILIT(8) then SRegs (ints `minusBS` singletonBS IBOX(n)) floats
+ else SRegs ints (floats `minusBS` singletonBS (IBOX(n _SUB_ ILIT(8))))
+
+ useMRegs (SRegs ints floats) xs =
+ SRegs (ints `minusBS` ints')
+ (floats `minusBS` floats')
+ where
+ SRegs ints' floats' = mkMRegs xs
+
+ freeMReg (SRegs ints floats) n =
+ if n _LT_ ILIT(8) then SRegs (ints `unionBS` singletonBS IBOX(n)) floats
+ else SRegs ints (floats `unionBS` singletonBS (IBOX(n _SUB_ ILIT(8))))
+
+ freeMRegs (SRegs ints floats) xs =
+ SRegs (ints `unionBS` ints')
+ (floats `unionBS` floats')
+ where
+ SRegs ints' floats' = mkMRegs xs
+
+instance MachineCode I386Instr where
+ -- Alas, we don't do anything clever with our OrdLists
+--OLD:
+-- flatten = flattenOrdList
+
+ regUsage = i386RegUsage
+ regLiveness = i386RegLiveness
+ patchRegs = i386PatchRegs
+
+ -- We spill just below the stack pointer, leaving two words per spill location.
+ spillReg dyn (MemoryReg i pk)
+ = trace "spillsave"
+ (mkUnitList (MOV (kindToSize pk) (OpReg dyn) (OpAddr (spRel (-2 * i)))))
+ loadReg (MemoryReg i pk) dyn
+ = trace "spillload"
+ (mkUnitList (MOV (kindToSize pk) (OpAddr (spRel (-2 * i))) (OpReg dyn)))
+
+--spRel gives us a stack relative addressing mode for volatile temporaries
+--and for excess call arguments.
+
+spRel
+ :: Int -- desired stack offset in words, positive or negative
+ -> Addr
+spRel n = Addr (Just esp) Nothing (ImmInt (n * 4))
+
+kindToSize :: PrimKind -> Size
+kindToSize PtrKind = L
+kindToSize CodePtrKind = L
+kindToSize DataPtrKind = L
+kindToSize RetKind = L
+kindToSize InfoPtrKind = L
+kindToSize CostCentreKind = L
+kindToSize CharKind = L
+kindToSize IntKind = L
+kindToSize WordKind = L
+kindToSize AddrKind = L
+kindToSize FloatKind = F
+kindToSize DoubleKind = D
+kindToSize ArrayKind = L
+kindToSize ByteArrayKind = L
+kindToSize StablePtrKind = L
+kindToSize MallocPtrKind = L
+
+\end{code}
+
+@i386RegUsage@ returns the sets of src and destination registers used by
+a particular instruction. Machine registers that are pre-allocated
+to stgRegs are filtered out, because they are uninteresting from a
+register allocation standpoint. (We wouldn't want them to end up on
+the free list!)
+
+\begin{code}
+
+i386RegUsage :: I386Instr -> RegUsage
+i386RegUsage instr = case instr of
+ MOV sz src dst -> usage2 src dst
+ MOVZX sz src dst -> usage2 src dst
+ MOVSX sz src dst -> usage2 src dst
+ LEA sz src dst -> usage2 src dst
+ ADD sz src dst -> usage2 src dst
+ SUB sz src dst -> usage2 src dst
+ IMUL sz src dst -> usage2 src dst
+ IDIV sz src -> usage (eax:edx:opToReg src) [eax,edx]
+ AND sz src dst -> usage2 src dst
+ OR sz src dst -> usage2 src dst
+ XOR sz src dst -> usage2 src dst
+ NOT sz op -> usage1 op
+ NEGI sz op -> usage1 op
+ SHL sz imm dst -> usage1 dst -- imm has to be an Imm
+ SAR sz imm dst -> usage1 dst -- imm has to be an Imm
+ SHR sz imm dst -> usage1 dst -- imm has to be an Imm
+ PUSH sz op -> usage (opToReg op) []
+ POP sz op -> usage [] (opToReg op)
+ TEST sz src dst -> usage (opToReg src ++ opToReg dst) []
+ CMP sz src dst -> usage (opToReg src ++ opToReg dst) []
+ SETCC cond op -> usage [] (opToReg op)
+ JXX cond label -> usage [] []
+ JMP op -> usage (opToReg op) freeRegs
+ CALL imm -> usage [] callClobberedRegs
+ CLTD -> usage [eax] [edx]
+ NOP -> usage [] []
+ SAHF -> usage [eax] []
+ FABS -> usage [st0] [st0]
+ FADD sz src -> usage (st0:opToReg src) [st0] -- allFPRegs
+ FADDP -> usage [st0,st1] [st0] -- allFPRegs
+ FIADD sz asrc -> usage (addrToRegs asrc) [st0]
+ FCHS -> usage [st0] [st0]
+ FCOM sz src -> usage (st0:opToReg src) []
+ FCOS -> usage [st0] [st0]
+ FDIV sz src -> usage (st0:opToReg src) [st0]
+ FDIVP -> usage [st0,st1] [st0]
+ FDIVRP -> usage [st0,st1] [st0]
+ FIDIV sz asrc -> usage (addrToRegs asrc) [st0]
+ FDIVR sz src -> usage (st0:opToReg src) [st0]
+ FIDIVR sz asrc -> usage (addrToRegs asrc) [st0]
+ FICOM sz asrc -> usage (addrToRegs asrc) []
+ FILD sz asrc dst -> usage (addrToRegs asrc) [dst] -- allFPRegs
+ FIST sz adst -> usage (st0:addrToRegs adst) []
+ FLD sz src -> usage (opToReg src) [st0] -- allFPRegs
+ FLD1 -> usage [] [st0] -- allFPRegs
+ FLDZ -> usage [] [st0] -- allFPRegs
+ FMUL sz src -> usage (st0:opToReg src) [st0]
+ FMULP -> usage [st0,st1] [st0]
+ FIMUL sz asrc -> usage (addrToRegs asrc) [st0]
+ FRNDINT -> usage [st0] [st0]
+ FSIN -> usage [st0] [st0]
+ FSQRT -> usage [st0] [st0]
+ FST sz (OpReg r) -> usage [st0] [r]
+ FST sz dst -> usage (st0:opToReg dst) []
+ FSTP sz (OpReg r) -> usage [st0] [r] -- allFPRegs
+ FSTP sz dst -> usage (st0:opToReg dst) [] -- allFPRegs
+ FSUB sz src -> usage (st0:opToReg src) [st0] -- allFPRegs
+ FSUBR sz src -> usage (st0:opToReg src) [st0] -- allFPRegs
+ FISUB sz asrc -> usage (addrToRegs asrc) [st0]
+ FSUBP -> usage [st0,st1] [st0] -- allFPRegs
+ FSUBRP -> usage [st0,st1] [st0] -- allFPRegs
+ FISUBR sz asrc -> usage (addrToRegs asrc) [st0]
+ FTST -> usage [st0] []
+ FCOMP sz op -> usage (st0:opToReg op) [st0] -- allFPRegs
+ FUCOMPP -> usage [st0, st1] [] -- allFPRegs
+ FXCH -> usage [st0, st1] [st0, st1]
+ FNSTSW -> usage [] [eax]
+ _ -> noUsage
+
+ where
+
+ usage2 :: Operand -> Operand -> RegUsage
+ usage2 op (OpReg reg) = usage (opToReg op) [reg]
+ usage2 op (OpAddr ea) = usage (opToReg op ++ addrToRegs ea) []
+ usage2 op (OpImm imm) = usage (opToReg op) []
+ usage1 :: Operand -> RegUsage
+ usage1 (OpReg reg) = usage [reg] [reg]
+ usage1 (OpAddr ea) = usage (addrToRegs ea) []
+ allFPRegs = [st0,st1,st2,st3,st4,st5,st6,st7]
+ --callClobberedRegs = [ eax, ecx, edx ] -- according to gcc, anyway.
+ callClobberedRegs = [eax]
+
+-- General purpose register collecting functions.
+
+ opToReg (OpReg reg) = [reg]
+ opToReg (OpImm imm) = []
+ opToReg (OpAddr ea) = addrToRegs ea
+
+ addrToRegs (Addr base index _) = baseToReg base ++ indexToReg index
+ where baseToReg Nothing = []
+ baseToReg (Just r) = [r]
+ indexToReg Nothing = []
+ indexToReg (Just (r,_)) = [r]
+ addrToRegs (ImmAddr _ _) = []
+
+ usage src dst = RU (mkUniqSet (filter interesting src))
+ (mkUniqSet (filter interesting dst))
+
+ interesting (FixedReg _) = False
+ interesting _ = True
+
+freeRegs :: [Reg]
+freeRegs = freeMappedRegs (\ x -> x) [0..15]
+
+freeMappedRegs :: (Int -> Int) -> [Int] -> [Reg]
+
+freeMappedRegs modify nums
+ = foldr free [] nums
+ where
+ free n acc
+ = let
+ modified_i = case (modify n) of { IBOX(x) -> x }
+ in
+ if _IS_TRUE_(freeReg modified_i) then (MappedReg modified_i) : acc else acc
+
+freeSet :: UniqSet Reg
+freeSet = mkUniqSet freeRegs
+
+noUsage :: RegUsage
+noUsage = RU emptyUniqSet emptyUniqSet
+
+endUsage :: RegUsage
+endUsage = RU emptyUniqSet freeSet
+
+\end{code}
+
+@i386RegLiveness@ takes future liveness information and modifies it according to
+the semantics of branches and labels. (An out-of-line branch clobbers the liveness
+passed back by the following instruction; a forward local branch passes back the
+liveness from the target label; a conditional branch merges the liveness from the
+target and the liveness from its successor; a label stashes away the current liveness
+in the future liveness environment).
+
+\begin{code}
+i386RegLiveness :: I386Instr -> RegLiveness -> RegLiveness
+i386RegLiveness instr info@(RL live future@(FL all env)) = case instr of
+
+ JXX _ lbl -> RL (lookup lbl `unionUniqSets` live) future
+ JMP _ -> RL emptyUniqSet future
+ CALL _ -> RL live future
+ LABEL lbl -> RL live (FL (all `unionUniqSets` live) (addToFM env lbl live))
+ _ -> info
+
+ where
+ lookup lbl = case lookupFM env lbl of
+ Just regs -> regs
+ Nothing -> trace ("Missing " ++ (uppShow 80 (pprCLabel (PprForAsm (\_->False) False id) lbl)) ++
+ " in future?") emptyUniqSet
+
+\end{code}
+
+@i386PatchRegs@ takes an instruction (possibly with MemoryReg/UnmappedReg registers) and
+changes all register references according to the supplied environment.
+
+\begin{code}
+
+i386PatchRegs :: I386Instr -> (Reg -> Reg) -> I386Instr
+i386PatchRegs instr env = case instr of
+ MOV sz src dst -> patch2 (MOV sz) src dst
+ MOVZX sz src dst -> patch2 (MOVZX sz) src dst
+ MOVSX sz src dst -> patch2 (MOVSX sz) src dst
+ LEA sz src dst -> patch2 (LEA sz) src dst
+ ADD sz src dst -> patch2 (ADD sz) src dst
+ SUB sz src dst -> patch2 (SUB sz) src dst
+ IMUL sz src dst -> patch2 (IMUL sz) src dst
+ IDIV sz src -> patch1 (IDIV sz) src
+ AND sz src dst -> patch2 (AND sz) src dst
+ OR sz src dst -> patch2 (OR sz) src dst
+ XOR sz src dst -> patch2 (XOR sz) src dst
+ NOT sz op -> patch1 (NOT sz) op
+ NEGI sz op -> patch1 (NEGI sz) op
+ SHL sz imm dst -> patch1 (SHL sz imm) dst
+ SAR sz imm dst -> patch1 (SAR sz imm) dst
+ SHR sz imm dst -> patch1 (SHR sz imm) dst
+ TEST sz src dst -> patch2 (TEST sz) src dst
+ CMP sz src dst -> patch2 (CMP sz) src dst
+ PUSH sz op -> patch1 (PUSH sz) op
+ POP sz op -> patch1 (POP sz) op
+ SETCC cond op -> patch1 (SETCC cond) op
+ JMP op -> patch1 JMP op
+ FADD sz src -> FADD sz (patchOp src)
+ FIADD sz asrc -> FIADD sz (lookupAddr asrc)
+ FCOM sz src -> patch1 (FCOM sz) src
+ FDIV sz src -> FDIV sz (patchOp src)
+ --FDIVP sz src -> FDIVP sz (patchOp src)
+ FIDIV sz asrc -> FIDIV sz (lookupAddr asrc)
+ FDIVR sz src -> FDIVR sz (patchOp src)
+ --FDIVRP sz src -> FDIVRP sz (patchOp src)
+ FIDIVR sz asrc -> FIDIVR sz (lookupAddr asrc)
+ FICOM sz asrc -> FICOM sz (lookupAddr asrc)
+ FILD sz asrc dst -> FILD sz (lookupAddr asrc) (env dst)
+ FIST sz adst -> FIST sz (lookupAddr adst)
+ FLD sz src -> patch1 (FLD sz) (patchOp src)
+ FMUL sz src -> FMUL sz (patchOp src)
+ --FMULP sz src -> FMULP sz (patchOp src)
+ FIMUL sz asrc -> FIMUL sz (lookupAddr asrc)
+ FST sz dst -> FST sz (patchOp dst)
+ FSTP sz dst -> FSTP sz (patchOp dst)
+ FSUB sz src -> FSUB sz (patchOp src)
+ --FSUBP sz src -> FSUBP sz (patchOp src)
+ FISUB sz asrc -> FISUB sz (lookupAddr asrc)
+ FSUBR sz src -> FSUBR sz (patchOp src)
+ --FSUBRP sz src -> FSUBRP sz (patchOp src)
+ FISUBR sz asrc -> FISUBR sz (lookupAddr asrc)
+ FCOMP sz src -> FCOMP sz (patchOp src)
+ _ -> instr
+
+ where
+ patch1 insn op = insn (patchOp op)
+ patch2 insn src dst = insn (patchOp src) (patchOp dst)
+
+ patchOp (OpReg reg) = OpReg (env reg)
+ patchOp (OpImm imm) = OpImm imm
+ patchOp (OpAddr ea) = OpAddr (lookupAddr ea)
+
+ lookupAddr (Addr base index disp)
+ = Addr (lookupBase base) (lookupIndex index) disp
+ where lookupBase Nothing = Nothing
+ lookupBase (Just r) = Just (env r)
+ lookupIndex Nothing = Nothing
+ lookupIndex (Just (r,i)) = Just (env r, i)
+ lookupAddr (ImmAddr imm off)
+ = ImmAddr imm off
+
+\end{code}
+
+Sometimes, we want to be able to modify addresses at compile time.
+(Okay, just for chrCode of a fetch.)
+
+\begin{code}
+
+#ifdef __GLASGOW_HASKELL__
+
+{-# SPECIALIZE
+ is13Bits :: Int -> Bool
+ #-}
+{-# SPECIALIZE
+ is13Bits :: Integer -> Bool
+ #-}
+
+#endif
+
+is13Bits :: Integral a => a -> Bool
+is13Bits x = x >= -4096 && x < 4096
+
+offset :: Addr -> Int -> Maybe Addr
+offset (Addr reg index (ImmInt n)) off
+ = Just (Addr reg index (ImmInt n2))
+ where n2 = n + off
+
+offset (Addr reg index (ImmInteger n)) off
+ = Just (Addr reg index (ImmInt (fromInteger n2)))
+ where n2 = n + toInteger off
+
+offset (ImmAddr imm off1) off2
+ = Just (ImmAddr imm off3)
+ where off3 = off1 + off2
+
+offset _ _ = Nothing
+
+\end{code}
+
+If you value your sanity, do not venture below this line.
+
+\begin{code}
+
+-- platform.h is generate and tells us what the target architecture is
+#include "../../includes/platform.h"
+#define STOLEN_X86_REGS 5
+#include "../../includes/MachRegs.h"
+#include "../../includes/i386-unknown-linuxaout.h"
+
+-- Redefine the literals used for I386 register names in the header
+-- files. Gag me with a spoon, eh?
+
+#define eax 0
+#define ebx 1
+#define ecx 2
+#define edx 3
+#define esi 4
+#define edi 5
+#define ebp 6
+#define esp 7
+#define st0 8
+#define st1 9
+#define st2 10
+#define st3 11
+#define st4 12
+#define st5 13
+#define st6 14
+#define st7 15
+#define CALLER_SAVES_Hp
+-- ToDo: rm when we give esp back
+#define REG_Hp esp
+#define REG_R2 ecx
+
+baseRegOffset :: MagicId -> Int
+baseRegOffset StkOReg = OFFSET_StkO
+baseRegOffset (VanillaReg _ ILIT2(1)) = OFFSET_R1
+baseRegOffset (VanillaReg _ ILIT2(2)) = OFFSET_R2
+baseRegOffset (VanillaReg _ ILIT2(3)) = OFFSET_R3
+baseRegOffset (VanillaReg _ ILIT2(4)) = OFFSET_R4
+baseRegOffset (VanillaReg _ ILIT2(5)) = OFFSET_R5
+baseRegOffset (VanillaReg _ ILIT2(6)) = OFFSET_R6
+baseRegOffset (VanillaReg _ ILIT2(7)) = OFFSET_R7
+baseRegOffset (VanillaReg _ ILIT2(8)) = OFFSET_R8
+baseRegOffset (FloatReg ILIT2(1)) = OFFSET_Flt1
+baseRegOffset (FloatReg ILIT2(2)) = OFFSET_Flt2
+baseRegOffset (FloatReg ILIT2(3)) = OFFSET_Flt3
+baseRegOffset (FloatReg ILIT2(4)) = OFFSET_Flt4
+baseRegOffset (DoubleReg ILIT2(1)) = OFFSET_Dbl1
+baseRegOffset (DoubleReg ILIT2(2)) = OFFSET_Dbl2
+baseRegOffset TagReg = OFFSET_Tag
+baseRegOffset RetReg = OFFSET_Ret
+baseRegOffset SpA = OFFSET_SpA
+baseRegOffset SuA = OFFSET_SuA
+baseRegOffset SpB = OFFSET_SpB
+baseRegOffset SuB = OFFSET_SuB
+baseRegOffset Hp = OFFSET_Hp
+baseRegOffset HpLim = OFFSET_HpLim
+baseRegOffset LivenessReg = OFFSET_Liveness
+--baseRegOffset ActivityReg = OFFSET_Activity
+#ifdef DEBUG
+baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
+baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg"
+baseRegOffset StkStubReg = panic "baseRegOffset:StkStubReg"
+baseRegOffset CurCostCentre = panic "baseRegOffset:CurCostCentre"
+baseRegOffset VoidReg = panic "baseRegOffset:VoidReg"
+#endif
+
+callerSaves :: MagicId -> Bool
+#ifdef CALLER_SAVES_Base
+callerSaves BaseReg = True
+#endif
+#ifdef CALLER_SAVES_StkO
+callerSaves StkOReg = True
+#endif
+#ifdef CALLER_SAVES_R1
+callerSaves (VanillaReg _ ILIT2(1)) = True
+#endif
+#ifdef CALLER_SAVES_R2
+callerSaves (VanillaReg _ ILIT2(2)) = True
+#endif
+#ifdef CALLER_SAVES_R3
+callerSaves (VanillaReg _ ILIT2(3)) = True
+#endif
+#ifdef CALLER_SAVES_R4
+callerSaves (VanillaReg _ ILIT2(4)) = True
+#endif
+#ifdef CALLER_SAVES_R5
+callerSaves (VanillaReg _ ILIT2(5)) = True
+#endif
+#ifdef CALLER_SAVES_R6
+callerSaves (VanillaReg _ ILIT2(6)) = True
+#endif
+#ifdef CALLER_SAVES_R7
+callerSaves (VanillaReg _ ILIT2(7)) = True
+#endif
+#ifdef CALLER_SAVES_R8
+callerSaves (VanillaReg _ ILIT2(8)) = True
+#endif
+#ifdef CALLER_SAVES_FltReg1
+callerSaves (FloatReg ILIT2(1)) = True
+#endif
+#ifdef CALLER_SAVES_FltReg2
+callerSaves (FloatReg ILIT2(2)) = True
+#endif
+#ifdef CALLER_SAVES_FltReg3
+callerSaves (FloatReg ILIT2(3)) = True
+#endif
+#ifdef CALLER_SAVES_FltReg4
+callerSaves (FloatReg ILIT2(4)) = True
+#endif
+#ifdef CALLER_SAVES_DblReg1
+callerSaves (DoubleReg ILIT2(1)) = True
+#endif
+#ifdef CALLER_SAVES_DblReg2
+callerSaves (DoubleReg ILIT2(2)) = True
+#endif
+#ifdef CALLER_SAVES_Tag
+callerSaves TagReg = True
+#endif
+#ifdef CALLER_SAVES_Ret
+callerSaves RetReg = True
+#endif
+#ifdef CALLER_SAVES_SpA
+callerSaves SpA = True
+#endif
+#ifdef CALLER_SAVES_SuA
+callerSaves SuA = True
+#endif
+#ifdef CALLER_SAVES_SpB
+callerSaves SpB = True
+#endif
+#ifdef CALLER_SAVES_SuB
+callerSaves SuB = True
+#endif
+#ifdef CALLER_SAVES_Hp
+callerSaves Hp = True
+#endif
+#ifdef CALLER_SAVES_HpLim
+callerSaves HpLim = True
+#endif
+#ifdef CALLER_SAVES_Liveness
+callerSaves LivenessReg = True
+#endif
+#ifdef CALLER_SAVES_Activity
+--callerSaves ActivityReg = True
+#endif
+#ifdef CALLER_SAVES_StdUpdRetVec
+callerSaves StdUpdRetVecReg = True
+#endif
+#ifdef CALLER_SAVES_StkStub
+callerSaves StkStubReg = True
+#endif
+callerSaves _ = False
+
+stgRegMap :: MagicId -> Maybe Reg
+
+#ifdef REG_Base
+stgRegMap BaseReg = Just (FixedReg ILIT(REG_Base))
+#endif
+#ifdef REG_StkO
+stgRegMap StkOReg = Just (FixedReg ILIT(REG_StkOReg))
+#endif
+#ifdef REG_R1
+stgRegMap (VanillaReg _ ILIT2(1)) = Just (FixedReg ILIT(REG_R1))
+#endif
+#ifdef REG_R2
+stgRegMap (VanillaReg _ ILIT2(2)) = Just (FixedReg ILIT(REG_R2))
+#endif
+#ifdef REG_R3
+stgRegMap (VanillaReg _ ILIT2(3)) = Just (FixedReg ILIT(REG_R3))
+#endif
+#ifdef REG_R4
+stgRegMap (VanillaReg _ ILIT2(4)) = Just (FixedReg ILIT(REG_R4))
+#endif
+#ifdef REG_R5
+stgRegMap (VanillaReg _ ILIT2(5)) = Just (FixedReg ILIT(REG_R5))
+#endif
+#ifdef REG_R6
+stgRegMap (VanillaReg _ ILIT2(6)) = Just (FixedReg ILIT(REG_R6))
+#endif
+#ifdef REG_R7
+stgRegMap (VanillaReg _ ILIT2(7)) = Just (FixedReg ILIT(REG_R7))
+#endif
+#ifdef REG_R8
+stgRegMap (VanillaReg _ ILIT2(8)) = Just (FixedReg ILIT(REG_R8))
+#endif
+#ifdef REG_Flt1
+stgRegMap (FloatReg ILIT2(1)) = Just (FixedReg ILIT(REG_Flt1))
+#endif
+#ifdef REG_Flt2
+stgRegMap (FloatReg ILIT2(2)) = Just (FixedReg ILIT(REG_Flt2))
+#endif
+#ifdef REG_Flt3
+stgRegMap (FloatReg ILIT2(3)) = Just (FixedReg ILIT(REG_Flt3))
+#endif
+#ifdef REG_Flt4
+stgRegMap (FloatReg ILIT2(4)) = Just (FixedReg ILIT(REG_Flt4))
+#endif
+#ifdef REG_Dbl1
+stgRegMap (DoubleReg ILIT2(1)) = Just (FixedReg ILIT(REG_Dbl1))
+#endif
+#ifdef REG_Dbl2
+stgRegMap (DoubleReg ILIT2(2)) = Just (FixedReg ILIT(REG_Dbl2))
+#endif
+#ifdef REG_Tag
+stgRegMap TagReg = Just (FixedReg ILIT(REG_TagReg))
+#endif
+#ifdef REG_Ret
+stgRegMap RetReg = Just (FixedReg ILIT(REG_Ret))
+#endif
+#ifdef REG_SpA
+stgRegMap SpA = Just (FixedReg ILIT(REG_SpA))
+#endif
+#ifdef REG_SuA
+stgRegMap SuA = Just (FixedReg ILIT(REG_SuA))
+#endif
+#ifdef REG_SpB
+stgRegMap SpB = Just (FixedReg ILIT(REG_SpB))
+#endif
+#ifdef REG_SuB
+stgRegMap SuB = Just (FixedReg ILIT(REG_SuB))
+#endif
+#ifdef REG_Hp
+stgRegMap Hp = Just (FixedReg ILIT(REG_Hp))
+#endif
+#ifdef REG_HpLim
+stgRegMap HpLim = Just (FixedReg ILIT(REG_HpLim))
+#endif
+#ifdef REG_Liveness
+stgRegMap LivenessReg = Just (FixedReg ILIT(REG_Liveness))
+#endif
+#ifdef REG_Activity
+--stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity))
+#endif
+#ifdef REG_StdUpdRetVec
+stgRegMap StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec))
+#endif
+#ifdef REG_StkStub
+stgRegMap StkStubReg = Just (FixedReg ILIT(REG_StkStub))
+#endif
+
+stgRegMap _ = Nothing
+
+\end{code}
+
+Here is the list of registers we can use in register allocation.
+
+\begin{code}
+freeReg :: FAST_INT -> FAST_BOOL
+
+--freeReg ILIT(esp) = _FALSE_ -- %esp is our stack pointer.
+
+#ifdef REG_Base
+freeReg ILIT(REG_Base) = _FALSE_
+#endif
+#ifdef REG_StkO
+freeReg ILIT(REG_StkO) = _FALSE_
+#endif
+#ifdef REG_R1
+freeReg ILIT(REG_R1) = _FALSE_
+#endif
+#ifdef REG_R2
+freeReg ILIT(REG_R2) = _FALSE_
+#endif
+#ifdef REG_R3
+freeReg ILIT(REG_R3) = _FALSE_
+#endif
+#ifdef REG_R4
+freeReg ILIT(REG_R4) = _FALSE_
+#endif
+#ifdef REG_R5
+freeReg ILIT(REG_R5) = _FALSE_
+#endif
+#ifdef REG_R6
+freeReg ILIT(REG_R6) = _FALSE_
+#endif
+#ifdef REG_R7
+freeReg ILIT(REG_R7) = _FALSE_
+#endif
+#ifdef REG_R8
+freeReg ILIT(REG_R8) = _FALSE_
+#endif
+#ifdef REG_Flt1
+freeReg ILIT(REG_Flt1) = _FALSE_
+#endif
+#ifdef REG_Flt2
+freeReg ILIT(REG_Flt2) = _FALSE_
+#endif
+#ifdef REG_Flt3
+freeReg ILIT(REG_Flt3) = _FALSE_
+#endif
+#ifdef REG_Flt4
+freeReg ILIT(REG_Flt4) = _FALSE_
+#endif
+#ifdef REG_Dbl1
+freeReg ILIT(REG_Dbl1) = _FALSE_
+#endif
+#ifdef REG_Dbl2
+freeReg ILIT(REG_Dbl2) = _FALSE_
+#endif
+#ifdef REG_Tag
+freeReg ILIT(REG_Tag) = _FALSE_
+#endif
+#ifdef REG_Ret
+freeReg ILIT(REG_Ret) = _FALSE_
+#endif
+#ifdef REG_SpA
+freeReg ILIT(REG_SpA) = _FALSE_
+#endif
+#ifdef REG_SuA
+freeReg ILIT(REG_SuA) = _FALSE_
+#endif
+#ifdef REG_SpB
+freeReg ILIT(REG_SpB) = _FALSE_
+#endif
+#ifdef REG_SuB
+freeReg ILIT(REG_SuB) = _FALSE_
+#endif
+#ifdef REG_Hp
+freeReg ILIT(REG_Hp) = _FALSE_
+#endif
+#ifdef REG_HpLim
+freeReg ILIT(REG_HpLim) = _FALSE_
+#endif
+#ifdef REG_Liveness
+freeReg ILIT(REG_Liveness) = _FALSE_
+#endif
+#ifdef REG_Activity
+--freeReg ILIT(REG_Activity) = _FALSE_
+#endif
+#ifdef REG_StdUpdRetVec
+freeReg ILIT(REG_StdUpdRetVec) = _FALSE_
+#endif
+#ifdef REG_StkStub
+freeReg ILIT(REG_StkStub) = _FALSE_
+#endif
+freeReg n
+#ifdef REG_Dbl1
+ | n _EQ_ (ILIT(REG_Dbl1) _ADD_ ILIT(1)) = _FALSE_
+#endif
+#ifdef REG_Dbl2
+ | n _EQ_ (ILIT(REG_Dbl2) _ADD_ ILIT(1)) = _FALSE_
+#endif
+
+ | otherwise = _TRUE_
+
+reservedRegs :: [Int]
+reservedRegs = []
+--reservedRegs = [NCG_Reserved_I1, NCG_Reserved_I2,
+-- NCG_Reserved_F1, NCG_Reserved_F2,
+-- NCG_Reserved_D1, NCG_Reserved_D2]
+
+\end{code}
+
--- /dev/null
+{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+interface I386Desc where
+import AbsCSyn(MagicId)
+import CLabelInfo(CLabel)
+import CharSeq(CSeq)
+import CmdLineOpts(GlobalSwitch, SwitchResult)
+import MachDesc(RegLoc, Target)
+import PreludePS(_PackedString)
+import PreludeRatio(Ratio(..))
+import Pretty(PprStyle)
+import PrimKind(PrimKind)
+import PrimOps(PrimOp)
+import SMRep(SMRep, SMSpecRepKind, SMUpdateKind)
+import SplitUniq(SplitUniqSupply)
+import Stix(CodeSegment, StixReg, StixTree)
+data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
+data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-}
+data RegLoc {-# GHC_PRAGMA Save StixTree | Always StixTree #-}
+data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
+data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-}
+data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
+mkI386 :: Bool -> (GlobalSwitch -> SwitchResult) -> (Target, PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq, Bool, [Char] -> [Char])
+ {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
+
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1995
+%
+\section[I386Desc]{The I386 Machine Description}
+
+\begin{code}
+#include "HsVersions.h"
+
+module I386Desc (
+ mkI386,
+
+ -- and assorted nonsense referenced by the class methods
+
+ PprStyle, SMRep, MagicId, RegLoc, StixTree, PrimKind, SwitchResult
+
+ ) where
+
+import AbsCSyn
+import AbsPrel ( PrimOp(..)
+ IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
+ IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+ )
+import AsmRegAlloc ( Reg, MachineCode(..), MachineRegisters(..),
+ RegLiveness(..), RegUsage(..), FutureLive(..)
+ )
+import CLabelInfo ( CLabel )
+import CmdLineOpts ( GlobalSwitch(..), stringSwitchSet, switchIsOn, SwitchResult(..) )
+import HeapOffs ( hpRelToInt )
+import MachDesc
+import Maybes ( Maybe(..) )
+import OrdList
+import Outputable
+import PrimKind ( PrimKind(..) )
+import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
+import I386Code
+import I386Gen ( i386CodeGen )
+import Stix
+import StixMacro
+import StixPrim
+import SplitUniq
+import Unique
+import Util
+
+\end{code}
+
+Header sizes depend only on command-line options, not on the target
+architecture. (I think.)
+
+\begin{code}
+
+fhs :: (GlobalSwitch -> SwitchResult) -> Int
+
+fhs switches = 1 + profFHS + ageFHS
+ where
+ profFHS = if switchIsOn switches SccProfilingOn then 1 else 0
+ ageFHS = if switchIsOn switches SccProfilingOn then 1 else 0
+
+vhs :: (GlobalSwitch -> SwitchResult) -> SMRep -> Int
+
+vhs switches sm = case sm of
+ StaticRep _ _ -> 0
+ SpecialisedRep _ _ _ _ -> 0
+ GenericRep _ _ _ -> 0
+ BigTupleRep _ -> 1
+ MuTupleRep _ -> 2 {- (1 + GC_MUT_RESERVED_WORDS) -}
+ DataRep _ -> 1
+ DynamicRep -> 2
+ BlackHoleRep -> 0
+ PhantomRep -> panic "vhs:phantom"
+
+\end{code}
+
+Here we map STG registers onto appropriate Stix Trees. First, we
+handle the two constants, @STK_STUB_closure@ and @vtbl_StdUpdFrame@.
+The rest are either in real machine registers or stored as offsets
+from BaseReg.
+
+\begin{code}
+
+i386Reg :: (GlobalSwitch -> SwitchResult) -> MagicId -> RegLoc
+
+i386Reg switches x =
+ case stgRegMap x of
+ Just reg -> Save nonReg
+ Nothing -> Always nonReg
+ where nonReg = case x of
+ StkStubReg -> sStLitLbl SLIT("STK_STUB_closure")
+ StdUpdRetVecReg -> sStLitLbl SLIT("vtbl_StdUpdFrame")
+ BaseReg -> sStLitLbl SLIT("MainRegTable")
+ --Hp -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo"))
+ --HpLim -> StInd PtrKind (sStLitLbl SLIT("StorageMgrInfo+4"))
+ TagReg -> StInd IntKind (StPrim IntSubOp [infoptr, StInt (1*4)])
+ where
+ r2 = VanillaReg PtrKind ILIT(2)
+ infoptr = case i386Reg switches r2 of
+ Always tree -> tree
+ Save _ -> StReg (StixMagicId r2)
+ _ -> StInd (kindFromMagicId x)
+ (StPrim IntAddOp [baseLoc, StInt (toInteger (offset*4))])
+ baseLoc = case stgRegMap BaseReg of
+ Just _ -> StReg (StixMagicId BaseReg)
+ Nothing -> sStLitLbl SLIT("MainRegTable")
+ offset = baseRegOffset x
+
+\end{code}
+
+Sizes in bytes.
+
+\begin{code}
+
+size pk = case kindToSize pk of
+ {B -> 1; S -> 2; L -> 4; F -> 4; D -> 8 }
+
+\end{code}
+
+Now the volatile saves and restores. We add the basic guys to the list of ``user''
+registers provided. Note that there are more basic registers on the restore list,
+because some are reloaded from constants.
+
+\begin{code}
+
+vsaves switches vols =
+ map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols))
+ where
+ save x = StAssign (kindFromMagicId x) loc reg
+ where reg = StReg (StixMagicId x)
+ loc = case i386Reg switches x of
+ Save loc -> loc
+ Always loc -> panic "vsaves"
+
+vrests switches vols =
+ map restore ((filter callerSaves)
+ ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-},StkStubReg,StdUpdRetVecReg] ++ vols))
+ where
+ restore x = StAssign (kindFromMagicId x) reg loc
+ where reg = StReg (StixMagicId x)
+ loc = case i386Reg switches x of
+ Save loc -> loc
+ Always loc -> panic "vrests"
+
+\end{code}
+
+Static closure sizes.
+
+\begin{code}
+
+charLikeSize, intLikeSize :: Target -> Int
+
+charLikeSize target =
+ size PtrKind * (fixedHeaderSize target + varHeaderSize target charLikeRep + 1)
+ where charLikeRep = SpecialisedRep CharLikeRep 0 1 SMNormalForm
+
+intLikeSize target =
+ size PtrKind * (fixedHeaderSize target + varHeaderSize target intLikeRep + 1)
+ where intLikeRep = SpecialisedRep IntLikeRep 0 1 SMNormalForm
+
+mhs, dhs :: (GlobalSwitch -> SwitchResult) -> StixTree
+
+mhs switches = StInt (toInteger words)
+ where
+ words = fhs switches + vhs switches (MuTupleRep 0)
+
+dhs switches = StInt (toInteger words)
+ where
+ words = fhs switches + vhs switches (DataRep 0)
+
+\end{code}
+
+Setting up a i386 target.
+
+\begin{code}
+mkI386 :: Bool
+ -> (GlobalSwitch -> SwitchResult)
+ -> (Target,
+ (PprStyle -> [[StixTree]] -> SUniqSM Unpretty), -- codeGen
+ Bool, -- underscore
+ (String -> String)) -- fmtAsmLbl
+
+mkI386 decentOS switches =
+ let fhs' = fhs switches
+ vhs' = vhs switches
+ i386Reg' = i386Reg switches
+ vsaves' = vsaves switches
+ vrests' = vrests switches
+ hprel = hpRelToInt target
+ as = amodeCode target
+ as' = amodeCode' target
+ csz = charLikeSize target
+ isz = intLikeSize target
+ mhs' = mhs switches
+ dhs' = dhs switches
+ ps = genPrimCode target
+ mc = genMacroCode target
+ hc = doHeapCheck --UNUSED NOW: target
+ target = mkTarget {-switches-} fhs' vhs' i386Reg' {-id-} size
+ hprel as as'
+ (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc)
+ {-i386CodeGen decentOS id-}
+ in
+ (target, i386CodeGen, decentOS, id)
+\end{code}
+
+
+
--- /dev/null
+{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
+interface I386Gen where
+import CLabelInfo(CLabel)
+import CharSeq(CSeq)
+import CmdLineOpts(GlobalSwitch)
+import PreludePS(_PackedString)
+import PreludeRatio(Ratio(..))
+import Pretty(PprStyle)
+import PrimKind(PrimKind)
+import PrimOps(PrimOp)
+import SplitUniq(SplitUniqSupply)
+import Stix(CodeSegment, StixReg, StixTree)
+data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
+data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
+i386CodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq
+ {-# GHC_PRAGMA _A_ 2 _U_ 211 _N_ _S_ "LS" _N_ _N_ #-}
+
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1993-1995
+%
+
+\begin{code}
+#include "HsVersions.h"
+#include "../includes/i386-unknown-linuxaout.h"
+
+module I386Gen (
+ i386CodeGen,
+
+ -- and, for self-sufficiency
+ PprStyle, StixTree, CSeq
+ ) where
+
+IMPORT_Trace
+
+import AbsCSyn ( AbstractC, MagicId(..), kindFromMagicId )
+import AbsPrel ( PrimOp(..)
+ IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
+ IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+ )
+import AsmRegAlloc ( runRegAllocate, mkReg, extractMappedRegNos,
+ Reg(..), RegLiveness(..), RegUsage(..),
+ FutureLive(..), MachineRegisters(..), MachineCode(..)
+ )
+import CLabelInfo ( CLabel, isAsmTemp )
+import I386Code {- everything -}
+import MachDesc
+import Maybes ( maybeToBool, Maybe(..) )
+import OrdList -- ( mkEmptyList, mkUnitList, mkSeqList, mkParList, OrdList )
+import Outputable
+import PrimKind ( PrimKind(..), isFloatingKind )
+import I386Desc
+import Stix
+import SplitUniq
+import Unique
+import Pretty
+import Unpretty
+import Util
+
+type CodeBlock a = (OrdList a -> OrdList a)
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[I386CodeGen]{Generating I386 Code}
+%* *
+%************************************************************************
+
+This is the top-level code-generation function for the I386.
+
+\begin{code}
+
+i386CodeGen :: PprStyle -> [[StixTree]] -> SUniqSM Unpretty
+i386CodeGen sty trees =
+ mapSUs genI386Code trees `thenSUs` \ dynamicCodes ->
+ let
+ staticCodes = scheduleI386Code dynamicCodes
+ pretty = printLabeledCodes sty staticCodes
+ in
+ returnSUs pretty
+
+\end{code}
+
+This bit does the code scheduling. The scheduler must also deal with
+register allocation of temporaries. Much parallelism can be exposed via
+the OrdList, but more might occur, so further analysis might be needed.
+
+\begin{code}
+
+scheduleI386Code :: [I386Code] -> [I386Instr]
+scheduleI386Code = concat . map (runRegAllocate freeI386Regs reservedRegs)
+ where
+ freeI386Regs :: I386Regs
+ freeI386Regs = mkMRegs (extractMappedRegNos freeRegs)
+
+
+\end{code}
+
+Registers passed up the tree. If the stix code forces the register
+to live in a pre-decided machine register, it comes out as @Fixed@;
+otherwise, it comes out as @Any@, and the parent can decide which
+register to put it in.
+
+\begin{code}
+
+data Register
+ = Fixed Reg PrimKind (CodeBlock I386Instr)
+ | Any PrimKind (Reg -> (CodeBlock I386Instr))
+
+registerCode :: Register -> Reg -> CodeBlock I386Instr
+registerCode (Fixed _ _ code) reg = code
+registerCode (Any _ code) reg = code reg
+
+registerName :: Register -> Reg -> Reg
+registerName (Fixed reg _ _) _ = reg
+registerName (Any _ _) reg = reg
+
+registerKind :: Register -> PrimKind
+registerKind (Fixed _ pk _) = pk
+registerKind (Any pk _) = pk
+
+isFixed :: Register -> Bool
+isFixed (Fixed _ _ _) = True
+isFixed (Any _ _) = False
+
+\end{code}
+
+Memory addressing modes passed up the tree.
+
+\begin{code}
+
+data Amode = Amode Addr (CodeBlock I386Instr)
+
+amodeAddr (Amode addr _) = addr
+amodeCode (Amode _ code) = code
+
+\end{code}
+
+Condition codes passed up the tree.
+
+\begin{code}
+
+data Condition = Condition Bool Cond (CodeBlock I386Instr)
+
+condName (Condition _ cond _) = cond
+condFloat (Condition float _ _) = float
+condCode (Condition _ _ code) = code
+
+\end{code}
+
+General things for putting together code sequences.
+
+\begin{code}
+
+asmVoid :: OrdList I386Instr
+asmVoid = mkEmptyList
+
+asmInstr :: I386Instr -> I386Code
+asmInstr i = mkUnitList i
+
+asmSeq :: [I386Instr] -> I386Code
+asmSeq is = foldr (mkSeqList . asmInstr) asmVoid is
+
+asmParThen :: [I386Code] -> (CodeBlock I386Instr)
+asmParThen others code = mkSeqList (foldr mkParList mkEmptyList others) code
+
+returnInstr :: I386Instr -> SUniqSM (CodeBlock I386Instr)
+returnInstr instr = returnSUs (\xs -> mkSeqList (asmInstr instr) xs)
+
+returnInstrs :: [I386Instr] -> SUniqSM (CodeBlock I386Instr)
+returnInstrs instrs = returnSUs (\xs -> mkSeqList (asmSeq instrs) xs)
+
+returnSeq :: (CodeBlock I386Instr) -> [I386Instr] -> SUniqSM (CodeBlock I386Instr)
+returnSeq code instrs = returnSUs (\xs -> code (mkSeqList (asmSeq instrs) xs))
+
+mkSeqInstr :: I386Instr -> (CodeBlock I386Instr)
+mkSeqInstr instr code = mkSeqList (asmInstr instr) code
+
+mkSeqInstrs :: [I386Instr] -> (CodeBlock I386Instr)
+mkSeqInstrs instrs code = mkSeqList (asmSeq instrs) code
+
+\end{code}
+
+Top level i386 code generator for a chunk of stix code.
+
+\begin{code}
+
+genI386Code :: [StixTree] -> SUniqSM (I386Code)
+
+genI386Code trees =
+ mapSUs getCode trees `thenSUs` \ blocks ->
+ returnSUs (foldr (.) id blocks asmVoid)
+
+\end{code}
+
+Code extractor for an entire stix tree---stix statement level.
+
+\begin{code}
+
+getCode
+ :: StixTree -- a stix statement
+ -> SUniqSM (CodeBlock I386Instr)
+
+getCode (StSegment seg) = returnInstr (SEGMENT seg)
+
+getCode (StAssign pk dst src)
+ | isFloatingKind pk = assignFltCode pk dst src
+ | otherwise = assignIntCode pk dst src
+
+getCode (StLabel lab) = returnInstr (LABEL lab)
+
+getCode (StFunBegin lab) = returnInstr (LABEL lab)
+
+getCode (StFunEnd lab) = returnSUs id
+
+getCode (StJump arg) = genJump arg
+
+getCode (StFallThrough lbl) = returnSUs id
+
+getCode (StCondJump lbl arg) = genCondJump lbl arg
+
+getCode (StData kind args) =
+ mapAndUnzipSUs getData args `thenSUs` \ (codes, imms) ->
+ returnSUs (\xs -> mkSeqList (asmInstr (DATA (kindToSize kind) imms))
+ (foldr1 (.) codes xs))
+ where
+ getData :: StixTree -> SUniqSM (CodeBlock I386Instr, Imm)
+ getData (StInt i) = returnSUs (id, ImmInteger i)
+#if __GLASGOW_HASKELL__ >= 23
+-- getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : _showRational 30 d))
+ -- yurgh (WDP 94/12)
+ getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : ppShow 80 (ppRational d)))
+#else
+ getData (StDouble d) = returnSUs (id, strImmLit ('0' : 'd' : show d))
+#endif
+ getData (StLitLbl s) = returnSUs (id, ImmLit (uppBeside (uppChar '_') s))
+ getData (StLitLit s) = returnSUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
+ getData (StString s) =
+ getUniqLabelNCG `thenSUs` \ lbl ->
+ returnSUs (mkSeqInstrs [LABEL lbl, ASCII True (_UNPK_ s)], ImmCLbl lbl)
+ getData (StCLbl l) = returnSUs (id, ImmCLbl l)
+
+getCode (StCall fn VoidKind args) = genCCall fn VoidKind args
+
+getCode (StComment s) = returnInstr (COMMENT s)
+
+\end{code}
+
+Generate code to get a subtree into a register.
+
+\begin{code}
+
+getReg :: StixTree -> SUniqSM Register
+
+getReg (StReg (StixMagicId stgreg)) =
+ case stgRegMap stgreg of
+ Just reg -> returnSUs (Fixed reg (kindFromMagicId stgreg) id)
+ -- cannot be Nothing
+
+getReg (StReg (StixTemp u pk)) = returnSUs (Fixed (UnmappedReg u pk) pk id)
+
+getReg (StDouble 0.0)
+ = let
+ code dst = mkSeqInstrs [FLDZ]
+ in
+ returnSUs (Any DoubleKind code)
+
+getReg (StDouble 1.0)
+ = let
+ code dst = mkSeqInstrs [FLD1]
+ in
+ returnSUs (Any DoubleKind code)
+
+getReg (StDouble d) =
+ getUniqLabelNCG `thenSUs` \ lbl ->
+ --getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ let code dst = mkSeqInstrs [
+ SEGMENT DataSegment,
+ LABEL lbl,
+#if __GLASGOW_HASKELL__ >= 23
+-- DATA D [strImmLit ('0' : 'd' :_showRational 30 d)],
+ DATA D [strImmLit ('0' : 'd' :ppShow 80 (ppRational d))],
+#else
+ DATA D [strImmLit ('0' : 'd' :show d)],
+#endif
+ SEGMENT TextSegment,
+ FLD D (OpImm (ImmCLbl lbl))
+ ]
+ in
+ returnSUs (Any DoubleKind code)
+
+getReg (StString s) =
+ getUniqLabelNCG `thenSUs` \ lbl ->
+ let code dst = mkSeqInstrs [
+ SEGMENT DataSegment,
+ LABEL lbl,
+ ASCII True (_UNPK_ s),
+ SEGMENT TextSegment,
+ MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
+ in
+ returnSUs (Any PtrKind code)
+
+getReg (StLitLit s) | _HEAD_ s == '"' && last xs == '"' =
+ getUniqLabelNCG `thenSUs` \ lbl ->
+ let code dst = mkSeqInstrs [
+ SEGMENT DataSegment,
+ LABEL lbl,
+ ASCII False (init xs),
+ SEGMENT TextSegment,
+ MOV L (OpImm (ImmCLbl lbl)) (OpReg dst)]
+ in
+ returnSUs (Any PtrKind code)
+ where
+ xs = _UNPK_ (_TAIL_ s)
+
+
+getReg tree@(StIndex _ _ _) = getReg (mangleIndexTree tree)
+
+getReg (StCall fn kind args) =
+ genCCall fn kind args `thenSUs` \ call ->
+ returnSUs (Fixed reg kind call)
+ where
+ reg = if isFloatingKind kind then st0 else eax
+
+getReg (StPrim primop args) =
+ case primop of
+
+ CharGtOp -> condIntReg GT args
+ CharGeOp -> condIntReg GE args
+ CharEqOp -> condIntReg EQ args
+ CharNeOp -> condIntReg NE args
+ CharLtOp -> condIntReg LT args
+ CharLeOp -> condIntReg LE args
+
+ IntAddOp -> -- this should be optimised by the generic Opts,
+ -- I don't know why it is not (sometimes)!
+ case args of
+ [x, StInt 0] -> getReg x
+ _ -> addCode L args
+
+ IntSubOp -> subCode L args
+ IntMulOp -> trivialCode (IMUL L) args True
+ IntQuotOp -> divCode L args True -- division
+ IntRemOp -> divCode L args False -- remainder
+ IntNegOp -> trivialUCode (NEGI L) args
+ IntAbsOp -> absIntCode args
+
+ AndOp -> trivialCode (AND L) args True
+ OrOp -> trivialCode (OR L) args True
+ NotOp -> trivialUCode (NOT L) args
+ SllOp -> trivialCode (SHL L) args False
+ SraOp -> trivialCode (SAR L) args False
+ SrlOp -> trivialCode (SHR L) args False
+ ISllOp -> panic "I386Gen:isll"
+ ISraOp -> panic "I386Gen:isra"
+ ISrlOp -> panic "I386Gen:isrl"
+
+ IntGtOp -> condIntReg GT args
+ IntGeOp -> condIntReg GE args
+ IntEqOp -> condIntReg EQ args
+ IntNeOp -> condIntReg NE args
+ IntLtOp -> condIntReg LT args
+ IntLeOp -> condIntReg LE args
+
+ WordGtOp -> condIntReg GU args
+ WordGeOp -> condIntReg GEU args
+ WordEqOp -> condIntReg EQ args
+ WordNeOp -> condIntReg NE args
+ WordLtOp -> condIntReg LU args
+ WordLeOp -> condIntReg LEU args
+
+ AddrGtOp -> condIntReg GU args
+ AddrGeOp -> condIntReg GEU args
+ AddrEqOp -> condIntReg EQ args
+ AddrNeOp -> condIntReg NE args
+ AddrLtOp -> condIntReg LU args
+ AddrLeOp -> condIntReg LEU args
+
+ FloatAddOp -> trivialFCode FloatKind FADD FADD FADDP FADDP args
+ FloatSubOp -> trivialFCode FloatKind FSUB FSUBR FSUBP FSUBRP args
+ FloatMulOp -> trivialFCode FloatKind FMUL FMUL FMULP FMULP args
+ FloatDivOp -> trivialFCode FloatKind FDIV FDIVR FDIVP FDIVRP args
+ FloatNegOp -> trivialUFCode FloatKind FCHS args
+
+ FloatGtOp -> condFltReg GT args
+ FloatGeOp -> condFltReg GE args
+ FloatEqOp -> condFltReg EQ args
+ FloatNeOp -> condFltReg NE args
+ FloatLtOp -> condFltReg LT args
+ FloatLeOp -> condFltReg LE args
+
+ FloatExpOp -> promoteAndCall SLIT("exp") DoubleKind
+ FloatLogOp -> promoteAndCall SLIT("log") DoubleKind
+ FloatSqrtOp -> trivialUFCode FloatKind FSQRT args
+
+ FloatSinOp -> promoteAndCall SLIT("sin") DoubleKind
+ --trivialUFCode FloatKind FSIN args
+ FloatCosOp -> promoteAndCall SLIT("cos") DoubleKind
+ --trivialUFCode FloatKind FCOS args
+ FloatTanOp -> promoteAndCall SLIT("tan") DoubleKind
+
+ FloatAsinOp -> promoteAndCall SLIT("asin") DoubleKind
+ FloatAcosOp -> promoteAndCall SLIT("acos") DoubleKind
+ FloatAtanOp -> promoteAndCall SLIT("atan") DoubleKind
+
+ FloatSinhOp -> promoteAndCall SLIT("sinh") DoubleKind
+ FloatCoshOp -> promoteAndCall SLIT("cosh") DoubleKind
+ FloatTanhOp -> promoteAndCall SLIT("tanh") DoubleKind
+
+ FloatPowerOp -> promoteAndCall SLIT("pow") DoubleKind
+
+ DoubleAddOp -> trivialFCode DoubleKind FADD FADD FADDP FADDP args
+ DoubleSubOp -> trivialFCode DoubleKind FSUB FSUBR FSUBP FSUBRP args
+ DoubleMulOp -> trivialFCode DoubleKind FMUL FMUL FMULP FMULP args
+ DoubleDivOp -> trivialFCode DoubleKind FDIV FDIVR FDIVP FDIVRP args
+ DoubleNegOp -> trivialUFCode DoubleKind FCHS args
+
+ DoubleGtOp -> condFltReg GT args
+ DoubleGeOp -> condFltReg GE args
+ DoubleEqOp -> condFltReg EQ args
+ DoubleNeOp -> condFltReg NE args
+ DoubleLtOp -> condFltReg LT args
+ DoubleLeOp -> condFltReg LE args
+
+ DoubleExpOp -> call SLIT("exp") DoubleKind
+ DoubleLogOp -> call SLIT("log") DoubleKind
+ DoubleSqrtOp -> trivialUFCode DoubleKind FSQRT args
+
+ DoubleSinOp -> call SLIT("sin") DoubleKind
+ --trivialUFCode DoubleKind FSIN args
+ DoubleCosOp -> call SLIT("cos") DoubleKind
+ --trivialUFCode DoubleKind FCOS args
+ DoubleTanOp -> call SLIT("tan") DoubleKind
+
+ DoubleAsinOp -> call SLIT("asin") DoubleKind
+ DoubleAcosOp -> call SLIT("acos") DoubleKind
+ DoubleAtanOp -> call SLIT("atan") DoubleKind
+
+ DoubleSinhOp -> call SLIT("sinh") DoubleKind
+ DoubleCoshOp -> call SLIT("cosh") DoubleKind
+ DoubleTanhOp -> call SLIT("tanh") DoubleKind
+
+ DoublePowerOp -> call SLIT("pow") DoubleKind
+
+ OrdOp -> coerceIntCode IntKind args
+ ChrOp -> chrCode args
+
+ Float2IntOp -> coerceFP2Int args
+ Int2FloatOp -> coerceInt2FP FloatKind args
+ Double2IntOp -> coerceFP2Int args
+ Int2DoubleOp -> coerceInt2FP DoubleKind args
+
+ Double2FloatOp -> coerceFltCode args
+ Float2DoubleOp -> coerceFltCode args
+
+ where
+ call fn pk = getReg (StCall fn pk args)
+ promoteAndCall fn pk = getReg (StCall fn pk (map promote args))
+ where
+ promote x = StPrim Float2DoubleOp [x]
+
+getReg (StInd pk mem) =
+ getAmode mem `thenSUs` \ amode ->
+ let
+ code = amodeCode amode
+ src = amodeAddr amode
+ size = kindToSize pk
+ code__2 dst = code .
+ if pk == DoubleKind || pk == FloatKind
+ then mkSeqInstr (FLD {-D-} size (OpAddr src))
+ else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
+ in
+ returnSUs (Any pk code__2)
+
+
+getReg (StInt i)
+ = let
+ src = ImmInt (fromInteger i)
+ code dst = mkSeqInstr (MOV L (OpImm src) (OpReg dst))
+ in
+ returnSUs (Any IntKind code)
+
+getReg leaf
+ | maybeToBool imm =
+ let
+ code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
+ in
+ returnSUs (Any PtrKind code)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+
+\end{code}
+
+Now, given a tree (the argument to an StInd) that references memory,
+produce a suitable addressing mode.
+
+\begin{code}
+
+getAmode :: StixTree -> SUniqSM Amode
+
+getAmode tree@(StIndex _ _ _) = getAmode (mangleIndexTree tree)
+
+getAmode (StPrim IntSubOp [x, StInt i])
+ =
+ getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ getReg x `thenSUs` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (-(fromInteger i))
+ in
+ returnSUs (Amode (Addr (Just reg) Nothing off) code)
+
+getAmode (StPrim IntAddOp [x, StInt i])
+ | maybeToBool imm
+ = let
+ code = mkSeqInstrs []
+ in
+ returnSUs (Amode (ImmAddr imm__2 (fromInteger i)) code)
+ where
+ imm = maybeImm x
+ imm__2 = case imm of Just x -> x
+
+getAmode (StPrim IntAddOp [x, StInt i])
+ =
+ getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ getReg x `thenSUs` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (fromInteger i)
+ in
+ returnSUs (Amode (Addr (Just reg) Nothing off) code)
+
+getAmode (StPrim IntAddOp [x, y]) =
+ getNewRegNCG PtrKind `thenSUs` \ tmp1 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ getReg x `thenSUs` \ register1 ->
+ getReg y `thenSUs` \ register2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ reg1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ reg2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2]
+ in
+ returnSUs (Amode (Addr (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
+
+getAmode leaf
+ | maybeToBool imm =
+ let code = mkSeqInstrs []
+ in
+ returnSUs (Amode (ImmAddr imm__2 0) code)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+
+getAmode other =
+ getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ getReg other `thenSUs` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = Nothing
+ in
+ returnSUs (Amode (Addr (Just reg) Nothing (ImmInt 0)) code)
+
+\end{code}
+
+\begin{code}
+getOp
+ :: StixTree
+ -> SUniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
+getOp (StInt i)
+ = returnSUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
+
+getOp (StInd pk mem)
+ = getAmode mem `thenSUs` \ amode ->
+ let
+ code = amodeCode amode --asmVoid
+ addr = amodeAddr amode
+ sz = kindToSize pk
+ in returnSUs (code, OpAddr addr, sz)
+
+getOp op
+ = getReg op `thenSUs` \ register ->
+ getNewRegNCG (registerKind register)
+ `thenSUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ pk = registerKind register
+ sz = kindToSize pk
+ in
+ returnSUs (code, OpReg reg, sz)
+
+getOpRI
+ :: StixTree
+ -> SUniqSM (CodeBlock I386Instr,Operand, Size) -- code, operator, size
+getOpRI op
+ | maybeToBool imm
+ = returnSUs (asmParThen [], OpImm imm_op, L)
+ where
+ imm = maybeImm op
+ imm_op = case imm of Just x -> x
+
+getOpRI op
+ = getReg op `thenSUs` \ register ->
+ getNewRegNCG (registerKind register)
+ `thenSUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ pk = registerKind register
+ sz = kindToSize pk
+ in
+ returnSUs (code, OpReg reg, sz)
+
+\end{code}
+
+Set up a condition code for a conditional branch.
+
+\begin{code}
+
+getCondition :: StixTree -> SUniqSM Condition
+
+getCondition (StPrim primop args) =
+ case primop of
+
+ CharGtOp -> condIntCode GT args
+ CharGeOp -> condIntCode GE args
+ CharEqOp -> condIntCode EQ args
+ CharNeOp -> condIntCode NE args
+ CharLtOp -> condIntCode LT args
+ CharLeOp -> condIntCode LE args
+
+ IntGtOp -> condIntCode GT args
+ IntGeOp -> condIntCode GE args
+ IntEqOp -> condIntCode EQ args
+ IntNeOp -> condIntCode NE args
+ IntLtOp -> condIntCode LT args
+ IntLeOp -> condIntCode LE args
+
+ WordGtOp -> condIntCode GU args
+ WordGeOp -> condIntCode GEU args
+ WordEqOp -> condIntCode EQ args
+ WordNeOp -> condIntCode NE args
+ WordLtOp -> condIntCode LU args
+ WordLeOp -> condIntCode LEU args
+
+ AddrGtOp -> condIntCode GU args
+ AddrGeOp -> condIntCode GEU args
+ AddrEqOp -> condIntCode EQ args
+ AddrNeOp -> condIntCode NE args
+ AddrLtOp -> condIntCode LU args
+ AddrLeOp -> condIntCode LEU args
+
+ FloatGtOp -> condFltCode GT args
+ FloatGeOp -> condFltCode GE args
+ FloatEqOp -> condFltCode EQ args
+ FloatNeOp -> condFltCode NE args
+ FloatLtOp -> condFltCode LT args
+ FloatLeOp -> condFltCode LE args
+
+ DoubleGtOp -> condFltCode GT args
+ DoubleGeOp -> condFltCode GE args
+ DoubleEqOp -> condFltCode EQ args
+ DoubleNeOp -> condFltCode NE args
+ DoubleLtOp -> condFltCode LT args
+ DoubleLeOp -> condFltCode LE args
+
+\end{code}
+
+Turn a boolean expression into a condition, to be passed
+back up the tree.
+
+\begin{code}
+
+condIntCode, condFltCode :: Cond -> [StixTree] -> SUniqSM Condition
+condIntCode cond [StInd _ x, y]
+ | maybeToBool imm
+ = getAmode x `thenSUs` \ amode ->
+ let
+ code1 = amodeCode amode asmVoid
+ y__2 = amodeAddr amode
+ code__2 = asmParThen [code1] .
+ mkSeqInstr (CMP L (OpImm imm__2) (OpAddr y__2))
+ in
+ returnSUs (Condition False cond code__2)
+ where
+ imm = maybeImm y
+ imm__2 = case imm of Just x -> x
+
+condIntCode cond [x, StInt 0]
+ = getReg x `thenSUs` \ register1 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code__2 = asmParThen [code1] .
+ mkSeqInstr (TEST L (OpReg src1) (OpReg src1))
+ in
+ returnSUs (Condition False cond code__2)
+
+condIntCode cond [x, y]
+ | maybeToBool imm
+ = getReg x `thenSUs` \ register1 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code__2 = asmParThen [code1] .
+ mkSeqInstr (CMP L (OpImm imm__2) (OpReg src1))
+ in
+ returnSUs (Condition False cond code__2)
+ where
+ imm = maybeImm y
+ imm__2 = case imm of Just x -> x
+
+condIntCode cond [StInd _ x, y]
+ = getAmode x `thenSUs` \ amode ->
+ getReg y `thenSUs` \ register2 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ let
+ code1 = amodeCode amode asmVoid
+ src1 = amodeAddr amode
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstr (CMP L (OpReg src2) (OpAddr src1))
+ in
+ returnSUs (Condition False cond code__2)
+
+condIntCode cond [y, StInd _ x]
+ = getAmode x `thenSUs` \ amode ->
+ getReg y `thenSUs` \ register2 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ let
+ code1 = amodeCode amode asmVoid
+ src1 = amodeAddr amode
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstr (CMP L (OpAddr src1) (OpReg src2))
+ in
+ returnSUs (Condition False cond code__2)
+
+condIntCode cond [x, y] =
+ getReg x `thenSUs` \ register1 ->
+ getReg y `thenSUs` \ register2 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstr (CMP L (OpReg src2) (OpReg src1))
+ in
+ returnSUs (Condition False cond code__2)
+
+condFltCode cond [x, StDouble 0.0] =
+ getReg x `thenSUs` \ register1 ->
+ getNewRegNCG (registerKind register1)
+ `thenSUs` \ tmp1 ->
+ let
+ pk1 = registerKind register1
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+
+ code__2 = asmParThen [code1 asmVoid] .
+ mkSeqInstrs [FTST, FSTP D (OpReg st0), -- or FLDZ, FUCOMPP ?
+ FNSTSW,
+ --AND HB (OpImm (ImmInt 68)) (OpReg eax),
+ --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
+ SAHF
+ ]
+ in
+ returnSUs (Condition True (fixFPCond cond) code__2)
+
+condFltCode cond [x, y] =
+ getReg x `thenSUs` \ register1 ->
+ getReg y `thenSUs` \ register2 ->
+ getNewRegNCG (registerKind register1)
+ `thenSUs` \ tmp1 ->
+ getNewRegNCG (registerKind register2)
+ `thenSUs` \ tmp2 ->
+ let
+ pk1 = registerKind register1
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+
+ code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
+ mkSeqInstrs [FUCOMPP,
+ FNSTSW,
+ --AND HB (OpImm (ImmInt 68)) (OpReg eax),
+ --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
+ SAHF
+ ]
+ in
+ returnSUs (Condition True (fixFPCond cond) code__2)
+
+\end{code}
+
+Turn those condition codes into integers now (when they appear on
+the right hand side of an assignment).
+
+\begin{code}
+
+condIntReg :: Cond -> [StixTree] -> SUniqSM Register
+condIntReg cond args =
+ condIntCode cond args `thenSUs` \ condition ->
+ getNewRegNCG IntKind `thenSUs` \ tmp ->
+ --getReg dst `thenSUs` \ register ->
+ let
+ --code2 = registerCode register tmp asmVoid
+ --dst__2 = registerName register tmp
+ code = condCode condition
+ cond = condName condition
+-- ToDo: if dst is eax, ebx, ecx, or edx we would not need the move.
+ code__2 dst = code . mkSeqInstrs [
+ SETCC cond (OpReg tmp),
+ AND L (OpImm (ImmInt 1)) (OpReg tmp),
+ MOV L (OpReg tmp) (OpReg dst)]
+ in
+ returnSUs (Any IntKind code__2)
+
+condFltReg :: Cond -> [StixTree] -> SUniqSM Register
+
+condFltReg cond args =
+ getUniqLabelNCG `thenSUs` \ lbl1 ->
+ getUniqLabelNCG `thenSUs` \ lbl2 ->
+ condFltCode cond args `thenSUs` \ condition ->
+ let
+ code = condCode condition
+ cond = condName condition
+ code__2 dst = code . mkSeqInstrs [
+ JXX cond lbl1,
+ MOV L (OpImm (ImmInt 0)) (OpReg dst),
+ JXX ALWAYS lbl2,
+ LABEL lbl1,
+ MOV L (OpImm (ImmInt 1)) (OpReg dst),
+ LABEL lbl2]
+ in
+ returnSUs (Any IntKind code__2)
+
+\end{code}
+
+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).
+
+\begin{code}
+
+assignIntCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock I386Instr)
+assignIntCode pk (StInd _ dst) src
+ = getAmode dst `thenSUs` \ amode ->
+ getOpRI src `thenSUs` \ (codesrc, opsrc, sz) ->
+ let
+ code1 = amodeCode amode asmVoid
+ dst__2 = amodeAddr amode
+ code__2 = asmParThen [code1, codesrc asmVoid] .
+ mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
+ in
+ returnSUs code__2
+
+assignIntCode pk dst (StInd _ src) =
+ getNewRegNCG IntKind `thenSUs` \ tmp ->
+ getAmode src `thenSUs` \ amode ->
+ getReg dst `thenSUs` \ register ->
+ let
+ code1 = amodeCode amode asmVoid
+ src__2 = amodeAddr amode
+ code2 = registerCode register tmp asmVoid
+ dst__2 = registerName register tmp
+ sz = kindToSize pk
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
+ in
+ returnSUs code__2
+
+assignIntCode pk dst src =
+ getReg dst `thenSUs` \ register1 ->
+ getReg src `thenSUs` \ register2 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp ->
+ let
+ dst__2 = registerName register1 tmp
+ code = registerCode register2 dst__2
+ src__2 = registerName register2 dst__2
+ code__2 = if isFixed register2 && dst__2 /= src__2
+ then code . mkSeqInstr (MOV L (OpReg src__2) (OpReg dst__2))
+ else
+ code
+ in
+ returnSUs code__2
+
+assignFltCode :: PrimKind -> StixTree -> StixTree -> SUniqSM (CodeBlock I386Instr)
+assignFltCode pk (StInd pk_dst dst) (StInd pk_src src)
+ = getNewRegNCG IntKind `thenSUs` \ tmp ->
+ getAmode src `thenSUs` \ amodesrc ->
+ getAmode dst `thenSUs` \ amodedst ->
+ --getReg src `thenSUs` \ register ->
+ let
+ codesrc1 = amodeCode amodesrc asmVoid
+ addrsrc1 = amodeAddr amodesrc
+ codedst1 = amodeCode amodedst asmVoid
+ addrdst1 = amodeAddr amodedst
+ addrsrc2 = case (offset addrsrc1 4) of Just x -> x
+ addrdst2 = case (offset addrdst1 4) of Just x -> x
+
+ code__2 = asmParThen [codesrc1, codedst1] .
+ mkSeqInstrs ([MOV L (OpAddr addrsrc1) (OpReg tmp),
+ MOV L (OpReg tmp) (OpAddr addrdst1)]
+ ++
+ if pk == DoubleKind
+ then [MOV L (OpAddr addrsrc2) (OpReg tmp),
+ MOV L (OpReg tmp) (OpAddr addrdst2)]
+ else [])
+ in
+ returnSUs code__2
+
+assignFltCode pk (StInd _ dst) src =
+ --getNewRegNCG pk `thenSUs` \ tmp ->
+ getAmode dst `thenSUs` \ amode ->
+ getReg src `thenSUs` \ register ->
+ let
+ sz = kindToSize pk
+ dst__2 = amodeAddr amode
+
+ code1 = amodeCode amode asmVoid
+ code2 = registerCode register {-tmp-}st0 asmVoid
+
+ --src__2 = registerName register tmp
+ pk__2 = registerKind register
+ sz__2 = kindToSize pk__2
+
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstr (FSTP sz (OpAddr dst__2))
+ in
+ returnSUs code__2
+
+assignFltCode pk dst src =
+ getReg dst `thenSUs` \ register1 ->
+ getReg src `thenSUs` \ register2 ->
+ --getNewRegNCG (registerKind register2)
+ -- `thenSUs` \ tmp ->
+ let
+ sz = kindToSize pk
+ dst__2 = registerName register1 st0 --tmp
+
+ code = registerCode register2 dst__2
+ src__2 = registerName register2 dst__2
+
+ code__2 = code
+ in
+ returnSUs code__2
+
+\end{code}
+
+Generating an unconditional branch. We accept two types of targets:
+an immediate CLabel or a tree that gets evaluated into a register.
+Any CLabels which are AsmTemporaries are assumed to be in the local
+block of code, close enough for a branch instruction. Other CLabels
+are assumed to be far away, so we use call.
+
+Do not fill the delay slots here; you will confuse the register allocator.
+
+\begin{code}
+
+genJump
+ :: StixTree -- the branch target
+ -> SUniqSM (CodeBlock I386Instr)
+
+{-
+genJump (StCLbl lbl)
+ | isAsmTemp lbl = returnInstrs [JXX ALWAYS lbl]
+ | otherwise = returnInstrs [JMP (OpImm target)]
+ where
+ target = ImmCLbl lbl
+-}
+
+genJump (StInd pk mem) =
+ getAmode mem `thenSUs` \ amode ->
+ let
+ code = amodeCode amode
+ target = amodeAddr amode
+ in
+ returnSeq code [JMP (OpAddr target)]
+
+genJump tree
+ | maybeToBool imm
+ = returnInstr (JMP (OpImm target))
+ where
+ imm = maybeImm tree
+ target = case imm of Just x -> x
+
+
+genJump tree =
+ getReg tree `thenSUs` \ register ->
+ getNewRegNCG PtrKind `thenSUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ target = registerName register tmp
+ in
+ returnSeq code [JMP (OpReg target)]
+
+\end{code}
+
+Conditional jumps are always to local labels, so we can use
+branch instructions. First, we have to ensure that the condition
+codes are set according to the supplied comparison operation.
+
+\begin{code}
+
+genCondJump
+ :: CLabel -- the branch target
+ -> StixTree -- the condition on which to branch
+ -> SUniqSM (CodeBlock I386Instr)
+
+genCondJump lbl bool =
+ getCondition bool `thenSUs` \ condition ->
+ let
+ code = condCode condition
+ cond = condName condition
+ target = ImmCLbl lbl
+ in
+ returnSeq code [JXX cond lbl]
+
+\end{code}
+
+\begin{code}
+
+genCCall
+ :: FAST_STRING -- function to call
+ -> PrimKind -- type of the result
+ -> [StixTree] -- arguments (of mixed type)
+ -> SUniqSM (CodeBlock I386Instr)
+
+genCCall fn kind [StInt i]
+ | fn == SLIT ("PerformGC_wrapper")
+ = getUniqLabelNCG `thenSUs` \ lbl ->
+ let
+ call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
+ MOV L (OpImm (ImmCLbl lbl))
+ -- this is hardwired
+ (OpAddr (Addr (Just ebx) Nothing (ImmInt 104))),
+ JMP (OpImm (ImmLit (uppPStr (SLIT ("_PerformGC_wrapper"))))),
+ LABEL lbl]
+ in
+ returnInstrs call
+
+genCCall fn kind args =
+ mapSUs getCallArg args `thenSUs` \ argCode ->
+ let
+ nargs = length args
+ code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))),
+ MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
+ ]
+ ]
+ code2 = asmParThen (map ($ asmVoid) (reverse argCode))
+ call = [CALL (ImmLit fn__2) -- ,
+ -- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp),
+ -- MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
+ ]
+ in
+ returnSeq (code1 . code2) call
+ where
+ -- function names that begin with '.' are assumed to be special internally
+ -- generated names like '.mul,' which don't get an underscore prefix
+ fn__2 = case (_HEAD_ fn) of
+ '.' -> uppPStr fn
+ _ -> uppBeside (uppChar '_') (uppPStr fn)
+
+ getCallArg
+ :: StixTree -- Current argument
+ -> SUniqSM (CodeBlock I386Instr) -- code
+ getCallArg arg =
+ getOp arg `thenSUs` \ (code, op, sz) ->
+ returnSUs (code . mkSeqInstr (PUSH sz op))
+\end{code}
+
+Trivial (dyadic) instructions. Only look for constants on the right hand
+side, because that's where the generic optimizer will have put them.
+
+\begin{code}
+
+trivialCode
+ :: (Operand -> Operand -> I386Instr)
+ -> [StixTree]
+ -> Bool -- is the instr commutative?
+ -> SUniqSM Register
+
+trivialCode instr [x, y] _
+ | maybeToBool imm
+ = getReg x `thenSUs` \ register1 ->
+ --getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ let
+ fixedname = registerName register1 eax
+ code__2 dst = let code1 = registerCode register1 dst
+ src1 = registerName register1 dst
+ in code1 .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpImm imm__2) (OpReg dst)]
+ else
+ mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
+ in
+ returnSUs (Any IntKind code__2)
+ where
+ imm = maybeImm y
+ imm__2 = case imm of Just x -> x
+
+trivialCode instr [x, y] _
+ | maybeToBool imm
+ = getReg y `thenSUs` \ register1 ->
+ --getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ let
+ fixedname = registerName register1 eax
+ code__2 dst = let code1 = registerCode register1 dst
+ src1 = registerName register1 dst
+ in code1 .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpImm imm__2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
+ in
+ returnSUs (Any IntKind code__2)
+ where
+ imm = maybeImm x
+ imm__2 = case imm of Just x -> x
+
+trivialCode instr [x, StInd pk mem] _
+ = getReg x `thenSUs` \ register ->
+ --getNewRegNCG IntKind `thenSUs` \ tmp ->
+ getAmode mem `thenSUs` \ amode ->
+ let
+ fixedname = registerName register eax
+ code2 = amodeCode amode asmVoid
+ src2 = amodeAddr amode
+ code__2 dst = let code1 = registerCode register dst asmVoid
+ src1 = registerName register dst
+ in asmParThen [code1, code2] .
+ if isFixed register && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpAddr src2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpAddr src2) (OpReg src1))
+ in
+ returnSUs (Any pk code__2)
+
+trivialCode instr [StInd pk mem, y] _
+ = getReg y `thenSUs` \ register ->
+ --getNewRegNCG IntKind `thenSUs` \ tmp ->
+ getAmode mem `thenSUs` \ amode ->
+ let
+ fixedname = registerName register eax
+ code2 = amodeCode amode asmVoid
+ src2 = amodeAddr amode
+ code__2 dst = let
+ code1 = registerCode register dst asmVoid
+ src1 = registerName register dst
+ in asmParThen [code1, code2] .
+ if isFixed register && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpAddr src2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpAddr src2) (OpReg src1))
+ in
+ returnSUs (Any pk code__2)
+
+trivialCode instr [x, y] is_comm_op
+ = getReg x `thenSUs` \ register1 ->
+ getReg y `thenSUs` \ register2 ->
+ --getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ let
+ fixedname = registerName register1 eax
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 dst = let
+ code1 = registerCode register1 dst asmVoid
+ src1 = registerName register1 dst
+ in asmParThen [code1, code2] .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ instr (OpReg src2) (OpReg dst)]
+ else
+ mkSeqInstr (instr (OpReg src2) (OpReg src1))
+ in
+ returnSUs (Any IntKind code__2)
+
+addCode
+ :: Size
+ -> [StixTree]
+ -> SUniqSM Register
+addCode sz [x, StInt y]
+ =
+ getReg x `thenSUs` \ register ->
+ getNewRegNCG IntKind `thenSUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src1 = registerName register tmp
+ src2 = ImmInt (fromInteger y)
+ code__2 dst = code .
+ mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+ in
+ returnSUs (Any IntKind code__2)
+
+addCode sz [x, StInd _ mem]
+ = getReg x `thenSUs` \ register1 ->
+ --getNewRegNCG (registerKind register1)
+ -- `thenSUs` \ tmp1 ->
+ getAmode mem `thenSUs` \ amode ->
+ let
+ code2 = amodeCode amode
+ src2 = amodeAddr amode
+
+ fixedname = registerName register1 eax
+ code__2 dst = let code1 = registerCode register1 dst
+ src1 = registerName register1 dst
+ in asmParThen [code2 asmVoid,code1 asmVoid] .
+ if isFixed register1 && src1 /= dst
+ then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
+ ADD sz (OpAddr src2) (OpReg dst)]
+ else
+ mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
+ in
+ returnSUs (Any IntKind code__2)
+
+addCode sz [StInd _ mem, y]
+ = getReg y `thenSUs` \ register2 ->
+ --getNewRegNCG (registerKind register2)
+ -- `thenSUs` \ tmp2 ->
+ getAmode mem `thenSUs` \ amode ->
+ let
+ code1 = amodeCode amode
+ src1 = amodeAddr amode
+
+ fixedname = registerName register2 eax
+ code__2 dst = let code2 = registerCode register2 dst
+ src2 = registerName register2 dst
+ in asmParThen [code1 asmVoid,code2 asmVoid] .
+ if isFixed register2 && src2 /= dst
+ then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
+ ADD sz (OpAddr src1) (OpReg dst)]
+ else
+ mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
+ in
+ returnSUs (Any IntKind code__2)
+
+addCode sz [x, y] =
+ getReg x `thenSUs` \ register1 ->
+ getReg y `thenSUs` \ register2 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 dst = asmParThen [code1, code2] .
+ mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
+ in
+ returnSUs (Any IntKind code__2)
+
+subCode
+ :: Size
+ -> [StixTree]
+ -> SUniqSM Register
+subCode sz [x, StInt y]
+ = getReg x `thenSUs` \ register ->
+ getNewRegNCG IntKind `thenSUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src1 = registerName register tmp
+ src2 = ImmInt (-(fromInteger y))
+ code__2 dst = code .
+ mkSeqInstr (LEA sz (OpAddr (Addr (Just src1) Nothing src2)) (OpReg dst))
+ in
+ returnSUs (Any IntKind code__2)
+
+subCode sz args = trivialCode (SUB sz) args False
+
+divCode
+ :: Size
+ -> [StixTree]
+ -> Bool -- True => division, False => remainder operation
+ -> SUniqSM Register
+
+-- x must go into eax, edx must be a sign-extension of eax,
+-- and y should go in some other register (or memory),
+-- so that we get edx:eax / reg -> eax (remainder in edx)
+-- Currently we chose to put y in memory (if it is not there already)
+divCode sz [x, StInd pk mem] is_division
+ = getReg x `thenSUs` \ register1 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ getAmode mem `thenSUs` \ amode ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = amodeCode amode asmVoid
+ src2 = amodeAddr amode
+ code__2 = asmParThen [code1, code2] .
+ mkSeqInstrs [MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr src2)]
+ in
+ returnSUs (Fixed (if is_division then eax else edx) IntKind code__2)
+
+divCode sz [x, StInt i] is_division
+ = getReg x `thenSUs` \ register1 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ src2 = ImmInt (fromInteger i)
+ code__2 = asmParThen [code1] .
+ mkSeqInstrs [-- we put src2 in (ebx)
+ MOV L (OpImm src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ in
+ returnSUs (Fixed (if is_division then eax else edx) IntKind code__2)
+
+divCode sz [x, y] is_division
+ = getReg x `thenSUs` \ register1 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp1 ->
+ getReg y `thenSUs` \ register2 ->
+ getNewRegNCG IntKind `thenSUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1 asmVoid
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2 asmVoid
+ src2 = registerName register2 tmp2
+ code__2 = asmParThen [code1, code2] .
+ if src2 == ecx || src2 == esi
+ then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpReg src2)]
+ else mkSeqInstrs [ -- we put src2 in (ebx)
+ MOV L (OpReg src2) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ in
+ returnSUs (Fixed (if is_division then eax else edx) IntKind code__2)
+
+trivialFCode
+ :: PrimKind
+ -> (Size -> Operand -> I386Instr)
+ -> (Size -> Operand -> I386Instr) -- reversed instr
+ -> I386Instr -- pop
+ -> I386Instr -- reversed instr, pop
+ -> [StixTree]
+ -> SUniqSM Register
+trivialFCode pk _ instrr _ _ [StInd pk' mem, y]
+ = getReg y `thenSUs` \ register2 ->
+ --getNewRegNCG (registerKind register2)
+ -- `thenSUs` \ tmp2 ->
+ getAmode mem `thenSUs` \ amode ->
+ let
+ code1 = amodeCode amode
+ src1 = amodeAddr amode
+
+ code__2 dst = let
+ code2 = registerCode register2 dst
+ src2 = registerName register2 dst
+ in asmParThen [code1 asmVoid,code2 asmVoid] .
+ mkSeqInstrs [instrr (kindToSize pk) (OpAddr src1)]
+ in
+ returnSUs (Any pk code__2)
+
+trivialFCode pk instr _ _ _ [x, StInd pk' mem]
+ = getReg x `thenSUs` \ register1 ->
+ --getNewRegNCG (registerKind register1)
+ -- `thenSUs` \ tmp1 ->
+ getAmode mem `thenSUs` \ amode ->
+ let
+ code2 = amodeCode amode
+ src2 = amodeAddr amode
+
+ code__2 dst = let
+ code1 = registerCode register1 dst
+ src1 = registerName register1 dst
+ in asmParThen [code2 asmVoid,code1 asmVoid] .
+ mkSeqInstrs [instr (kindToSize pk) (OpAddr src2)]
+ in
+ returnSUs (Any pk code__2)
+
+trivialFCode pk _ _ _ instrpr [x, y] =
+ getReg x `thenSUs` \ register1 ->
+ getReg y `thenSUs` \ register2 ->
+ --getNewRegNCG (registerKind register1)
+ -- `thenSUs` \ tmp1 ->
+ --getNewRegNCG (registerKind register2)
+ -- `thenSUs` \ tmp2 ->
+ getNewRegNCG DoubleKind `thenSUs` \ tmp ->
+ let
+ pk1 = registerKind register1
+ code1 = registerCode register1 st0 --tmp1
+ src1 = registerName register1 st0 --tmp1
+
+ pk2 = registerKind register2
+
+ code__2 dst = let
+ code2 = registerCode register2 dst
+ src2 = registerName register2 dst
+ in asmParThen [code1 asmVoid, code2 asmVoid] .
+ mkSeqInstr instrpr
+ in
+ returnSUs (Any pk1 code__2)
+
+\end{code}
+
+Trivial unary instructions. Note that we don't have to worry about
+matching an StInt as the argument, because genericOpt will already
+have handled the constant-folding.
+
+\begin{code}
+
+trivialUCode
+ :: (Operand -> I386Instr)
+ -> [StixTree]
+ -> SUniqSM Register
+
+trivialUCode instr [x] =
+ getReg x `thenSUs` \ register ->
+-- getNewRegNCG IntKind `thenSUs` \ tmp ->
+ let
+-- fixedname = registerName register eax
+ code__2 dst = let
+ code = registerCode register dst
+ src = registerName register dst
+ in code . if isFixed register && dst /= src
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ instr (OpReg dst)]
+ else mkSeqInstr (instr (OpReg src))
+ in
+ returnSUs (Any IntKind code__2)
+
+trivialUFCode
+ :: PrimKind
+ -> I386Instr
+ -> [StixTree]
+ -> SUniqSM Register
+
+trivialUFCode pk instr [StInd pk' mem] =
+ getAmode mem `thenSUs` \ amode ->
+ let
+ code = amodeCode amode
+ src = amodeAddr amode
+ code__2 dst = code . mkSeqInstrs [FLD (kindToSize pk) (OpAddr src),
+ instr]
+ in
+ returnSUs (Any pk code__2)
+
+trivialUFCode pk instr [x] =
+ getReg x `thenSUs` \ register ->
+ --getNewRegNCG pk `thenSUs` \ tmp ->
+ let
+ code__2 dst = let
+ code = registerCode register dst
+ src = registerName register dst
+ in code . mkSeqInstrs [instr]
+ in
+ returnSUs (Any pk code__2)
+\end{code}
+
+Absolute value on integers, mostly for gmp size check macros. Again,
+the argument cannot be an StInt, because genericOpt already folded
+constants.
+
+\begin{code}
+
+absIntCode :: [StixTree] -> SUniqSM Register
+absIntCode [x] =
+ getReg x `thenSUs` \ register ->
+ --getNewRegNCG IntKind `thenSUs` \ reg ->
+ getUniqLabelNCG `thenSUs` \ lbl ->
+ let
+ code__2 dst = let code = registerCode register dst
+ src = registerName register dst
+ in code . if isFixed register && dst /= src
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ TEST L (OpReg dst) (OpReg dst),
+ JXX GE lbl,
+ NEGI L (OpReg dst),
+ LABEL lbl]
+ else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
+ JXX GE lbl,
+ NEGI L (OpReg src),
+ LABEL lbl]
+ in
+ returnSUs (Any IntKind code__2)
+
+\end{code}
+
+Simple integer coercions that don't require any code to be generated.
+Here we just change the type on the register passed on up
+
+\begin{code}
+
+coerceIntCode :: PrimKind -> [StixTree] -> SUniqSM Register
+coerceIntCode pk [x] =
+ getReg x `thenSUs` \ register ->
+ case register of
+ Fixed reg _ code -> returnSUs (Fixed reg pk code)
+ Any _ code -> returnSUs (Any pk code)
+
+coerceFltCode :: [StixTree] -> SUniqSM Register
+coerceFltCode [x] =
+ getReg x `thenSUs` \ register ->
+ case register of
+ Fixed reg _ code -> returnSUs (Fixed reg DoubleKind code)
+ Any _ code -> returnSUs (Any DoubleKind code)
+
+\end{code}
+
+Integer to character conversion. We try to do this in one step if
+the original object is in memory.
+
+\begin{code}
+chrCode :: [StixTree] -> SUniqSM Register
+{-
+chrCode [StInd pk mem] =
+ getAmode mem `thenSUs` \ amode ->
+ let
+ code = amodeCode amode
+ src = amodeAddr amode
+ code__2 dst = code . mkSeqInstr (MOVZX L (OpAddr src) (OpReg dst))
+ in
+ returnSUs (Any pk code__2)
+-}
+chrCode [x] =
+ getReg x `thenSUs` \ register ->
+ --getNewRegNCG IntKind `thenSUs` \ reg ->
+ let
+ fixedname = registerName register eax
+ code__2 dst = let
+ code = registerCode register dst
+ src = registerName register dst
+ in code .
+ if isFixed register && src /= dst
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ AND L (OpImm (ImmInt 255)) (OpReg dst)]
+ else mkSeqInstr (AND L (OpImm (ImmInt 255)) (OpReg src))
+ in
+ returnSUs (Any IntKind code__2)
+
+\end{code}
+
+More complicated integer/float conversions. Here we have to store
+temporaries in memory to move between the integer and the floating
+point register sets.
+
+\begin{code}
+coerceInt2FP :: PrimKind -> [StixTree] -> SUniqSM Register
+coerceInt2FP pk [x] =
+ getReg x `thenSUs` \ register ->
+ getNewRegNCG IntKind `thenSUs` \ reg ->
+ let
+ code = registerCode register reg
+ src = registerName register reg
+
+ code__2 dst = code . mkSeqInstrs [
+ -- to fix: should spill instead of using R1
+ MOV L (OpReg src) (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))),
+ FILD (kindToSize pk) (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
+ in
+ returnSUs (Any pk code__2)
+
+coerceFP2Int :: [StixTree] -> SUniqSM Register
+coerceFP2Int [x] =
+ getReg x `thenSUs` \ register ->
+ getNewRegNCG DoubleKind `thenSUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ pk = registerKind register
+
+ code__2 dst = let
+ in code . mkSeqInstrs [
+ FRNDINT,
+ FIST L (Addr (Just ebx) Nothing (ImmInt OFFSET_R1)),
+ MOV L (OpAddr (Addr (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
+ in
+ returnSUs (Any IntKind code__2)
+\end{code}
+
+Some random little helpers.
+
+\begin{code}
+
+maybeImm :: StixTree -> Maybe Imm
+maybeImm (StInt i)
+ | i >= toInteger minInt && i <= toInteger maxInt = Just (ImmInt (fromInteger i))
+ | otherwise = Just (ImmInteger i)
+maybeImm (StLitLbl s) = Just (ImmLit (uppBeside (uppChar '_') s))
+maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
+maybeImm (StCLbl l) = Just (ImmCLbl l)
+maybeImm _ = Nothing
+
+mangleIndexTree :: StixTree -> StixTree
+
+mangleIndexTree (StIndex pk base (StInt i)) =
+ StPrim IntAddOp [base, off]
+ where
+ off = StInt (i * size pk)
+ size :: PrimKind -> Integer
+ size pk = case kindToSize pk of
+ {B -> 1; S -> 2; L -> 4; F -> 4; D -> 8 }
+
+mangleIndexTree (StIndex pk base off) =
+ case pk of
+ CharKind -> StPrim IntAddOp [base, off]
+ _ -> StPrim IntAddOp [base, off__2]
+ where
+ off__2 = StPrim SllOp [off, StInt (shift pk)]
+ shift :: PrimKind -> Integer
+ shift DoubleKind = 3
+ shift _ = 2
+
+cvtLitLit :: String -> String
+cvtLitLit "stdin" = "_IO_stdin_"
+cvtLitLit "stdout" = "_IO_stdout_"
+cvtLitLit "stderr" = "_IO_stderr_"
+cvtLitLit s
+ | isHex s = s
+ | otherwise = error ("Native code generator can't handle ``" ++ s ++ "''")
+ where
+ isHex ('0':'x':xs) = all isHexDigit xs
+ isHex _ = False
+ -- Now, where have I seen this before?
+ isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || c >= 'a' && c <= 'f'
+
+
+\end{code}
+
+\begin{code}
+
+stackArgLoc = 23 :: Int -- where to stack call arguments
+
+\end{code}
+
+\begin{code}
+
+getNewRegNCG :: PrimKind -> SUniqSM Reg
+getNewRegNCG pk =
+ getSUnique `thenSUs` \ u ->
+ returnSUs (mkReg u pk)
+
+fixFPCond :: Cond -> Cond
+-- on the 486 the flags set by FP compare are the unsigned ones!
+fixFPCond GE = GEU
+fixFPCond GT = GU
+fixFPCond LT = LU
+fixFPCond LE = LEU
+fixFPCond any = any
+\end{code}
import Pretty(PprStyle)
import PrimKind(PrimKind)
import PrimOps(PrimOp)
-import SMRep(SMRep, SMSpecRepKind, SMUpdateKind)
+import SMRep(SMRep)
import SplitUniq(SUniqSM(..), SplitUniqSupply)
import Stix(CodeSegment, StixReg, StixTree, StixTreeList(..))
-import UniType(UniType)
import Unique(Unique)
import Unpretty(Unpretty(..))
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
-data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-}
-data CExprMacro {-# GHC_PRAGMA INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG #-}
-data CStmtMacro {-# GHC_PRAGMA ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG #-}
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
-data RegRelative {-# GHC_PRAGMA HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset #-}
-data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-}
+data AbstractC
+data CAddrMode
+data CExprMacro
+data CStmtMacro
+data MagicId
+data RegRelative
+data BasicLit
data CLabel
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
+data CSeq
+data GlobalSwitch
data RegLoc = Save StixTree | Always StixTree
-data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-}
+data SwitchResult
data HeapOffset
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
-data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-}
+data PprStyle
+data PrimKind
+data PrimOp
+data SMRep
type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
+data SplitUniqSupply
+data StixTree
type StixTreeList = [StixTree] -> [StixTree]
-data Target {-# GHC_PRAGMA Target (GlobalSwitch -> SwitchResult) Int (SMRep -> Int) (MagicId -> RegLoc) (StixTree -> StixTree) (PrimKind -> Int) ([MagicId] -> [StixTree]) ([MagicId] -> [StixTree]) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) Int Int StixTree StixTree ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) Bool ([Char] -> [Char]) #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Target = Target Int (SMRep -> Int) (MagicId -> RegLoc) (PrimKind -> Int) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) ([MagicId] -> [StixTree], [MagicId] -> [StixTree], Int, Int, StixTree, StixTree, [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree])
+data Unique
type Unpretty = CSeq
amodeToStix :: Target -> CAddrMode -> StixTree
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAAASAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: CAddrMode -> StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ua; _NO_DEFLT_ } _N_ #-}
amodeToStix' :: Target -> CAddrMode -> StixTree
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAAAASAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: CAddrMode -> StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ub; _NO_DEFLT_ } _N_ #-}
charLikeClosureSize :: Target -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAU(P)AAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uc; _NO_DEFLT_ } _N_ #-}
-codeGen :: Target -> PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 1222 _N_ _S_ "U(AAAAAAAAAAAAAAAAAASAA)" {_A_ 1 _U_ 1222 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uj; _NO_DEFLT_ } _N_ #-}
dataHS :: Target -> StixTree
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAAAASAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uf; _NO_DEFLT_ } _N_ #-}
fixedHeaderSize :: Target -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AU(P)AAAAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u2; _NO_DEFLT_ } _N_ #-}
-fmtAsmLbl :: Target -> [Char] -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAAAAAAAAAAAAAAS)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [Char] -> [Char]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ul; _NO_DEFLT_ } _N_ #-}
heapCheck :: Target -> StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 1 _U_ 122222 _N_ _S_ "U(AAAAAAAAAAAAAAAAASAAA)" {_A_ 1 _U_ 122222 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ui; _NO_DEFLT_ } _N_ #-}
hpRel :: Target -> HeapOffset -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAASAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: HeapOffset -> Int) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u9; _NO_DEFLT_ } _N_ #-}
intLikeClosureSize :: Target -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAAU(P)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ud; _NO_DEFLT_ } _N_ #-}
macroCode :: Target -> CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 1 _U_ 12222 _N_ _S_ "U(AAAAAAAAAAAAAAAASAAAA)" {_A_ 1 _U_ 12222 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uh; _NO_DEFLT_ } _N_ #-}
-mkTarget :: (GlobalSwitch -> SwitchResult) -> Int -> (SMRep -> Int) -> (MagicId -> RegLoc) -> (StixTree -> StixTree) -> (PrimKind -> Int) -> ([MagicId] -> [StixTree]) -> ([MagicId] -> [StixTree]) -> (HeapOffset -> Int) -> (CAddrMode -> StixTree) -> (CAddrMode -> StixTree) -> Int -> Int -> StixTree -> StixTree -> ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) -> Bool -> ([Char] -> [Char]) -> Target
- {-# GHC_PRAGMA _A_ 21 _U_ 222222222222222222222 _N_ _N_ _F_ _IF_ARGS_ 0 21 XXXXXXXXXXXXXXXXXXXXX 22 \ (u0 :: GlobalSwitch -> SwitchResult) (u1 :: Int) (u2 :: SMRep -> Int) (u3 :: MagicId -> RegLoc) (u4 :: StixTree -> StixTree) (u5 :: PrimKind -> Int) (u6 :: [MagicId] -> [StixTree]) (u7 :: [MagicId] -> [StixTree]) (u8 :: HeapOffset -> Int) (u9 :: CAddrMode -> StixTree) (ua :: CAddrMode -> StixTree) (ub :: Int) (uc :: Int) (ud :: StixTree) (ue :: StixTree) (uf :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ug :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uj :: Bool) (uk :: [Char] -> [Char]) -> _!_ _ORIG_ MachDesc Target [] [u0, u1, u2, u3, u4, u5, u6, u7, u8, u9, ua, ub, uc, ud, ue, uf, ug, uh, ui, uj, uk] _N_ #-}
+mkTarget :: Int -> (SMRep -> Int) -> (MagicId -> RegLoc) -> (PrimKind -> Int) -> (HeapOffset -> Int) -> (CAddrMode -> StixTree) -> (CAddrMode -> StixTree) -> ([MagicId] -> [StixTree], [MagicId] -> [StixTree], Int, Int, StixTree, StixTree, [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree], StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> Target
mutHS :: Target -> StixTree
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAAASAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ue; _NO_DEFLT_ } _N_ #-}
-nativeOpt :: Target -> StixTree -> StixTree
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAASAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: StixTree -> StixTree) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u5; _NO_DEFLT_ } _N_ #-}
primToStix :: Target -> [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 1 _U_ 122222 _N_ _S_ "U(AAAAAAAAAAAAAAASAAAAA)" {_A_ 1 _U_ 122222 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> ug; _NO_DEFLT_ } _N_ #-}
saveLoc :: Target -> MagicId -> StixTree
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAASAAAAAAAAAAAAAAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
sizeof :: Target -> PrimKind -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAASAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: PrimKind -> Int) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u6; _NO_DEFLT_ } _N_ #-}
stgReg :: Target -> MagicId -> RegLoc
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAASAAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: MagicId -> RegLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u4; _NO_DEFLT_ } _N_ #-}
-targetSwitches :: Target -> GlobalSwitch -> SwitchResult
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(SAAAAAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: GlobalSwitch -> SwitchResult) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u1; _NO_DEFLT_ } _N_ #-}
-underscore :: Target -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAAAAAAAAAAAAAEA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Bool) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> uk; _NO_DEFLT_ } _N_ #-}
varHeaderSize :: Target -> SMRep -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AASAAAAAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SMRep -> Int) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u3; _NO_DEFLT_ } _N_ #-}
volatileRestores :: Target -> [MagicId] -> [StixTree]
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAASAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [MagicId] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u8; _NO_DEFLT_ } _N_ #-}
volatileSaves :: Target -> [MagicId] -> [StixTree]
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAASAAAAAAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [MagicId] -> [StixTree]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Target) -> case u0 of { _ALG_ _ORIG_ MachDesc Target (u1 :: GlobalSwitch -> SwitchResult) (u2 :: Int) (u3 :: SMRep -> Int) (u4 :: MagicId -> RegLoc) (u5 :: StixTree -> StixTree) (u6 :: PrimKind -> Int) (u7 :: [MagicId] -> [StixTree]) (u8 :: [MagicId] -> [StixTree]) (u9 :: HeapOffset -> Int) (ua :: CAddrMode -> StixTree) (ub :: CAddrMode -> StixTree) (uc :: Int) (ud :: Int) (ue :: StixTree) (uf :: StixTree) (ug :: [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uh :: CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (ui :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (uj :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) (uk :: Bool) (ul :: [Char] -> [Char]) -> u7; _NO_DEFLT_ } _N_ #-}
#include "HsVersions.h"
module MachDesc (
- Target, mkTarget, RegLoc(..),
+ Target(..){-(..) for target_STRICT only-}, mkTarget, RegLoc(..),
saveLoc,
- targetSwitches, fixedHeaderSize, varHeaderSize, stgReg,
- nativeOpt, sizeof, volatileSaves, volatileRestores, hpRel,
+-- targetSwitches, UNUSED FOR NOW
+ fixedHeaderSize, varHeaderSize, stgReg,
+-- nativeOpt, UNUSED FOR NOW
+ sizeof, volatileSaves, volatileRestores, hpRel,
amodeToStix, amodeToStix', charLikeClosureSize,
intLikeClosureSize, mutHS, dataHS, primToStix, macroCode,
- heapCheck, codeGen, underscore, fmtAsmLbl,
+ heapCheck,
+-- codeGen, underscore, fmtAsmLbl, UNUSED FOR NOW (done a diff way)
-- and, for self-sufficiency...
AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId,
\begin{code}
data Target = Target
- (GlobalSwitch -> SwitchResult) -- switches
+-- (GlobalSwitch -> SwitchResult) -- switches
Int -- fixedHeaderSize
(SMRep -> Int) -- varHeaderSize
(MagicId -> RegLoc) -- stgReg
- (StixTree -> StixTree) -- nativeOpt
+-- (StixTree -> StixTree) -- nativeOpt
(PrimKind -> Int) -- sizeof
- ([MagicId] -> [StixTree]) -- volatileSaves
- ([MagicId] -> [StixTree]) -- volatileRestores
(HeapOffset -> Int) -- hpRel
(CAddrMode -> StixTree) -- amodeToStix
(CAddrMode -> StixTree) -- amodeToStix'
- Int -- charLikeClosureSize
- Int -- intLikeClosureSize
- StixTree -- mutHS
- StixTree -- dataHS
- ([CAddrMode] -> PrimOp -> [CAddrMode] -> SUniqSM StixTreeList)
+ (
+ ([MagicId] -> [StixTree]), -- volatileSaves
+ ([MagicId] -> [StixTree]), -- volatileRestores
+ Int, -- charLikeClosureSize
+ Int, -- intLikeClosureSize
+ StixTree, -- mutHS
+ StixTree, -- dataHS
+ ([CAddrMode] -> PrimOp -> [CAddrMode] -> SUniqSM StixTreeList),
-- primToStix
- (CStmtMacro -> [CAddrMode] -> SUniqSM StixTreeList)
+ (CStmtMacro -> [CAddrMode] -> SUniqSM StixTreeList),
-- macroCode
(StixTree -> StixTree -> StixTree -> SUniqSM StixTreeList)
-- heapCheck
-
+ )
+{- UNUSED: done a diff way:
(PprStyle -> [[StixTree]] -> SUniqSM Unpretty)
-- codeGen
Bool -- underscore
(String -> String) -- fmtAsmLbl
+-}
mkTarget = Target
-targetSwitches (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = sw
-fixedHeaderSize (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = fhs
-varHeaderSize (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = vhs
-stgReg (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = reg
-nativeOpt (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = opt
-sizeof (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = size
-volatileSaves (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = vsave
-volatileRestores (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = vrest
-hpRel (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = hprel
-amodeToStix (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = am
-amodeToStix' (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = am'
-charLikeClosureSize (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = csz
-intLikeClosureSize (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = isz
-mutHS (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = mhs
-dataHS (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = dhs
-primToStix (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = ps
-macroCode (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = mc
-heapCheck (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = hc
-codeGen (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = cg
-underscore (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = us
-fmtAsmLbl (Target sw fhs vhs reg opt size vsave vrest hprel am am' csz isz mhs dhs ps mc hc cg us fmt) = fmt
+{- UNUSED FOR NOW:
+targetSwitches (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = {-sw-} x
+-}
+fixedHeaderSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = fhs
+varHeaderSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = vhs x
+stgReg (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = reg x
+{- UNUSED FOR NOW:
+nativeOpt (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = {-opt-} x
+-}
+sizeof (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = size x
+-- used only for wrapper-hungry PrimOps:
+hpRel (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = hprel x
+amodeToStix (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = am x
+amodeToStix' (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' ~(vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = am' x
+
+volatileSaves (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = vsave x
+-- used only for wrapper-hungry PrimOps:
+volatileRestores (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = vrest x
+charLikeClosureSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = csz
+intLikeClosureSize (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = isz
+mutHS (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = mhs
+dataHS (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = dhs
+primToStix (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y z = ps x y z
+macroCode (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y = mc x y
+heapCheck (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y z = hc x y z
+{- UNUSED: done a diff way:
+codeGen (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x y = cg x y
+underscore (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) = us
+fmtAsmLbl (Target {-sw-} fhs vhs reg {-opt-} size hprel am am' (vsave, vrest, csz, isz, mhs, dhs, ps, mc, hc) {-cg us fmt-}) x = fmt x
+-}
\end{code}
Trees for register save locations
import UniqSet(UniqSet(..))
import Unique(Unique)
data Addr = AddrRegReg Reg Reg | AddrRegImm Reg Imm
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
-data Reg {-# GHC_PRAGMA FixedReg Int# | MappedReg Int# | MemoryReg Int PrimKind | UnmappedReg Unique PrimKind #-}
-data BitSet {-# GHC_PRAGMA MkBS Word# #-}
+data MagicId
+data Reg
+data BitSet
data CLabel
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
-data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data CodeSegment {-# GHC_PRAGMA DataSegment | TextSegment #-}
+data CSeq
+data FiniteMap a b
+data OrdList a
+data PrimKind
+data CodeSegment
data Cond = ALWAYS | NEVER | GEU | LU | EQ | GT | GE | GU | LT | LE | LEU | NE | NEG | POS | VC | VS
data Imm = ImmInt Int | ImmInteger Integer | ImmCLbl CLabel | ImmLab CSeq | ImmLit CSeq | LO Imm | HI Imm
data RI = RIReg Reg | RIImm Imm
data Size = SB | HW | UB | UHW | W | D | F | DF
type SparcCode = OrdList SparcInstr
data SparcInstr = LD Size Addr Reg | ST Size Reg Addr | ADD Bool Bool Reg RI Reg | SUB Bool Bool Reg RI Reg | AND Bool Reg RI Reg | ANDN Bool Reg RI Reg | OR Bool Reg RI Reg | ORN Bool Reg RI Reg | XOR Bool Reg RI Reg | XNOR Bool Reg RI Reg | SLL Reg RI Reg | SRL Reg RI Reg | SRA Reg RI Reg | SETHI Imm Reg | NOP | FABS Size Reg Reg | FADD Size Reg Reg Reg | FCMP Bool Size Reg Reg | FDIV Size Reg Reg Reg | FMOV Size Reg Reg | FMUL Size Reg Reg Reg | FNEG Size Reg Reg | FSQRT Size Reg Reg | FSUB Size Reg Reg Reg | FxTOy Size Size Reg Reg | BI Cond Bool Imm | BF Cond Bool Imm | JMP Addr | CALL Imm Int Bool | LABEL CLabel | COMMENT _PackedString | SEGMENT CodeSegment | ASCII Bool [Char] | DATA Size [Imm]
-data SparcRegs {-# GHC_PRAGMA SRegs BitSet BitSet BitSet #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data SparcRegs
+data UniqFM a
type UniqSet a = UniqFM a
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Unique
argRegs :: [Reg]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
baseRegOffset :: MagicId -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
callerSaves :: MagicId -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
f0 :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
fp :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [30#] _N_ #-}
freeRegs :: [Reg]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
g0 :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [0#] _N_ #-}
is13Bits :: Integral a => a -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(LU(U(ALASAAAA)AAA)AAAAAAAAAA)" {_A_ 3 _U_ 1112 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Integer ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(PPP)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
kindToSize :: PrimKind -> Size
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-}
o0 :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
offset :: Addr -> Int -> Labda Addr
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
printLabeledCodes :: PprStyle -> [SparcInstr] -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
reservedRegs :: [Int]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
sp :: Reg
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ AsmRegAlloc FixedReg [] [14#] _N_ #-}
stgRegMap :: MagicId -> Labda Reg
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
strImmLit :: [Char] -> Imm
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance MachineCode SparcInstr
- {-# GHC_PRAGMA _M_ SparcCode {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 6 _!_ _TUP_5 [(SparcInstr -> RegUsage), (SparcInstr -> RegLiveness -> RegLiveness), (SparcInstr -> (Reg -> Reg) -> SparcInstr), (Reg -> Reg -> OrdList SparcInstr), (Reg -> Reg -> OrdList SparcInstr)] [_CONSTM_ MachineCode regUsage (SparcInstr), _CONSTM_ MachineCode regLiveness (SparcInstr), _CONSTM_ MachineCode patchRegs (SparcInstr), _CONSTM_ MachineCode spillReg (SparcInstr), _CONSTM_ MachineCode loadReg (SparcInstr)] _N_
- regUsage = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
- regLiveness = _A_ 2 _U_ 11 _N_ _S_ "SU(LU(LL))" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_,
- patchRegs = _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_,
- spillReg = _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_,
- loadReg = _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
instance MachineRegisters SparcRegs
- {-# GHC_PRAGMA _M_ SparcCode {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 7 _!_ _TUP_6 [([Int] -> SparcRegs), (PrimKind -> SparcRegs -> [Int]), (SparcRegs -> Int# -> SparcRegs), (SparcRegs -> [Int] -> SparcRegs), (SparcRegs -> Int# -> SparcRegs), (SparcRegs -> [Int] -> SparcRegs)] [_CONSTM_ MachineRegisters mkMRegs (SparcRegs), _CONSTM_ MachineRegisters possibleMRegs (SparcRegs), _CONSTM_ MachineRegisters useMReg (SparcRegs), _CONSTM_ MachineRegisters useMRegs (SparcRegs), _CONSTM_ MachineRegisters freeMReg (SparcRegs), _CONSTM_ MachineRegisters freeMRegs (SparcRegs)] _N_
- mkMRegs = _A_ 1 _U_ 1 _N_ _N_ _N_ _N_,
- possibleMRegs = _A_ 2 _U_ 11 _N_ _S_ "EU(LLL)" {_A_ 4 _U_ 1111 _N_ _N_ _N_ _N_} _N_ _N_,
- useMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LLL)P" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_,
- useMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LLL)L" {_A_ 4 _U_ 1111 _N_ _N_ _N_ _N_} _N_ _N_,
- freeMReg = _A_ 2 _U_ 12 _N_ _S_ "U(LLL)P" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_,
- freeMRegs = _A_ 2 _U_ 11 _N_ _S_ "U(LLL)L" {_A_ 4 _U_ 1111 _N_ _N_ _N_ _N_} _N_ _N_ #-}
pprAddr sty (AddrRegImm r1 (ImmInt i))
| i == 0 = pprReg r1
+ | i < -4096 || i > 4095 = large_offset_error i
| i < 0 =
uppBesides [
pprReg r1,
pprAddr sty (AddrRegImm r1 (ImmInteger i))
| i == 0 = pprReg r1
+ | i < -4096 || i > 4095 = large_offset_error i
| i < 0 =
uppBesides [
pprReg r1,
pprImm sty imm
]
+large_offset_error i
+ = error ("ERROR: SPARC native-code generator cannot handle large offset ("++show i++");\nprobably because of large constant data structures;\nworkaround: use -fvia-C on this module.\n")
+
pprRI :: PprStyle -> RI -> Unpretty
pprRI sty (RIReg r) = pprReg r
pprRI sty (RIImm r) = pprImm sty r
baseRegOffset Hp = OFFSET_Hp
baseRegOffset HpLim = OFFSET_HpLim
baseRegOffset LivenessReg = OFFSET_Liveness
-baseRegOffset ActivityReg = OFFSET_Activity
+--baseRegOffset ActivityReg = OFFSET_Activity
#ifdef DEBUG
baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
baseRegOffset StdUpdRetVecReg = panic "baseRegOffset:StgUpdRetVecReg"
callerSaves LivenessReg = True
#endif
#ifdef CALLER_SAVES_Activity
-callerSaves ActivityReg = True
+--callerSaves ActivityReg = True
#endif
#ifdef CALLER_SAVES_StdUpdRetVec
callerSaves StdUpdRetVecReg = True
stgRegMap LivenessReg = Just (FixedReg ILIT(REG_Liveness))
#endif
#ifdef REG_Activity
-stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity))
+--stgRegMap ActivityReg = Just (FixedReg ILIT(REG_Activity))
#endif
#ifdef REG_StdUpdRetVec
stgRegMap StdUpdRetVecReg = Just (FixedReg ILIT(REG_StdUpdRetVec))
freeReg ILIT(REG_Liveness) = _FALSE_
#endif
#ifdef REG_Activity
-freeReg ILIT(REG_Activity) = _FALSE_
+--freeReg ILIT(REG_Activity) = _FALSE_
#endif
#ifdef REG_StdUpdRetVec
freeReg ILIT(REG_StdUpdRetVec) = _FALSE_
import PrimKind(PrimKind)
import PrimOps(PrimOp)
import SMRep(SMRep, SMSpecRepKind, SMUpdateKind)
+import SplitUniq(SplitUniqSupply)
import Stix(CodeSegment, StixReg, StixTree)
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
-data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-}
-data RegLoc {-# GHC_PRAGMA Save StixTree | Always StixTree #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-}
-data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
-mkSparc :: Bool -> (GlobalSwitch -> SwitchResult) -> Target
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
+data MagicId
+data SwitchResult
+data RegLoc
+data PprStyle
+data PrimKind
+data SMRep
+data StixTree
+mkSparc :: Bool -> (GlobalSwitch -> SwitchResult) -> (Target, PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq, Bool, [Char] -> [Char])
\begin{code}
vsaves switches vols =
- map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,ActivityReg] ++ vols))
+ map save ((filter callerSaves) ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-}] ++ vols))
where
save x = StAssign (kindFromMagicId x) loc reg
where reg = StReg (StixMagicId x)
vrests switches vols =
map restore ((filter callerSaves)
- ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg,ActivityReg,StkStubReg,StdUpdRetVecReg] ++ vols))
+ ([BaseReg,SpA,SuA,SpB,SuB,Hp,HpLim,RetReg{-,ActivityReg-},StkStubReg,StdUpdRetVecReg] ++ vols))
where
restore x = StAssign (kindFromMagicId x) reg loc
where reg = StReg (StixMagicId x)
\begin{code}
-mkSparc :: Bool -> (GlobalSwitch -> SwitchResult) -> Target
+mkSparc :: Bool
+ -> (GlobalSwitch -> SwitchResult)
+ -> (Target,
+ (PprStyle -> [[StixTree]] -> SUniqSM Unpretty), -- codeGen
+ Bool, -- underscore
+ (String -> String)) -- fmtAsmLbl
mkSparc decentOS switches =
- let fhs' = fhs switches
+ let
+ fhs' = fhs switches
vhs' = vhs switches
sparcReg' = sparcReg switches
vsaves' = vsaves switches
dhs' = dhs switches
ps = genPrimCode target
mc = genMacroCode target
- hc = doHeapCheck target
- target = mkTarget switches fhs' vhs' sparcReg' id size vsaves' vrests'
- hprel as as' csz isz mhs' dhs' ps mc hc
- sparcCodeGen decentOS id
- in target
-
+ hc = doHeapCheck --UNUSED NOW: target
+ target = mkTarget {-switches-} fhs' vhs' sparcReg' {-id-} size
+ hprel as as'
+ (vsaves', vrests', csz, isz, mhs', dhs', ps, mc, hc)
+ {-sparcCodeGen decentOS id-}
+ in
+ (target, sparcCodeGen, decentOS, id)
\end{code}
-
-
-
import PrimOps(PrimOp)
import SplitUniq(SplitUniqSupply)
import Stix(CodeSegment, StixReg, StixTree)
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
-data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
+data CSeq
+data PprStyle
+data StixTree
sparcCodeGen :: PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 211 _N_ _S_ "LS" _N_ _N_ #-}
IntSubOp -> trivialCode (SUB False False) args
IntMulOp -> call SLIT(".umul") IntKind
IntQuotOp -> call SLIT(".div") IntKind
- IntDivOp -> call SLIT("stg_div") IntKind
IntRemOp -> call SLIT(".rem") IntKind
IntNegOp -> trivialUCode (SUB False False g0) args
IntAbsOp -> absIntCode args
import SplitUniq(SUniqSM(..), SplitUniqSupply)
import UniType(UniType)
import Unique(Unique)
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
+data MagicId
data CLabel
data CodeSegment = DataSegment | TextSegment
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
+data PrimKind
+data PrimOp
type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
+data SplitUniqSupply
data StixReg = StixMagicId MagicId | StixTemp Unique PrimKind
data StixTree = StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString
type StixTreeList = [StixTree] -> [StixTree]
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Unique
getUniqLabelNCG :: SplitUniqSupply -> CLabel
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ALA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
sStLitLbl :: _PackedString -> StixTree
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
-stgActivityReg :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgBaseReg :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgHp :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgHpLim :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgLivenessReg :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgNode :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgRetReg :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgSpA :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgSpB :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgStdUpdRetVecReg :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgStkOReg :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgStkStubReg :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgSuA :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgSuB :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgTagReg :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
instance Eq CodeSegment
- {-# GHC_PRAGMA _M_ Stix {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(CodeSegment -> CodeSegment -> Bool), (CodeSegment -> CodeSegment -> Bool)] [_CONSTM_ Eq (==) (CodeSegment), _CONSTM_ Eq (/=) (CodeSegment)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg,
stgSpA, stgSuA, stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg,
- stgActivityReg, stgStdUpdRetVecReg, stgStkStubReg,
+-- stgActivityReg,
+ stgStdUpdRetVecReg, stgStkStubReg,
getUniqLabelNCG,
-- And for self-sufficiency, by golly...
\begin{code}
stgBaseReg, stgStkOReg, stgNode, stgTagReg, stgRetReg, stgSpA, stgSuA,
- stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg, stgActivityReg, stgStdUpdRetVecReg,
+ stgSpB, stgSuB, stgHp, stgHpLim, stgLivenessReg{-, stgActivityReg-}, stgStdUpdRetVecReg,
stgStkStubReg :: StixTree
stgBaseReg = StReg (StixMagicId BaseReg)
stgHp = StReg (StixMagicId Hp)
stgHpLim = StReg (StixMagicId HpLim)
stgLivenessReg = StReg (StixMagicId LivenessReg)
-stgActivityReg = StReg (StixMagicId ActivityReg)
+--stgActivityReg = StReg (StixMagicId ActivityReg)
stgStdUpdRetVecReg = StReg (StixMagicId StdUpdRetVecReg)
stgStkStubReg = StReg (StixMagicId StkStubReg)
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface StixInfo where
-import AbsCSyn(AbstractC)
-import MachDesc(Target)
+import AbsCSyn(AbstractC, CAddrMode)
+import HeapOffs(HeapOffset)
import SplitUniq(SplitUniqSupply)
import Stix(StixTree)
-genCodeInfoTable :: Target -> AbstractC -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
+genCodeInfoTable :: (HeapOffset -> Int) -> (CAddrMode -> StixTree) -> AbstractC -> SplitUniqSupply -> [StixTree] -> [StixTree]
dyn___rtbl = sStLitLbl SLIT("Dyn___rtbl")
genCodeInfoTable
- :: Target
+ :: {-Target-}
+ (HeapOffset -> Int) -- needed bit of Target
+ -> (CAddrMode -> StixTree) -- ditto
-> AbstractC
-> SUniqSM StixTreeList
-genCodeInfoTable target (CClosureInfoAndCode cl_info _ _ upd cl_descr) =
+genCodeInfoTable hp_rel amode2stix (CClosureInfoAndCode cl_info _ _ upd cl_descr _) =
returnSUs (\xs -> info : lbl : xs)
where
size = if isSpecRep sm_rep
then closureNonHdrSize cl_info
- else hpRel target (closureSizeWithoutFixedHdr cl_info)
+ else hp_rel (closureSizeWithoutFixedHdr cl_info)
ptrs = closurePtrsSize cl_info
- upd_code = amodeToStix target upd
+ upd_code = amode2stix upd
info_unused = StInt (-1)
import PrimKind(PrimKind)
import SplitUniq(SplitUniqSupply)
import Stix(StixTree)
-decodeFloatingKind :: PrimKind -> Target -> [CAddrMode] -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 4 _U_ 121102 _N_ _N_ _N_ _N_ #-}
-encodeFloatingKind :: PrimKind -> Target -> [CAddrMode] -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 4 _U_ 121122 _N_ _S_ "LLSL" _N_ _N_ #-}
-gmpCompare :: Target -> CAddrMode -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 3 _U_ 22102 _N_ _N_ _N_ _N_ #-}
-gmpInt2Integer :: Target -> [CAddrMode] -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 3 _U_ 21122 _N_ _S_ "LLS" _N_ _N_ #-}
-gmpInteger2Int :: Target -> CAddrMode -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 3 _U_ 22102 _N_ _N_ _N_ _N_ #-}
-gmpString2Integer :: Target -> [CAddrMode] -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 3 _U_ 21122 _N_ _S_ "U(ALLLAAAAALAAAALASAAAA)LS" _N_ _N_ #-}
-gmpTake1Return1 :: Target -> [CAddrMode] -> _PackedString -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 4 _U_ 212122 _N_ _S_ "U(AAALAAAAALAAAALAASAAA)LLL" _N_ _N_ #-}
-gmpTake2Return1 :: Target -> [CAddrMode] -> _PackedString -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 4 _U_ 212122 _N_ _S_ "U(AAALAAAAALAAAALAASAAA)LLL" _N_ _N_ #-}
-gmpTake2Return2 :: Target -> [CAddrMode] -> _PackedString -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 4 _U_ 212122 _N_ _S_ "U(AAALAAAAALAAAALAASAAA)LLL" _N_ _N_ #-}
+decodeFloatingKind :: PrimKind -> Target -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> (CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
+encodeFloatingKind :: PrimKind -> Target -> CAddrMode -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
+gmpCompare :: Target -> CAddrMode -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
+gmpInt2Integer :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> (CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
+gmpInteger2Int :: Target -> CAddrMode -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
+gmpString2Integer :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> (CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
+gmpTake1Return1 :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> _PackedString -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
+gmpTake2Return1 :: Target -> (CAddrMode, CAddrMode, CAddrMode) -> _PackedString -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
+gmpTake2Return2 :: Target -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> _PackedString -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode, CAddrMode) -> SplitUniqSupply -> [StixTree] -> [StixTree]
gmpTake1Return1
:: Target
- -> [CAddrMode] -- result (3 parts)
- -> FAST_STRING -- function name
- -> [CAddrMode] -- argument (3 parts)
+ -> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
+ -> FAST_STRING -- function name
+ -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode)
+ -- argument (4 parts)
-> SUniqSM StixTreeList
argument1 = mpStruct 1 -- out here to avoid CAF (sigh)
init3 = StCall SLIT("mpz_init") VoidKind [result3]
init4 = StCall SLIT("mpz_init") VoidKind [result4]
-gmpTake1Return1 target res rtn arg =
- let [ar,sr,dr] = map (amodeToStix target) res
- [liveness, aa,sa,da] = map (amodeToStix target) arg
- space = mpSpace target 2 1 [sa]
+-- hacking with Uncle Will:
+#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
+
+gmpTake1Return1 target_STRICT res@(car,csr,cdr) rtn arg@(clive,caa,csa,cda) =
+ let
+ a2stix = amodeToStix target
+ data_hs = dataHS target
+
+ ar = a2stix car
+ sr = a2stix csr
+ dr = a2stix cdr
+ liveness= a2stix clive
+ aa = a2stix caa
+ sa = a2stix csa
+ da = a2stix cda
+
+ space = mpSpace data_hs 2 1 [sa]
oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
safeHp = saveLoc target Hp
save = StAssign PtrKind safeHp oldHp
- (a1,a2,a3) = toStruct target argument1 (aa,sa,da)
+ (a1,a2,a3) = toStruct data_hs argument1 (aa,sa,da)
mpz_op = StCall rtn VoidKind [result2, argument1]
restore = StAssign PtrKind stgHp safeHp
- (r1,r2,r3) = fromStruct target result2 (ar,sr,dr)
+ (r1,r2,r3) = fromStruct data_hs result2 (ar,sr,dr)
in
- heapCheck target liveness space (StInt 0)
- `thenSUs` \ heap_chk ->
+ heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
returnSUs (heap_chk .
(\xs -> a1 : a2 : a3 : save : init2 : mpz_op : r1 : r2 : r3 : restore : xs))
gmpTake2Return1
:: Target
- -> [CAddrMode] -- result (3 parts)
- -> FAST_STRING -- function name
- -> [CAddrMode] -- arguments (3 parts each)
+ -> (CAddrMode,CAddrMode,CAddrMode) -- result (3 parts)
+ -> FAST_STRING -- function name
+ -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+ -- liveness + 2 arguments (3 parts each)
-> SUniqSM StixTreeList
-gmpTake2Return1 target res rtn args =
- let [ar,sr,dr] = map (amodeToStix target) res
- [liveness, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args
- space = mpSpace target 3 1 [sa1, sa2]
+gmpTake2Return1 target_STRICT res@(car,csr,cdr) rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
+ let
+ a2stix = amodeToStix target
+ data_hs = dataHS target
+
+ ar = a2stix car
+ sr = a2stix csr
+ dr = a2stix cdr
+ liveness= a2stix clive
+ aa1 = a2stix caa1
+ sa1 = a2stix csa1
+ da1 = a2stix cda1
+ aa2 = a2stix caa2
+ sa2 = a2stix csa2
+ da2 = a2stix cda2
+
+ space = mpSpace data_hs 3 1 [sa1, sa2]
oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
safeHp = saveLoc target Hp
save = StAssign PtrKind safeHp oldHp
- (a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1)
- (a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2)
+ (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
+ (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
mpz_op = StCall rtn VoidKind [result3, argument1, argument2]
restore = StAssign PtrKind stgHp safeHp
- (r1,r2,r3) = fromStruct target result3 (ar,sr,dr)
+ (r1,r2,r3) = fromStruct data_hs result3 (ar,sr,dr)
in
- heapCheck target liveness space (StInt 0)
- `thenSUs` \ heap_chk ->
+ heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
returnSUs (heap_chk .
(\xs -> a1 : a2 : a3 : a4 : a5 : a6
gmpTake2Return2
:: Target
- -> [CAddrMode] -- results (3 parts each)
+ -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+ -- 2 results (3 parts each)
-> FAST_STRING -- function name
- -> [CAddrMode] -- arguments (3 parts each)
+ -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+ -- liveness + 2 arguments (3 parts each)
-> SUniqSM StixTreeList
-gmpTake2Return2 target res rtn args =
- let [ar1,sr1,dr1, ar2,sr2,dr2] = map (amodeToStix target) res
- [liveness, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args
- space = StPrim IntMulOp [mpSpace target 2 1 [sa1, sa2], StInt 2]
+gmpTake2Return2 target_STRICT res@(car1,csr1,cdr1, car2,csr2,cdr2)
+ rtn args@(clive, caa1,csa1,cda1, caa2,csa2,cda2) =
+ let
+ a2stix = amodeToStix target
+ data_hs = dataHS target
+
+ ar1 = a2stix car1
+ sr1 = a2stix csr1
+ dr1 = a2stix cdr1
+ ar2 = a2stix car2
+ sr2 = a2stix csr2
+ dr2 = a2stix cdr2
+ liveness= a2stix clive
+ aa1 = a2stix caa1
+ sa1 = a2stix csa1
+ da1 = a2stix cda1
+ aa2 = a2stix caa2
+ sa2 = a2stix csa2
+ da2 = a2stix cda2
+
+ space = StPrim IntMulOp [mpSpace data_hs 2 1 [sa1, sa2], StInt 2]
oldHp = StIndex PtrKind stgHp (StPrim IntNegOp [space])
safeHp = saveLoc target Hp
save = StAssign PtrKind safeHp oldHp
- (a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1)
- (a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2)
+ (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
+ (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
mpz_op = StCall rtn VoidKind [result3, result4, argument1, argument2]
restore = StAssign PtrKind stgHp safeHp
- (r1,r2,r3) = fromStruct target result3 (ar1,sr1,dr1)
- (r4,r5,r6) = fromStruct target result4 (ar2,sr2,dr2)
+ (r1,r2,r3) = fromStruct data_hs result3 (ar1,sr1,dr1)
+ (r4,r5,r6) = fromStruct data_hs result4 (ar2,sr2,dr2)
in
- heapCheck target liveness space (StInt 0)
- `thenSUs` \ heap_chk ->
+ heapCheck target liveness space (StInt 0) `thenSUs` \ heap_chk ->
returnSUs (heap_chk .
(\xs -> a1 : a2 : a3 : a4 : a5 : a6
\end{code}
-Although gmpCompare doesn't allocate space, it does temporarily use some
-space just beyond the heap pointer. This is safe, because the enclosing
-routine has already guaranteed that this space will be available.
-(See ``primOpHeapRequired.'')
+Although gmpCompare doesn't allocate space, it does temporarily use
+some space just beyond the heap pointer. This is safe, because the
+enclosing routine has already guaranteed that this space will be
+available. (See ``primOpHeapRequired.'')
\begin{code}
gmpCompare
:: Target
-> CAddrMode -- result (boolean)
- -> [CAddrMode] -- arguments (3 parts each)
+ -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+ -- alloc hp + 2 arguments (3 parts each)
-> SUniqSM StixTreeList
-gmpCompare target res args =
- let result = amodeToStix target res
- [hp, aa1,sa1,da1, aa2,sa2,da2] = map (amodeToStix target) args
+gmpCompare target_STRICT res args@(chp, caa1,csa1,cda1, caa2,csa2,cda2) =
+ let
+ a2stix = amodeToStix target
+ data_hs = dataHS target
+
+ result = a2stix res
+ hp = a2stix chp
+ aa1 = a2stix caa1
+ sa1 = a2stix csa1
+ da1 = a2stix cda1
+ aa2 = a2stix caa2
+ sa2 = a2stix csa2
+ da2 = a2stix cda2
+
argument1 = hp
argument2 = StIndex IntKind hp (StInt (toInteger mpIntSize))
- (a1,a2,a3) = toStruct target argument1 (aa1,sa1,da1)
- (a4,a5,a6) = toStruct target argument2 (aa2,sa2,da2)
+ (a1,a2,a3) = toStruct data_hs argument1 (aa1,sa1,da1)
+ (a4,a5,a6) = toStruct data_hs argument2 (aa2,sa2,da2)
mpz_cmp = StCall SLIT("mpz_cmp") IntKind [argument1, argument2]
r1 = StAssign IntKind result mpz_cmp
in
gmpInteger2Int
:: Target
-> CAddrMode -- result
- -> [CAddrMode] -- argument (3 parts)
+ -> (CAddrMode, CAddrMode,CAddrMode,CAddrMode) -- alloc hp + argument (3 parts)
-> SUniqSM StixTreeList
-gmpInteger2Int target res args =
- let result = amodeToStix target res
- [hp, aa,sa,da] = map (amodeToStix target) args
- (a1,a2,a3) = toStruct target hp (aa,sa,da)
+gmpInteger2Int target_STRICT res args@(chp, caa,csa,cda) =
+ let
+ a2stix = amodeToStix target
+ data_hs = dataHS target
+
+ result = a2stix res
+ hp = a2stix chp
+ aa = a2stix caa
+ sa = a2stix csa
+ da = a2stix cda
+
+ (a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
mpz_get_si = StCall SLIT("mpz_get_si") IntKind [hp]
r1 = StAssign IntKind result mpz_get_si
in
gmpInt2Integer
:: Target
- -> [CAddrMode] -- result (3 parts)
- -> [CAddrMode] -- allocated heap, int to convert
+ -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
+ -> (CAddrMode, CAddrMode) -- allocated heap, Int to convert
-> SUniqSM StixTreeList
-gmpInt2Integer target res args@[_, n] =
- getUniqLabelNCG `thenSUs` \ zlbl ->
- getUniqLabelNCG `thenSUs` \ nlbl ->
- getUniqLabelNCG `thenSUs` \ jlbl ->
- let [ar,sr,dr] = map (amodeToStix target) res
- [hp, i] = map (amodeToStix target) args
+gmpInt2Integer target_STRICT res@(car,csr,cdr) args@(chp, n) =
+ getUniqLabelNCG `thenSUs` \ zlbl ->
+ getUniqLabelNCG `thenSUs` \ nlbl ->
+ getUniqLabelNCG `thenSUs` \ jlbl ->
+ let
+ a2stix = amodeToStix target
+
+ ar = a2stix car
+ sr = a2stix csr
+ dr = a2stix cdr
+ hp = a2stix chp
+ i = a2stix n
+
h1 = StAssign PtrKind (StInd PtrKind hp) arrayOfData_info
size = varHeaderSize target (DataRep 0) + mIN_MP_INT_SIZE
h2 = StAssign IntKind (StInd IntKind (StIndex IntKind hp (StInt 1)))
gmpString2Integer
:: Target
- -> [CAddrMode] -- result (3 parts)
- -> [CAddrMode] -- liveness, string
+ -> (CAddrMode, CAddrMode, CAddrMode) -- result (3 parts)
+ -> (CAddrMode, CAddrMode) -- liveness, string
-> SUniqSM StixTreeList
-gmpString2Integer target res [liveness, str] =
+gmpString2Integer target_STRICT res@(car,csr,cdr) (liveness, str) =
getUniqLabelNCG `thenSUs` \ ulbl ->
- let [ar,sr,dr] = map (amodeToStix target) res
+ let
+ a2stix = amodeToStix target
+ data_hs = dataHS target
+
+ ar = a2stix car
+ sr = a2stix csr
+ dr = a2stix cdr
+
len = case str of
(CString s) -> _LENGTH_ s
(CLit (MachStr s)) -> _LENGTH_ s
save = StAssign PtrKind safeHp oldHp
result = StIndex IntKind stgHpLim (StInt (toInteger (-mpIntSize)))
set_str = StCall SLIT("mpz_init_set_str") IntKind
- [result, amodeToStix target str, StInt 10]
+ [result, a2stix str, StInt 10]
test = StPrim IntEqOp [set_str, StInt 0]
cjmp = StCondJump ulbl test
abort = StCall SLIT("abort") VoidKind []
join = StLabel ulbl
restore = StAssign PtrKind stgHp safeHp
- (a1,a2,a3) = fromStruct target result (ar,sr,dr)
+ (a1,a2,a3) = fromStruct data_hs result (ar,sr,dr)
in
macroCode target HEAP_CHK [liveness, mkIntCLit space, mkIntCLit_0]
`thenSUs` \ heap_chk ->
encodeFloatingKind
:: PrimKind
-> Target
- -> [CAddrMode] -- result
- -> [CAddrMode] -- heap pointer for result, integer argument (3 parts), exponent
+ -> CAddrMode -- result
+ -> (CAddrMode,CAddrMode,CAddrMode,CAddrMode,CAddrMode)
+ -- heap pointer for result, integer argument (3 parts), exponent
-> SUniqSM StixTreeList
-encodeFloatingKind pk target [res] args =
- let result = amodeToStix target res
- [hp, aa,sa,da, expon] = map (amodeToStix target) args
- pk' = if sizeof target FloatKind == sizeof target DoubleKind then DoubleKind
+encodeFloatingKind pk target_STRICT res args@(chp, caa,csa,cda, cexpon) =
+ let
+ a2stix = amodeToStix target
+ size_of = sizeof target
+ data_hs = dataHS target
+
+ result = a2stix res
+ hp = a2stix chp
+ aa = a2stix caa
+ sa = a2stix csa
+ da = a2stix cda
+ expon = a2stix cexpon
+
+ pk' = if size_of FloatKind == size_of DoubleKind
+ then DoubleKind
else pk
- (a1,a2,a3) = toStruct target hp (aa,sa,da)
+ (a1,a2,a3) = toStruct data_hs hp (aa,sa,da)
fn = case pk' of
FloatKind -> SLIT("__encodeFloat")
DoubleKind -> SLIT("__encodeDouble")
decodeFloatingKind
:: PrimKind
-> Target
- -> [CAddrMode] -- exponent result, integer result (3 parts)
- -> [CAddrMode] -- heap pointer for exponent, floating argument
+ -> (CAddrMode, CAddrMode, CAddrMode, CAddrMode)
+ -- exponent result, integer result (3 parts)
+ -> (CAddrMode, CAddrMode)
+ -- heap pointer for exponent, floating argument
-> SUniqSM StixTreeList
-decodeFloatingKind pk target res args =
- let [exponr,ar,sr,dr] = map (amodeToStix target) res
- [hp, arg] = map (amodeToStix target) args
- pk' = if sizeof target FloatKind == sizeof target DoubleKind then DoubleKind
+decodeFloatingKind pk target_STRICT res@(cexponr,car,csr,cdr) args@(chp, carg) =
+ let
+ a2stix = amodeToStix target
+ size_of = sizeof target
+ data_hs = dataHS target
+
+ exponr = a2stix cexponr
+ ar = a2stix car
+ sr = a2stix csr
+ dr = a2stix cdr
+ hp = a2stix chp
+ arg = a2stix carg
+
+ pk' = if size_of FloatKind == size_of DoubleKind
+ then DoubleKind
else pk
setup = StAssign PtrKind mpData_mantissa (StIndex IntKind hp (StInt 1))
fn = case pk' of
DoubleKind -> SLIT("__decodeDouble")
_ -> panic "decodeFloatingKind"
decode = StCall fn VoidKind [mantissa, hp, arg]
- (a1,a2,a3) = fromStruct target mantissa (ar,sr,dr)
+ (a1,a2,a3) = fromStruct data_hs mantissa (ar,sr,dr)
a4 = StAssign IntKind exponr (StInd IntKind hp)
in
returnSUs (\xs -> setup : decode : a1 : a2 : a3 : a4 : xs)
mpData base = StInd PtrKind (StIndex IntKind base (StInt 2))
mpSpace
- :: Target
+ :: StixTree -- dataHs from Target
-> Int -- gmp structures needed
-> Int -- number of results
-> [StixTree] -- sizes to add for estimating result size
-> StixTree -- total space
-mpSpace target gmp res sizes =
+mpSpace data_hs gmp res sizes =
foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes
where
sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y]
fixed = StInt (toInteger (17 * res + gmp * mpIntSize))
- hdrs = StPrim IntMulOp [dataHS target, StInt (toInteger res)]
+ hdrs = StPrim IntMulOp [data_hs, StInt (toInteger res)]
\end{code}
which includes the space needed for these temporaries before you use them.
\begin{code}
-
mpStruct :: Int -> StixTree
mpStruct n = StIndex IntKind stgHpLim (StInt (toInteger (-(n * mpIntSize))))
toStruct
- :: Target
+ :: StixTree -- dataHS, from Target
-> StixTree
-> (StixTree, StixTree, StixTree)
-> (StixTree, StixTree, StixTree)
-toStruct target str (alloc,size,arr) =
+toStruct data_hs str (alloc,size,arr) =
let
f1 = StAssign IntKind (mpAlloc str) alloc
f2 = StAssign IntKind (mpSize str) size
- f3 = StAssign PtrKind (mpData str) (StIndex PtrKind arr (dataHS target))
+ f3 = StAssign PtrKind (mpData str) (StIndex PtrKind arr data_hs)
in
(f1, f2, f3)
fromStruct
- :: Target
+ :: StixTree -- dataHS, from Target
-> StixTree
-> (StixTree, StixTree, StixTree)
-> (StixTree, StixTree, StixTree)
-fromStruct target str (alloc,size,arr) =
+fromStruct data_hs str (alloc,size,arr) =
let
e1 = StAssign IntKind alloc (mpAlloc str)
e2 = StAssign IntKind size (mpSize str)
e3 = StAssign PtrKind arr (StIndex PtrKind (mpData str)
- (StPrim IntNegOp [dataHS target]))
+ (StPrim IntNegOp [data_hs]))
in
(e1, e2, e3)
-
-
\end{code}
import BasicLit(BasicLit)
import CLabelInfo(CLabel)
import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
import CostCentre(CostCentre)
import HeapOffs(HeapOffset)
import MachDesc(RegLoc, Target)
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
import PrimKind(PrimKind)
import PrimOps(PrimOp)
import SMRep(SMRep)
import SplitUniq(SplitUniqSupply)
import Stix(CodeSegment, StixReg, StixTree)
import Unique(Unique)
-data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-}
-data CExprMacro {-# GHC_PRAGMA INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG #-}
-data CStmtMacro {-# GHC_PRAGMA ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG #-}
-data Target {-# GHC_PRAGMA Target (GlobalSwitch -> SwitchResult) Int (SMRep -> Int) (MagicId -> RegLoc) (StixTree -> StixTree) (PrimKind -> Int) ([MagicId] -> [StixTree]) ([MagicId] -> [StixTree]) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) Int Int StixTree StixTree ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) Bool ([Char] -> [Char]) #-}
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
-doHeapCheck :: Target -> StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 5 _U_ 022012 _N_ _S_ "ALLAU(ALA)" {_A_ 3 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+data CAddrMode
+data CExprMacro
+data CStmtMacro
+data Target
+data SplitUniqSupply
+data StixTree
+doHeapCheck :: StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]
genMacroCode :: Target -> CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 3 _U_ 21122 _N_ _S_ "LEL" _N_ _N_ #-}
smStablePtrTable :: StixTree
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
mkIntCLit_3 = mkIntCLit 3
+-- hacking with Uncle Will:
+#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
+
genMacroCode
:: Target
-> CStmtMacro -- statement macro
-> [CAddrMode] -- args
-> SUniqSM StixTreeList
-genMacroCode target ARGS_CHK_A_LOAD_NODE args =
+genMacroCode target_STRICT macro args
+ = genmacro macro args
+ where
+ a2stix = amodeToStix target
+ stg_reg = stgReg target
+
+ -- real thing: here we go -----------------------
+
+ genmacro ARGS_CHK_A_LOAD_NODE args =
getUniqLabelNCG `thenSUs` \ ulbl ->
- let [words, lbl] = map (amodeToStix target) args
+ let [words, lbl] = map a2stix args
temp = StIndex PtrKind stgSpA words
test = StPrim AddrGeOp [stgSuA, temp]
cjmp = StCondJump ulbl test
in
returnSUs (\xs -> cjmp : assign : updatePAP : join : xs)
-genMacroCode target ARGS_CHK_A [words] =
+ genmacro ARGS_CHK_A [words] =
getUniqLabelNCG `thenSUs` \ ulbl ->
- let temp = StIndex PtrKind stgSpA (amodeToStix target words)
+ let temp = StIndex PtrKind stgSpA (a2stix words)
test = StPrim AddrGeOp [stgSuA, temp]
cjmp = StCondJump ulbl test
join = StLabel ulbl
\begin{code}
-genMacroCode target ARGS_CHK_B_LOAD_NODE args =
+ genmacro ARGS_CHK_B_LOAD_NODE args =
getUniqLabelNCG `thenSUs` \ ulbl ->
- let [words, lbl] = map (amodeToStix target) args
+ let [words, lbl] = map a2stix args
temp = StIndex PtrKind stgSuB (StPrim IntNegOp [words])
test = StPrim AddrGeOp [stgSpB, temp]
cjmp = StCondJump ulbl test
in
returnSUs (\xs -> cjmp : assign : updatePAP : join : xs)
-genMacroCode target ARGS_CHK_B [words] =
+ genmacro ARGS_CHK_B [words] =
getUniqLabelNCG `thenSUs` \ ulbl ->
- let temp = StIndex PtrKind stgSuB (StPrim IntNegOp [amodeToStix target words])
+ let temp = StIndex PtrKind stgSuB (StPrim IntNegOp [a2stix words])
test = StPrim AddrGeOp [stgSpB, temp]
cjmp = StCondJump ulbl test
join = StLabel ulbl
\begin{code}
-genMacroCode target HEAP_CHK args =
- let [liveness,words,reenter] = map (amodeToStix target) args
+ genmacro HEAP_CHK args =
+ let [liveness,words,reenter] = map a2stix args
in
- doHeapCheck target liveness words reenter
+ doHeapCheck {-UNUSED NOW:target-} liveness words reenter
\end{code}
\begin{code}
-genMacroCode target STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] =
+ genmacro STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] =
{- Need to check to see if we are compiling with stack checks
getUniqLabelNCG `thenSUs` \ ulbl ->
let words = StPrim IntNegOp
- [StPrim IntAddOp [amodeToStix target aWords, amodeToStix target bWords]]
+ [StPrim IntAddOp [a2stix aWords, a2stix bWords]]
temp = StIndex PtrKind stgSpA words
test = StPrim AddrGtOp [temp, stgSpB]
cjmp = StCondJump ulbl test
\begin{code}
-genMacroCode target UPD_CAF args =
- let [cafptr,bhptr] = map (amodeToStix target) args
+ genmacro UPD_CAF args =
+ let [cafptr,bhptr] = map a2stix args
w0 = StInd PtrKind cafptr
w1 = StInd PtrKind (StIndex PtrKind cafptr (StInt 1))
w2 = StInd PtrKind (StIndex PtrKind cafptr (StInt 2))
\begin{code}
-genMacroCode target UPD_IND args =
+ genmacro UPD_IND args =
getUniqLabelNCG `thenSUs` \ ulbl ->
- let [updptr, heapptr] = map (amodeToStix target) args
+ let [updptr, heapptr] = map a2stix args
test = StPrim AddrGtOp [updptr, smOldLim]
cjmp = StCondJump ulbl test
updRoots = StAssign PtrKind smOldMutables updptr
\begin{code}
-genMacroCode target UPD_INPLACE_NOPTRS args = returnSUs id
+ genmacro UPD_INPLACE_NOPTRS args = returnSUs id
\end{code}
\begin{code}
-genMacroCode target UPD_INPLACE_PTRS [liveness] =
+ genmacro UPD_INPLACE_PTRS [liveness] =
getUniqLabelNCG `thenSUs` \ ulbl ->
let cjmp = StCondJump ulbl testOldLim
testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
updOldMutables = StAssign PtrKind smOldMutables stgNode
updUpdReg = StAssign PtrKind stgNode hpBack2
in
- genMacroCode target HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
+ genmacro HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
`thenSUs` \ heap_chk ->
returnSUs (\xs -> (cjmp :
heap_chk (updUpd0 : updUpd1 : updUpd2 :
\begin{code}
-genMacroCode target UPD_BH_UPDATABLE args = returnSUs id
+ genmacro UPD_BH_UPDATABLE args = returnSUs id
-genMacroCode target UPD_BH_SINGLE_ENTRY [arg] =
+ genmacro UPD_BH_SINGLE_ENTRY [arg] =
let
- update = StAssign PtrKind (StInd PtrKind (amodeToStix target arg)) bh_info
+ update = StAssign PtrKind (StInd PtrKind (a2stix arg)) bh_info
in
returnSUs (\xs -> update : xs)
\begin{code}
-genMacroCode target PUSH_STD_UPD_FRAME args =
- let [bhptr, aWords, bWords] = map (amodeToStix target) args
+ genmacro PUSH_STD_UPD_FRAME args =
+ let [bhptr, aWords, bWords] = map a2stix args
frame n = StInd PtrKind
(StIndex PtrKind stgSpB (StPrim IntAddOp
[bWords, StInt (toInteger (sTD_UF_SIZE - n))]))
\begin{code}
-genMacroCode target POP_STD_UPD_FRAME args =
+ genmacro POP_STD_UPD_FRAME args =
let frame n = StInd PtrKind (StIndex PtrKind stgSpB (StInt (toInteger (-n))))
grabRet = StAssign PtrKind stgRetReg (frame uF_RET)
\begin{code}
{- UNUSED:
-genMacroCode target PUSH_CON_UPD_FRAME args =
+ genmacro PUSH_CON_UPD_FRAME args =
panic "genMacroCode:PUSH_CON_UPD_FRAME"
-}
\end{code}
\begin{code}
-genMacroCode target SET_ARITY args = returnSUs id
-genMacroCode target CHK_ARITY args = returnSUs id
+ genmacro SET_ARITY args = returnSUs id
+ genmacro CHK_ARITY args = returnSUs id
\end{code}
\begin{code}
-genMacroCode target SET_TAG [tag] =
- let set_tag = StAssign IntKind stgTagReg (amodeToStix target tag)
+ genmacro SET_TAG [tag] =
+ let set_tag = StAssign IntKind stgTagReg (a2stix tag)
in
- case stgReg target TagReg of
+ case stg_reg TagReg of
Always _ -> returnSUs id
Save _ -> returnSUs (\xs -> set_tag : xs)
\begin{code}
doHeapCheck
- :: Target
- -> StixTree -- liveness
+ :: {- unused now: Target
+ -> -}StixTree -- liveness
-> StixTree -- words needed
-> StixTree -- always reenter node? (boolean)
-> SUniqSM StixTreeList
-doHeapCheck target liveness words reenter =
+doHeapCheck {-target:unused now-} liveness words reenter =
getUniqLabelNCG `thenSUs` \ ulbl ->
let newHp = StIndex PtrKind stgHp words
assign = StAssign PtrKind stgHp newHp
import BasicLit(BasicLit)
import CLabelInfo(CLabel)
import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch, SwitchResult)
import CostCentre(CostCentre)
import HeapOffs(HeapOffset)
import MachDesc(RegLoc, Target)
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
-import Pretty(PprStyle)
import PrimKind(PrimKind)
import PrimOps(PrimOp)
import SMRep(SMRep)
import Stix(CodeSegment, StixReg, StixTree)
import UniType(UniType)
import Unique(Unique)
-data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-}
-data Target {-# GHC_PRAGMA Target (GlobalSwitch -> SwitchResult) Int (SMRep -> Int) (MagicId -> RegLoc) (StixTree -> StixTree) (PrimKind -> Int) ([MagicId] -> [StixTree]) ([MagicId] -> [StixTree]) (HeapOffset -> Int) (CAddrMode -> StixTree) (CAddrMode -> StixTree) Int Int StixTree StixTree ([CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (CStmtMacro -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]) (StixTree -> StixTree -> StixTree -> SplitUniqSupply -> [StixTree] -> [StixTree]) (PprStyle -> [[StixTree]] -> SplitUniqSupply -> CSeq) Bool ([Char] -> [Char]) #-}
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data StixTree {-# GHC_PRAGMA StSegment CodeSegment | StInt Integer | StDouble (Ratio Integer) | StString _PackedString | StLitLbl CSeq | StLitLit _PackedString | StCLbl CLabel | StReg StixReg | StIndex PrimKind StixTree StixTree | StInd PrimKind StixTree | StAssign PrimKind StixTree StixTree | StLabel CLabel | StFunBegin CLabel | StFunEnd CLabel | StJump StixTree | StFallThrough CLabel | StCondJump CLabel StixTree | StData PrimKind [StixTree] | StPrim PrimOp [StixTree] | StCall _PackedString PrimKind [StixTree] | StComment _PackedString #-}
+data CAddrMode
+data Target
+data PrimOp
+data SplitUniqSupply
+data StixTree
amodeCode :: Target -> CAddrMode -> StixTree
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
amodeCode' :: Target -> CAddrMode -> StixTree
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
genPrimCode :: Target -> [CAddrMode] -> PrimOp -> [CAddrMode] -> SplitUniqSupply -> [StixTree] -> [StixTree]
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LSSL" _N_ _N_ #-}
of C code? ADR
\begin{code}
-
-genPrimCode target lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
- | is_asm = error "ERROR: Native code generator can't handle casm"
- | otherwise =
- case lhs of
- [] -> returnSUs (\xs -> (StCall fn VoidKind args) : xs)
- [lhs] ->
- let lhs' = amodeToStix target lhs
- pk = if isFloatingKind (getAmodeKind lhs) then DoubleKind else IntKind
- call = StAssign pk lhs' (StCall fn pk args)
- in
- returnSUs (\xs -> call : xs)
- where
- args = map amodeCodeForCCall rhs
- amodeCodeForCCall x =
- let base = amodeToStix' target x
- in
- case getAmodeKind x of
- ArrayKind -> StIndex PtrKind base (mutHS target)
- ByteArrayKind -> StIndex IntKind base (dataHS target)
- MallocPtrKind -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
- _ -> base
-
-\end{code}
-
-The @ErrorIO@ primitive is actually a bit weird...assign a new value to the root
-closure, flush stdout and stderr, and jump to the @ErrorIO_innards@.
-
-\begin{code}
-
-genPrimCode target [] ErrorIOPrimOp [rhs] =
- let changeTop = StAssign PtrKind topClosure (amodeToStix target rhs)
- in
- returnSUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
-
+-- hacking with Uncle Will:
+#define target_STRICT target@(Target _ _ _ _ _ _ _ _)
+
+genPrimCode target_STRICT res op args
+ = genprim res op args
+ where
+ a2stix = amodeToStix target
+ a2stix' = amodeToStix' target
+ mut_hs = mutHS target
+ data_hs = dataHS target
+ heap_chkr = heapCheck target
+ size_of = sizeof target
+ fixed_hs = fixedHeaderSize target
+ var_hs = varHeaderSize target
+
+ --- real code will follow... -------------
\end{code}
The (MP) integer operations are a true nightmare. Since we don't have a
heap check accordingly.
\begin{code}
-
-genPrimCode target res IntegerAddOp args =
- gmpTake2Return1 target res SLIT("mpz_add") args
-genPrimCode target res IntegerSubOp args =
- gmpTake2Return1 target res SLIT("mpz_sub") args
-genPrimCode target res IntegerMulOp args =
- gmpTake2Return1 target res SLIT("mpz_mul") args
-
-genPrimCode target res IntegerNegOp arg =
- gmpTake1Return1 target res SLIT("mpz_neg") arg
-
-genPrimCode target res IntegerQuotRemOp arg =
- gmpTake2Return2 target res SLIT("mpz_divmod") arg
-genPrimCode target res IntegerDivModOp arg =
- gmpTake2Return2 target res SLIT("mpz_targetivmod") arg
-
+ -- NB: ordering of clauses somewhere driven by
+ -- the desire to getting sane patt-matching behavior
+
+ genprim res@[ar1,sr1,dr1, ar2,sr2,dr2]
+ IntegerQuotRemOp
+ args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
+ gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_divmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+
+ genprim res@[ar1,sr1,dr1, ar2,sr2,dr2]
+ IntegerDivModOp
+ args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
+ gmpTake2Return2 target (ar1,sr1,dr1, ar2,sr2,dr2) SLIT("mpz_targetivmod") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+
+ genprim res@[ar,sr,dr] IntegerAddOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
+ gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_add") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+ genprim res@[ar,sr,dr] IntegerSubOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
+ gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_sub") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+ genprim res@[ar,sr,dr] IntegerMulOp args@[liveness, aa1,sa1,da1, aa2,sa2,da2] =
+ gmpTake2Return1 target (ar,sr,dr) SLIT("mpz_mul") (liveness, aa1,sa1,da1, aa2,sa2,da2)
+
+ genprim res@[ar,sr,dr] IntegerNegOp arg@[liveness,aa,sa,da] =
+ gmpTake1Return1 target (ar,sr,dr) SLIT("mpz_neg") (liveness,aa,sa,da)
\end{code}
Since we are using the heap for intermediate @MP_INT@ structs, integer comparison
{\em does} require a heap check in the native code implementation.
\begin{code}
+ genprim res@[exponr,ar,sr,dr] FloatDecodeOp args@[hp, arg] =
+ decodeFloatingKind FloatKind target (exponr,ar,sr,dr) (hp, arg)
+
+ genprim res@[exponr,ar,sr,dr] DoubleDecodeOp args@[hp, arg] =
+ decodeFloatingKind DoubleKind target (exponr,ar,sr,dr) (hp, arg)
-genPrimCode target [res] IntegerCmpOp args = gmpCompare target res args
+ genprim res@[ar,sr,dr] Int2IntegerOp args@[hp, n]
+ = gmpInt2Integer target (ar,sr,dr) (hp, n)
-genPrimCode target [res] Integer2IntOp arg = gmpInteger2Int target res arg
+ genprim res@[ar,sr,dr] Addr2IntegerOp args@[liveness,str]
+ = gmpString2Integer target (ar,sr,dr) (liveness,str)
-genPrimCode target res Int2IntegerOp args = gmpInt2Integer target res args
+ genprim [res] IntegerCmpOp args@[hp, aa1,sa1,da1, aa2,sa2,da2]
+ = gmpCompare target res (hp, aa1,sa1,da1, aa2,sa2,da2)
-genPrimCode target res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp"
+ genprim [res] Integer2IntOp arg@[hp, aa,sa,da]
+ = gmpInteger2Int target res (hp, aa,sa,da)
-genPrimCode target res Addr2IntegerOp args = gmpString2Integer target res args
+ genprim [res] FloatEncodeOp args@[hp, aa,sa,da, expon] =
+ encodeFloatingKind FloatKind target res (hp, aa,sa,da, expon)
-genPrimCode target res FloatEncodeOp args =
- encodeFloatingKind FloatKind target res args
+ genprim [res] DoubleEncodeOp args@[hp, aa,sa,da, expon] =
+ encodeFloatingKind DoubleKind target res (hp, aa,sa,da, expon)
-genPrimCode target res DoubleEncodeOp args =
- encodeFloatingKind DoubleKind target res args
+ genprim [res] Int2AddrOp [arg] =
+ simpleCoercion AddrKind res arg
-genPrimCode target res FloatDecodeOp args =
- decodeFloatingKind FloatKind target res args
+ genprim [res] Addr2IntOp [arg] =
+ simpleCoercion IntKind res arg
-genPrimCode target res DoubleDecodeOp args =
- decodeFloatingKind DoubleKind target res args
+ genprim [res] Int2WordOp [arg] =
+ simpleCoercion IntKind{-WordKind?-} res arg
-genPrimCode target res Int2AddrOp arg =
- simpleCoercion target AddrKind res arg
+ genprim [res] Word2IntOp [arg] =
+ simpleCoercion IntKind res arg
+
+\end{code}
-genPrimCode target res Addr2IntOp arg =
- simpleCoercion target IntKind res arg
+The @ErrorIO@ primitive is actually a bit weird...assign a new value to the root
+closure, flush stdout and stderr, and jump to the @ErrorIO_innards@.
-genPrimCode target res Int2WordOp arg =
- simpleCoercion target IntKind{-WordKind?-} res arg
+\begin{code}
-genPrimCode target res Word2IntOp arg =
- simpleCoercion target IntKind res arg
+ genprim [] ErrorIOPrimOp [rhs] =
+ let changeTop = StAssign PtrKind topClosure (a2stix rhs)
+ in
+ returnSUs (\xs -> changeTop : flushStdout : flushStderr : errorIO : xs)
\end{code}
@newArray#@ ops allocate heap space.
\begin{code}
-
-genPrimCode target [res] NewArrayOp args =
- let [liveness, n, initial] = map (amodeToStix target) args
- result = amodeToStix target res
- space = StPrim IntAddOp [n, mutHS target]
+ genprim [res] NewArrayOp args =
+ let [liveness, n, initial] = map a2stix args
+ result = a2stix res
+ space = StPrim IntAddOp [n, mut_hs]
loc = StIndex PtrKind stgHp
(StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
assign = StAssign PtrKind result loc
initialise = StCall SLIT("newArrZh_init") VoidKind [result, n, initial]
in
- heapCheck target liveness space (StInt 0)
- `thenSUs` \ heap_chk ->
+ heap_chkr liveness space (StInt 0) `thenSUs` \ heap_chk ->
returnSUs (heap_chk . (\xs -> assign : initialise : xs))
-genPrimCode target [res] (NewByteArrayOp pk) args =
- let [liveness, count] = map (amodeToStix target) args
- result = amodeToStix target res
- n = StPrim IntMulOp [count, StInt (toInteger (sizeof target pk))]
- slop = StPrim IntAddOp [n, StInt (toInteger (sizeof target IntKind - 1))]
- words = StPrim IntDivOp [slop, StInt (toInteger (sizeof target IntKind))]
- space = StPrim IntAddOp [n, StPrim IntAddOp [words, dataHS target]]
+ genprim [res] (NewByteArrayOp pk) args =
+ let [liveness, count] = map a2stix args
+ result = a2stix res
+ n = StPrim IntMulOp [count, StInt (toInteger (size_of pk))]
+ slop = StPrim IntAddOp [n, StInt (toInteger (size_of IntKind - 1))]
+ words = StPrim IntQuotOp [slop, StInt (toInteger (size_of IntKind))]
+ space = StPrim IntAddOp [n, StPrim IntAddOp [words, data_hs]]
loc = StIndex PtrKind stgHp
(StPrim IntNegOp [StPrim IntSubOp [space, StInt 1]])
assign = StAssign PtrKind result loc
init2 = StAssign IntKind
(StInd IntKind
(StIndex IntKind loc
- (StInt (toInteger (fixedHeaderSize target)))))
+ (StInt (toInteger fixed_hs))))
(StPrim IntAddOp [words,
- StInt (toInteger (varHeaderSize target
- (DataRep 0)))])
+ StInt (toInteger (var_hs (DataRep 0)))])
in
- heapCheck target liveness space (StInt 0)
- `thenSUs` \ heap_chk ->
+ heap_chkr liveness space (StInt 0) `thenSUs` \ heap_chk ->
returnSUs (heap_chk . (\xs -> assign : init1 : init2 : xs))
-genPrimCode target [res] SameMutableArrayOp args =
- let compare = StPrim AddrEqOp (map (amodeToStix target) args)
- assign = StAssign IntKind (amodeToStix target res) compare
+ genprim [res] SameMutableArrayOp args =
+ let compare = StPrim AddrEqOp (map a2stix args)
+ assign = StAssign IntKind (a2stix res) compare
in
returnSUs (\xs -> assign : xs)
-genPrimCode target res SameMutableByteArrayOp args =
- genPrimCode target res SameMutableArrayOp args
+ genprim res@[_] SameMutableByteArrayOp args =
+ genprim res SameMutableArrayOp args
\end{code}
\begin{code}
-genPrimCode target [lhs] UnsafeFreezeArrayOp [rhs] =
- let lhs' = amodeToStix target lhs
- rhs' = amodeToStix target rhs
+ genprim [lhs] UnsafeFreezeArrayOp [rhs] =
+ let lhs' = a2stix lhs
+ rhs' = a2stix rhs
header = StInd PtrKind lhs'
assign = StAssign PtrKind lhs' rhs'
freeze = StAssign PtrKind header imMutArrayOfPtrs_info
in
returnSUs (\xs -> assign : freeze : xs)
-genPrimCode target lhs UnsafeFreezeByteArrayOp rhs =
- simpleCoercion target PtrKind lhs rhs
+ genprim [lhs] UnsafeFreezeByteArrayOp [rhs] =
+ simpleCoercion PtrKind lhs rhs
\end{code}
\begin{code}
-genPrimCode target lhs IndexArrayOp args =
- genPrimCode target lhs ReadArrayOp args
+ genprim lhs@[_] IndexArrayOp args =
+ genprim lhs ReadArrayOp args
-genPrimCode target [lhs] ReadArrayOp [obj, ix] =
- let lhs' = amodeToStix target lhs
- obj' = amodeToStix target obj
- ix' = amodeToStix target ix
- base = StIndex IntKind obj' (mutHS target)
+ genprim [lhs] ReadArrayOp [obj, ix] =
+ let lhs' = a2stix lhs
+ obj' = a2stix obj
+ ix' = a2stix ix
+ base = StIndex IntKind obj' mut_hs
assign = StAssign PtrKind lhs' (StInd PtrKind (StIndex PtrKind base ix'))
in
returnSUs (\xs -> assign : xs)
-genPrimCode target [lhs] WriteArrayOp [obj, ix, v] =
- let obj' = amodeToStix target obj
- ix' = amodeToStix target ix
- v' = amodeToStix target v
- base = StIndex IntKind obj' (mutHS target)
+ genprim [lhs] WriteArrayOp [obj, ix, v] =
+ let obj' = a2stix obj
+ ix' = a2stix ix
+ v' = a2stix v
+ base = StIndex IntKind obj' mut_hs
assign = StAssign PtrKind (StInd PtrKind (StIndex PtrKind base ix')) v'
in
returnSUs (\xs -> assign : xs)
-genPrimCode target lhs (IndexByteArrayOp pk) args =
- genPrimCode target lhs (ReadByteArrayOp pk) args
+ genprim lhs@[_] (IndexByteArrayOp pk) args =
+ genprim lhs (ReadByteArrayOp pk) args
+
+-- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
-genPrimCode target [lhs] (ReadByteArrayOp pk) [obj, ix] =
- let lhs' = amodeToStix target lhs
- obj' = amodeToStix target obj
- ix' = amodeToStix target ix
- base = StIndex IntKind obj' (dataHS target)
- assign = StAssign pk lhs' (StInd pk (StIndex CharKind base ix'))
+ genprim [lhs] (ReadByteArrayOp pk) [obj, ix] =
+ let lhs' = a2stix lhs
+ obj' = a2stix obj
+ ix' = a2stix ix
+ base = StIndex IntKind obj' data_hs
+ assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
in
returnSUs (\xs -> assign : xs)
-genPrimCode target [] (WriteByteArrayOp pk) [obj, ix, v] =
- let obj' = amodeToStix target obj
- ix' = amodeToStix target ix
- v' = amodeToStix target v
- base = StIndex IntKind obj' (dataHS target)
- assign = StAssign pk (StInd pk (StIndex CharKind base ix')) v'
+ genprim [lhs] (IndexOffAddrOp pk) [obj, ix] =
+ let lhs' = a2stix lhs
+ obj' = a2stix obj
+ ix' = a2stix ix
+ assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
in
returnSUs (\xs -> assign : xs)
-genPrimCode target [lhs] (IndexOffAddrOp pk) [obj, ix] =
- let lhs' = amodeToStix target lhs
- obj' = amodeToStix target obj
- ix' = amodeToStix target ix
- assign = StAssign pk lhs' (StInd pk (StIndex CharKind obj' ix'))
+ genprim [] (WriteByteArrayOp pk) [obj, ix, v] =
+ let obj' = a2stix obj
+ ix' = a2stix ix
+ v' = a2stix v
+ base = StIndex IntKind obj' data_hs
+ assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
in
returnSUs (\xs -> assign : xs)
-
\end{code}
Stable pointer operations.
\begin{code}
-genPrimCode target [lhs] DeRefStablePtrOp [sp] =
- let lhs' = amodeToStix target lhs
+ genprim [lhs] DeRefStablePtrOp [sp] =
+ let lhs' = a2stix lhs
pk = getAmodeKind lhs
- sp' = amodeToStix target sp
+ sp' = a2stix sp
call = StCall SLIT("deRefStablePointer") pk [sp', smStablePtrTable]
assign = StAssign pk lhs' call
in
--JSM
\begin{pseudocode}
-genPrimCode sty md [lhs] MakeStablePtrOp args =
+ genprim [lhs] MakeStablePtrOp args =
let
-- some useful abbreviations (I'm sure these must exist already)
add = trPrim . IntAddOp
(spt_EMPTY spt oklbl : (enlarge ++ (trLabel [oklbl] : allocate)))
\end{pseudocode}
+\begin{code}
+ genprim res Word2IntegerOp args = panic "genPrimCode:Word2IntegerOp"
+
+ genprim lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs
+ | is_asm = error "ERROR: Native code generator can't handle casm"
+ | otherwise =
+ case lhs of
+ [] -> returnSUs (\xs -> (StCall fn VoidKind args) : xs)
+ [lhs] ->
+ let lhs' = a2stix lhs
+ pk = if isFloatingKind (getAmodeKind lhs) then DoubleKind else IntKind
+ call = StAssign pk lhs' (StCall fn pk args)
+ in
+ returnSUs (\xs -> call : xs)
+ where
+ args = map amodeCodeForCCall rhs
+ amodeCodeForCCall x =
+ let base = a2stix' x
+ in
+ case getAmodeKind x of
+ ArrayKind -> StIndex PtrKind base mut_hs
+ ByteArrayKind -> StIndex IntKind base data_hs
+ MallocPtrKind -> error "ERROR: native-code generator can't handle Malloc Ptrs (yet): use -fvia-C!"
+ _ -> base
+\end{code}
Now the more mundane operations.
\begin{code}
-
-genPrimCode target lhs op rhs =
- let lhs' = map (amodeToStix target) lhs
- rhs' = map (amodeToStix' target) rhs
+ genprim lhs op rhs =
+ let lhs' = map a2stix lhs
+ rhs' = map a2stix' rhs
in
- returnSUs (\ xs -> simplePrim target lhs' op rhs' : xs)
-
-simpleCoercion
- :: Target
- -> PrimKind
- -> [CAddrMode]
- -> [CAddrMode]
- -> SUniqSM StixTreeList
-
-simpleCoercion target pk [lhs] [rhs] =
- returnSUs (\xs -> StAssign pk (amodeToStix target lhs) (amodeToStix target rhs) : xs)
+ returnSUs (\ xs -> simplePrim lhs' op rhs' : xs)
+
+ {-
+ simpleCoercion
+ :: Target
+ -> PrimKind
+ -> [CAddrMode]
+ -> [CAddrMode]
+ -> SUniqSM StixTreeList
+ -}
+ simpleCoercion pk lhs rhs =
+ returnSUs (\xs -> StAssign pk (a2stix lhs) (a2stix rhs) : xs)
\end{code}
at the level of the specific code generator.
\begin{code}
-
-simplePrim
+ {-
+ simplePrim
:: Target
-> [StixTree]
-> PrimOp
-> [StixTree]
-> StixTree
-
+ -}
\end{code}
Now look for something more conventional.
\begin{code}
-simplePrim target [lhs] op rest = StAssign pk lhs (StPrim op rest)
+ simplePrim [lhs] op rest = StAssign pk lhs (StPrim op rest)
where pk = if isCompareOp op then IntKind
else case getPrimOpResultInfo op of
ReturnsPrim pk -> pk
_ -> simplePrim_error op
-simplePrim target _ op _ = simplePrim_error op
+ simplePrim _ op _ = simplePrim_error op
-simplePrim_error op
- = error ("ERROR: primitive operation `"++showPrimOp PprDebug op++"'cannot be handled\nby the native-code generator. Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n")
+ simplePrim_error op
+ = error ("ERROR: primitive operation `"++showPrimOp PprDebug op++"'cannot be handled\nby the native-code generator. Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n")
\end{code}
%---------------------------------------------------------------------
-> CAddrMode
-> StixTree
-amodeCode' target am@(CVal rr CharKind)
+amodeCode'{-'-} target_STRICT am@(CVal rr CharKind)
| mixedTypeLocn am = StPrim ChrOp [amodeToStix target am]
| otherwise = amodeToStix target am
amodeCode' target am = amodeToStix target am
-amodeCode target am@(CVal rr CharKind) | mixedTypeLocn am =
- StInd IntKind (amodeCode target (CAddr rr))
+amodeCode target_STRICT am
+ = acode am
+ where
+ -- grab "target" things:
+ hp_rel = hpRel target
+ char_like = charLikeClosureSize target
+ int_like = intLikeClosureSize target
+ a2stix = amodeToStix target
+
+ -- real code: ----------------------------------
+ acode am@(CVal rr CharKind) | mixedTypeLocn am =
+ StInd IntKind (acode (CAddr rr))
-amodeCode target (CVal rr pk) = StInd pk (amodeCode target (CAddr rr))
+ acode (CVal rr pk) = StInd pk (acode (CAddr rr))
-amodeCode target (CAddr r@(SpARel spA off)) =
- StIndex PtrKind stgSpA (StInt (toInteger (spARelToInt r)))
+ acode (CAddr r@(SpARel spA off)) =
+ StIndex PtrKind stgSpA (StInt (toInteger (spARelToInt r)))
-amodeCode target (CAddr r@(SpBRel spB off)) =
- StIndex IntKind stgSpB (StInt (toInteger (spBRelToInt r)))
+ acode (CAddr r@(SpBRel spB off)) =
+ StIndex IntKind stgSpB (StInt (toInteger (spBRelToInt r)))
-amodeCode target (CAddr (HpRel hp off)) =
- StIndex IntKind stgHp (StInt (toInteger (-(hpRel target (hp `subOff` off)))))
+ acode (CAddr (HpRel hp off)) =
+ StIndex IntKind stgHp (StInt (toInteger (-(hp_rel (hp `subOff` off)))))
-amodeCode target (CAddr (NodeRel off)) =
- StIndex IntKind stgNode (StInt (toInteger (hpRel target off)))
+ acode (CAddr (NodeRel off)) =
+ StIndex IntKind stgNode (StInt (toInteger (hp_rel off)))
-amodeCode target (CReg magic) = StReg (StixMagicId magic)
-amodeCode target (CTemp uniq pk) = StReg (StixTemp uniq pk)
+ acode (CReg magic) = StReg (StixMagicId magic)
+ acode (CTemp uniq pk) = StReg (StixTemp uniq pk)
-amodeCode target (CLbl lbl _) = StCLbl lbl
+ acode (CLbl lbl _) = StCLbl lbl
-amodeCode target (CUnVecLbl dir _) = StCLbl dir
+ acode (CUnVecLbl dir _) = StCLbl dir
-amodeCode target (CTableEntry base off pk) =
- StInd pk (StIndex pk (amodeCode target base) (amodeCode target off))
+ acode (CTableEntry base off pk) =
+ StInd pk (StIndex pk (acode base) (acode off))
--- For CharLike and IntLike, we attempt some trivial constant-folding here.
+ -- For CharLike and IntLike, we attempt some trivial constant-folding here.
-amodeCode target (CCharLike (CLit (MachChar c))) =
- StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
- where off = charLikeClosureSize target * ord c
+ acode (CCharLike (CLit (MachChar c))) =
+ StLitLbl (uppBeside (uppPStr SLIT("CHARLIKE_closures+")) (uppInt off))
+ where off = char_like * ord c
-amodeCode target (CCharLike x) =
- StPrim IntAddOp [charLike, off]
- where off = StPrim IntMulOp [amodeCode target x,
- StInt (toInteger (charLikeClosureSize target))]
+ acode (CCharLike x) =
+ StPrim IntAddOp [charLike, off]
+ where off = StPrim IntMulOp [acode x,
+ StInt (toInteger (char_like))]
-amodeCode target (CIntLike (CLit (MachInt i _))) =
- StPrim IntAddOp [intLikePtr, StInt off]
- where off = toInteger (intLikeClosureSize target) * i
+ acode (CIntLike (CLit (MachInt i _))) =
+ StPrim IntAddOp [intLikePtr, StInt off]
+ where off = toInteger int_like * i
-amodeCode target (CIntLike x) =
- StPrim IntAddOp [intLikePtr, off]
- where off = StPrim IntMulOp [amodeCode target x,
- StInt (toInteger (intLikeClosureSize target))]
+ acode (CIntLike x) =
+ StPrim IntAddOp [intLikePtr, off]
+ where off = StPrim IntMulOp [acode x,
+ StInt (toInteger int_like)]
--- A CString is just a (CLit . MachStr)
-amodeCode target (CString s) = StString s
+ -- A CString is just a (CLit . MachStr)
+ acode (CString s) = StString s
-amodeCode target (CLit core) = case core of
- (MachChar c) -> StInt (toInteger (ord c))
- (MachStr s) -> StString s
- (MachAddr a) -> StInt a
- (MachInt i _) -> StInt i
- (MachLitLit s _) -> StLitLit s
- (MachFloat d) -> StDouble d
- (MachDouble d) -> StDouble d
- _ -> panic "amodeCode:core literal"
+ acode (CLit core) = case core of
+ (MachChar c) -> StInt (toInteger (ord c))
+ (MachStr s) -> StString s
+ (MachAddr a) -> StInt a
+ (MachInt i _) -> StInt i
+ (MachLitLit s _) -> StLitLit s
+ (MachFloat d) -> StDouble d
+ (MachDouble d) -> StDouble d
+ _ -> panic "amodeCode:core literal"
--- A CLitLit is just a (CLit . MachLitLit)
-amodeCode target (CLitLit s _) = StLitLit s
+ -- A CLitLit is just a (CLit . MachLitLit)
+ acode (CLitLit s _) = StLitLit s
--- COffsets are in words, not bytes!
-amodeCode target (COffset off) = StInt (toInteger (hpRel target off))
+ -- COffsets are in words, not bytes!
+ acode (COffset off) = StInt (toInteger (hp_rel off))
-amodeCode target (CMacroExpr _ macro [arg]) =
- case macro of
- INFO_PTR -> StInd PtrKind (amodeToStix target arg)
- ENTRY_CODE -> amodeToStix target arg
- INFO_TAG -> tag
- EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
- where
- tag = StInd IntKind (StIndex IntKind (amodeToStix target arg) (StInt (-2)))
- -- That ``-2'' really bothers me. (JSM)
+ acode (CMacroExpr _ macro [arg]) =
+ case macro of
+ INFO_PTR -> StInd PtrKind (a2stix arg)
+ ENTRY_CODE -> a2stix arg
+ INFO_TAG -> tag
+ EVAL_TAG -> StPrim IntGeOp [tag, StInt 0]
+ where
+ tag = StInd IntKind (StIndex IntKind (a2stix arg) (StInt (-2)))
+ -- That ``-2'' really bothers me. (JSM)
-amodeCode target (CCostCentre cc print_as_string)
- = if noCostCentreAttached cc
- then StComment SLIT("") -- sigh
- else panic "amodeCode:CCostCentre"
+ acode (CCostCentre cc print_as_string)
+ = if noCostCentreAttached cc
+ then StComment SLIT("") -- sigh
+ else panic "amodeCode:CCostCentre"
\end{code}
Sizes of the CharLike and IntLike closures that are arranged as arrays in the
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface AbsPrel where
-import BasicLit(BasicLit)
import Class(Class)
import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
-import CostCentre(CostCentre)
+import CoreSyn(CoreExpr)
import HeapOffs(HeapOffset)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Maybes(Labda)
import Name(Name)
import NameTypes(FullName, ShortName)
import Outputable(NamedThing, Outputable)
import PlainCore(PlainCoreExpr(..))
import PrelFuns(gLASGOW_MISC, gLASGOW_ST, pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_IO, pRELUDE_LIST, pRELUDE_PRIMIO, pRELUDE_PS, pRELUDE_RATIO, pRELUDE_TEXT)
-import PrelVals(aBSENT_ERROR_ID, buildId, eRROR_ID, foldlId, foldrId, integerMinusOneId, integerPlusOneId, integerZeroId, mkBuild, mkFoldl, mkFoldr, pAT_ERROR_ID, packStringForCId, realWorldPrimId, unpackCStringAppendId, unpackCStringId, voidPrimId)
+import PrelVals(aBSENT_ERROR_ID, buildId, eRROR_ID, foldlId, foldrId, integerMinusOneId, integerPlusOneId, integerZeroId, mkBuild, mkFoldl, mkFoldr, pAT_ERROR_ID, packStringForCId, realWorldPrimId, unpackCString2Id, unpackCStringAppendId, unpackCStringId, voidPrimId)
import PreludePS(_PackedString)
import Pretty(PprStyle, PrettyRep)
import PrimKind(PrimKind)
-import PrimOps(HeapRequirement(..), PrimOp(..), PrimOpResultInfo(..), fragilePrimOp, getPrimOpResultInfo, isCompareOp, pprPrimOp, primOpCanTriggerGC, primOpHeapReq, primOpIsCheap, primOpNameInfo, primOpNeedsWrapper, primOpOkForSpeculation, showPrimOp, tagOf_PrimOp, typeOfPrimOp)
+import PrimOps(HeapRequirement(..), PrimOp(..), PrimOpResultInfo(..), fragilePrimOp, getPrimOpResultInfo, isCompareOp, pprPrimOp, primOpCanTriggerGC, primOpHeapReq, primOpIsCheap, primOpNameInfo, primOpNeedsWrapper, primOpOkForSpeculation, showPrimOp, typeOfPrimOp)
import TyCon(TyCon)
import TyVar(TyVar, TyVarTemplate)
-import TysPrim(addrPrimTy, addrPrimTyCon, charPrimTy, charPrimTyCon, doublePrimTy, doublePrimTyCon, floatPrimTy, floatPrimTyCon, intPrimTy, intPrimTyCon, mkStatePrimTy, realWorldStatePrimTy, realWorldTy, realWorldTyCon, voidPrimTy, wordPrimTy, wordPrimTyCon)
-import TysWiredIn(addrDataCon, addrTy, boolTy, boolTyCon, charDataCon, charTy, charTyCon, cmpTagTy, consDataCon, doubleDataCon, doubleTy, doubleTyCon, eqPrimDataCon, falseDataCon, floatDataCon, floatTy, floatTyCon, getStatePairingConInfo, gtPrimDataCon, intDataCon, intTy, intTyCon, integerTy, integerTyCon, liftDataCon, liftTyCon, listTyCon, ltPrimDataCon, mkLiftTy, mkListTy, mkPrimIoTy, mkTupleTy, nilDataCon, ratioDataCon, rationalTy, rationalTyCon, realWorldStateTy, stateDataCon, stringTy, trueDataCon, unitTy, wordDataCon, wordTy)
+import TysPrim(addrPrimTy, addrPrimTyCon, charPrimTy, charPrimTyCon, doublePrimTy, doublePrimTyCon, floatPrimTy, floatPrimTyCon, intPrimTy, intPrimTyCon, realWorldStatePrimTy, realWorldTy, realWorldTyCon, voidPrimTy, wordPrimTy, wordPrimTyCon)
+import TysWiredIn(addrDataCon, addrTy, addrTyCon, boolTy, boolTyCon, charDataCon, charTy, charTyCon, cmpTagTy, consDataCon, doubleDataCon, doubleTy, doubleTyCon, eqPrimDataCon, falseDataCon, floatDataCon, floatTy, floatTyCon, getStatePairingConInfo, gtPrimDataCon, intDataCon, intTy, intTyCon, integerDataCon, integerTy, integerTyCon, liftDataCon, liftTyCon, listTyCon, ltPrimDataCon, mkLiftTy, mkListTy, mkPrimIoTy, mkTupleTy, nilDataCon, ratioDataCon, rationalTy, rationalTyCon, realWorldStateTy, stateDataCon, stringTy, trueDataCon, unitTy, wordDataCon, wordTy, wordTyCon)
import UniType(TauType(..), UniType)
import Unique(Unique)
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
+data GlobalSwitch
+data CoreExpr a b
data HeapOffset
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
+data Id
+data Labda a
+data Name
type PlainCoreExpr = CoreExpr Id Id
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
+data PprStyle
+data PrimKind
data HeapRequirement = NoHeapRequired | FixedHeapRequired HeapOffset | VariableHeapRequired
data PrimOp
= CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp
data PrimOpResultInfo = ReturnsPrim PrimKind | ReturnsAlg TyCon
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
+data TyCon
type TauType = UniType
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data UniType
+data Unique
gLASGOW_MISC :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
gLASGOW_ST :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_BUILTIN :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_CORE :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_IO :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_LIST :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_PRIMIO :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_PS :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_RATIO :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_TEXT :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
aBSENT_ERROR_ID :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
buildId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
eRROR_ID :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
foldlId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
foldrId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integerMinusOneId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integerPlusOneId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integerZeroId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkBuild :: UniType -> TyVar -> Id -> Id -> Id -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _N_ _N_ _N_ #-}
mkFoldl :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-}
mkFoldr :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-}
fragilePrimOp :: PrimOp -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isCompareOp :: PrimOp -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
addrPrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
addrPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charPrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
doublePrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
doublePrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatPrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intPrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
addrDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
addrTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+addrTyCon :: TyCon
boolTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
boolTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
builtinNameInfo :: (GlobalSwitch -> Bool) -> (_PackedString -> Labda Name, _PackedString -> Labda Name)
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
cmpTagTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
consDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
doubleDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
doubleTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
doubleTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
eqPrimDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
falseDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
getStatePairingConInfo :: UniType -> (Id, UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
gtPrimDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+integerDataCon :: Id
integerTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integerTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
liftDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
liftTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
listTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
ltPrimDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkFunTy :: UniType -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: UniType) (u1 :: UniType) -> _!_ _ORIG_ UniType UniFun [] [u0, u1] _N_ #-}
pAT_ERROR_ID :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
packStringForCId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
realWorldPrimId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+unpackCString2Id :: Id
unpackCStringAppendId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
unpackCStringId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
voidPrimId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-}
primOpCanTriggerGC :: PrimOp -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
primOpHeapReq :: PrimOp -> HeapRequirement
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
primOpIsCheap :: PrimOp -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
primOpNameInfo :: PrimOp -> (_PackedString, Name)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
primOpNeedsWrapper :: PrimOp -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
primOpOkForSpeculation :: PrimOp -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
showPrimOp :: PprStyle -> PrimOp -> [Char]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
-tagOf_PrimOp :: PrimOp -> Int#
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
typeOfPrimOp :: PrimOp -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-mkStatePrimTy :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
realWorldStatePrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _APP_ _ORIG_ TysPrim mkStatePrimTy [ _ORIG_ TysPrim realWorldTy ] _N_ #-}
realWorldTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
realWorldTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
voidPrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
wordPrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
wordPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkLiftTy :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkListTy :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkPrimIoTy :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkTupleTy :: Int -> [UniType] -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
nilDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
ratioDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
rationalTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
rationalTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
readUnfoldingPrimOp :: _PackedString -> PrimOp
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
realWorldStateTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stringTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _APP_ _ORIG_ TysWiredIn mkListTy [ _ORIG_ TysWiredIn charTy ] _N_ #-}
trueDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
unitTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
wordDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
wordTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+wordTyCon :: TyCon
instance Eq GlobalSwitch
- {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool)] [_CONSTM_ Eq (==) (GlobalSwitch), _CONSTM_ Eq (/=) (GlobalSwitch)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Eq Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool)] [_CONSTM_ Eq (==) (PrimKind), _CONSTM_ Eq (/=) (PrimKind)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Eq PrimOp
- {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimOp -> PrimOp -> Bool), (PrimOp -> PrimOp -> Bool)] [_CONSTM_ Eq (==) (PrimOp), _CONSTM_ Eq (/=) (PrimOp)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: PrimOp) (u1 :: PrimOp) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u0 ] of { _PRIM_ (u2 :: Int#) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u1 ] of { _PRIM_ (u3 :: Int#) -> _#_ eqInt# [] [u2, u3] } } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Eq TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool)] [_CONSTM_ Eq (==) (TyCon), _CONSTM_ Eq (/=) (TyCon)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Ord GlobalSwitch
- {-# GHC_PRAGMA _M_ CmdLineOpts {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq GlobalSwitch}}, (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> Bool), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> GlobalSwitch), (GlobalSwitch -> GlobalSwitch -> _CMP_TAG)] [_DFUN_ Eq (GlobalSwitch), _CONSTM_ Ord (<) (GlobalSwitch), _CONSTM_ Ord (<=) (GlobalSwitch), _CONSTM_ Ord (>=) (GlobalSwitch), _CONSTM_ Ord (>) (GlobalSwitch), _CONSTM_ Ord max (GlobalSwitch), _CONSTM_ Ord min (GlobalSwitch), _CONSTM_ Ord _tagCmp (GlobalSwitch)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Ord Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq PrimKind}}, (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> _CMP_TAG)] [_DFUN_ Eq (PrimKind), _CONSTM_ Ord (<) (PrimKind), _CONSTM_ Ord (<=) (PrimKind), _CONSTM_ Ord (>=) (PrimKind), _CONSTM_ Ord (>) (PrimKind), _CONSTM_ Ord max (PrimKind), _CONSTM_ Ord min (PrimKind), _CONSTM_ Ord _tagCmp (PrimKind)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Ord TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyCon}}, (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> _CMP_TAG)] [_DFUN_ Eq (TyCon), _CONSTM_ Ord (<) (TyCon), _CONSTM_ Ord (<=) (TyCon), _CONSTM_ Ord (>=) (TyCon), _CONSTM_ Ord (>) (TyCon), _CONSTM_ Ord max (TyCon), _CONSTM_ Ord min (TyCon), _CONSTM_ Ord _tagCmp (TyCon)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_,
- getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyCon -> ExportFlag), (TyCon -> Bool), (TyCon -> (_PackedString, _PackedString)), (TyCon -> _PackedString), (TyCon -> [_PackedString]), (TyCon -> SrcLoc), (TyCon -> Unique), (TyCon -> Bool), (TyCon -> UniType), (TyCon -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyCon), _CONSTM_ NamedThing isLocallyDefined (TyCon), _CONSTM_ NamedThing getOrigName (TyCon), _CONSTM_ NamedThing getOccurrenceName (TyCon), _CONSTM_ NamedThing getInformingModules (TyCon), _CONSTM_ NamedThing getSrcLoc (TyCon), _CONSTM_ NamedThing getTheUnique (TyCon), _CONSTM_ NamedThing hasType (TyCon), _CONSTM_ NamedThing getType (TyCon), _CONSTM_ NamedThing fromPreludeCore (TyCon)] _N_
- getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getTheUnique = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Unique } [ _NOREP_S_ "NamedThing.TyCon.getTheUnique" ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> Bool) } [ _NOREP_S_ "NamedThing.TyCon.hasType", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> UniType) } [ _NOREP_S_ "NamedThing.TyCon.getType", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
instance Outputable Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance Outputable PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (PrimKind) _N_
- ppr = _A_ 2 _U_ 0120 _N_ _S_ "AL" {_A_ 1 _U_ 120 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable PrimOp
- {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ #-}
instance Outputable TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyCon) _N_
- ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-}
instance Text Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_
- readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_,
- showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
-- *odd* values that need to be reached out and grabbed:
eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
- unpackCStringId, packStringForCId, unpackCStringAppendId,
+ unpackCStringId, unpackCString2Id, packStringForCId, unpackCStringAppendId,
integerZeroId, integerPlusOneId, integerMinusOneId,
#ifdef DPH
-- types: Addr#, Int#, Word#, Int
intPrimTy, intTy, intPrimTyCon, intTyCon, intDataCon,
- wordPrimTyCon, wordPrimTy, wordTy, wordDataCon,
- addrPrimTyCon, addrPrimTy, addrTy, addrDataCon,
+ wordPrimTyCon, wordPrimTy, wordTy, wordTyCon, wordDataCon,
+ addrPrimTyCon, addrPrimTy, addrTy, addrTyCon, addrDataCon,
-- types: Integer, Rational (= Ratio Integer)
integerTy, rationalTy,
- integerTyCon, rationalTyCon, ratioDataCon,
+ integerTyCon, integerDataCon,
+ rationalTyCon, ratioDataCon,
-- type: Lift
liftTyCon, liftDataCon, mkLiftTy,
(SLIT("foldl"), WiredInVal foldlId),
(SLIT("foldr"), WiredInVal foldrId),
(SLIT("_runST"), WiredInVal runSTId),
- (SLIT("realWorld#"), WiredInVal realWorldPrimId)
+ (SLIT("_seq_"), WiredInVal seqId), -- yes, used in sequential-land, too
+ -- WDP 95/11
+ (SLIT("realWorld#"), WiredInVal realWorldPrimId)
]
parallel_vals
- =[(SLIT("_seq_"), WiredInVal seqId),
- (SLIT("_par_"), WiredInVal parId),
+ =[(SLIT("_par_"), WiredInVal parId),
(SLIT("_fork_"), WiredInVal forkId)
#ifdef GRAN
,
IntSubOp,
IntMulOp,
IntQuotOp,
- IntDivOp,
IntRemOp,
IntNegOp,
AndOp,
interface PrelFuns where
import Bag(Bag)
import BasicLit(BasicLit)
-import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
+import BinderInfo(BinderInfo)
import CharSeq(CSeq)
import Class(Class, ClassOp)
import CmdLineOpts(GlobalSwitch)
import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr)
-import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC)
-import Id(Id, IdDetails)
+import CostCentre(CostCentre)
+import Id(Id)
import IdEnv(IdEnv(..))
-import IdInfo(ArgUsage, ArgUsageInfo, ArityInfo, DeforestInfo, Demand, DemandInfo, FBConsum, FBProd, FBType, FBTypeInfo, IdInfo, OptIdInfo(..), SpecEnv, SpecInfo, StrictnessInfo, UpdateInfo, arityMaybe, mkArityInfo, mkUnfolding, noIdInfo, noInfo_UF, nullSpecEnv)
-import InstEnv(InstTemplate, InstTy)
+import IdInfo(ArgUsage, ArgUsageInfo, ArityInfo, DeforestInfo, Demand, DemandInfo, FBConsum, FBProd, FBType, FBTypeInfo, IdInfo, OptIdInfo(..), SpecEnv, StrictnessInfo, UpdateInfo, arityMaybe, mkArityInfo, mkUnfolding, noIdInfo, noInfo_UF, nullSpecEnv)
+import InstEnv(InstTemplate)
import MagicUFs(MagicUnfoldingFun)
import Maybes(Labda)
import Name(Name(..))
-import NameTypes(FullName, Provenance, ShortName, mkPreludeCoreName)
+import NameTypes(FullName, ShortName, mkPreludeCoreName)
import Outputable(ExportFlag, NamedThing(..), Outputable(..))
import PlainCore(PlainCoreAtom(..), PlainCoreExpr(..))
import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
import PrimKind(PrimKind(..))
import PrimOps(PrimOp(..))
import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance(..))
import SrcLoc(SrcLoc)
-import TyCon(Arity(..), TyCon, cmpTyCon)
+import TyCon(Arity(..), TyCon)
import TyVar(TyVar, TyVarTemplate, alpha_tv, alpha_tyvar, beta_tv, beta_tyvar, delta_tv, delta_tyvar, epsilon_tv, epsilon_tyvar, gamma_tv, gamma_tyvar)
import TyVarEnv(TyVarEnv(..))
import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType(..), alpha, alpha_ty, beta, beta_ty, delta, delta_ty, epsilon, epsilon_ty, gamma, gamma_ty)
import Unique(Unique)
class OptIdInfo a where
noInfo :: a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) -> _APP_ _TYAPP_ patError# { u0 } [ _NOREP_S_ "%DIdInfo.OptIdInfo.noInfo\"" ] _N_ #-}
getInfo :: IdInfo -> a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.getInfo\"", u2 ] _N_ #-}
addInfo :: IdInfo -> a -> IdInfo
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) (u3 :: u0) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0 -> IdInfo) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.addInfo\"", u2, u3 ] _N_ #-}
ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 6 _U_ 022222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 6 XXXXXX 7 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: PprStyle) (u3 :: Id -> Id) (u4 :: u0) (u5 :: Int) (u6 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.ppInfo\"", u2, u3, u4, u5, u6 ] _N_ #-}
class NamedThing a where
getExportFlag :: a -> ExportFlag
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-}
isLocallyDefined :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-}
getOrigName :: a -> (_PackedString, _PackedString)
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-}
getOccurrenceName :: a -> _PackedString
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-}
getInformingModules :: a -> [_PackedString]
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-}
getSrcLoc :: a -> SrcLoc
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-}
getTheUnique :: a -> Unique
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-}
hasType :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-}
getType :: a -> UniType
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-}
fromPreludeCore :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-}
class Outputable a where
ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_
- {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-}
-data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-}
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
-data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data CoreArg a {-# GHC_PRAGMA TypeArg UniType | ValArg (CoreAtom a) #-}
-data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-}
-data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-}
-data CoreCaseAlternatives a b {-# GHC_PRAGMA CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b) #-}
-data CoreCaseDefault a b {-# GHC_PRAGMA CoNoDefault | CoBindDefault a (CoreExpr a b) #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Bag a
+data BasicLit
+data BinderInfo
+data Class
+data ClassOp
+data GlobalSwitch
+data CoreArg a
+data CoreAtom a
+data CoreBinding a b
+data CoreCaseAlternatives a b
+data CoreCaseDefault a b
+data CoreExpr a b
+data CostCentre
+data Id
type IdEnv a = UniqFM a
-data ArgUsage {-# GHC_PRAGMA ArgUsage Int | UnknownArgUsage #-}
-data ArgUsageInfo {-# GHC_PRAGMA NoArgUsageInfo | SomeArgUsageInfo [ArgUsage] #-}
-data ArityInfo {-# GHC_PRAGMA UnknownArity | ArityExactly Int #-}
-data DeforestInfo {-# GHC_PRAGMA Don'tDeforest | DoDeforest #-}
-data Demand {-# GHC_PRAGMA WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum #-}
-data DemandInfo {-# GHC_PRAGMA UnknownDemand | DemandedAsPer Demand #-}
-data FBConsum {-# GHC_PRAGMA FBGoodConsum | FBBadConsum #-}
-data FBProd {-# GHC_PRAGMA FBGoodProd | FBBadProd #-}
-data FBType {-# GHC_PRAGMA FBType [FBConsum] FBProd #-}
-data FBTypeInfo {-# GHC_PRAGMA NoFBTypeInfo | SomeFBTypeInfo FBType #-}
-data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-}
-data SpecEnv {-# GHC_PRAGMA SpecEnv [SpecInfo] #-}
-data StrictnessInfo {-# GHC_PRAGMA NoStrictnessInfo | BottomGuaranteed | StrictnessInfo [Demand] (Labda Id) #-}
-data UpdateInfo {-# GHC_PRAGMA NoUpdateInfo | SomeUpdateInfo [Int] #-}
-data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
+data ArgUsage
+data ArgUsageInfo
+data ArityInfo
+data DeforestInfo
+data Demand
+data DemandInfo
+data FBConsum
+data FBProd
+data FBType
+data FBTypeInfo
+data IdInfo
+data SpecEnv
+data StrictnessInfo
+data UpdateInfo
+data InstTemplate
+data Labda a
data Name = Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString
-data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-}
-data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-}
-data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-}
+data FullName
+data ShortName
+data ExportFlag
type PlainCoreAtom = CoreAtom Id
type PlainCoreExpr = CoreExpr Id Id
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
+data PrettyRep
data PrimKind = PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind
data PrimOp
= CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp
-data UnfoldingDetails {-# GHC_PRAGMA NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance #-}
+data UnfoldingDetails
data UnfoldingGuidance = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
+data SrcLoc
type Arity = Int
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
+data TyCon
+data TyVar
+data TyVarTemplate
type TyVarEnv a = UniqFM a
type SigmaType = UniType
type TauType = UniType
type ThetaType = [(Class, UniType)]
data UniType = UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data UniqFM a
+data Unique
arityMaybe :: ArityInfo -> Labda Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: ArityInfo) -> case u0 of { _ALG_ _ORIG_ IdInfo UnknownArity -> _!_ _ORIG_ Maybes Hamna [Int] []; _ORIG_ IdInfo ArityExactly (u1 :: Int) -> _!_ _ORIG_ Maybes Ni [Int] [u1]; _NO_DEFLT_ } _N_ #-}
mkArityInfo :: Int -> ArityInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ IdInfo ArityExactly [] [u0] _N_ #-}
mkUnfolding :: UnfoldingGuidance -> CoreExpr Id Id -> UnfoldingDetails
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
noIdInfo :: IdInfo
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _ORIG_ IdInfo IdInfo [] [_CONSTM_ OptIdInfo noInfo (ArityInfo), _CONSTM_ OptIdInfo noInfo (DemandInfo), _ORIG_ IdInfo nullSpecEnv, _CONSTM_ OptIdInfo noInfo (StrictnessInfo), _ORIG_ IdInfo noInfo_UF, _CONSTM_ OptIdInfo noInfo (UpdateInfo), _CONSTM_ OptIdInfo noInfo (DeforestInfo), _CONSTM_ OptIdInfo noInfo (ArgUsageInfo), _CONSTM_ OptIdInfo noInfo (FBTypeInfo), _ORIG_ SrcLoc mkUnknownSrcLoc] _N_ #-}
noInfo_UF :: UnfoldingDetails
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ SimplEnv NoUnfoldingDetails [] [] _N_ #-}
nullSpecEnv :: SpecEnv
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkPreludeCoreName :: _PackedString -> _PackedString -> FullName
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
-cmpTyCon :: TyCon -> TyCon -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
alpha_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
alpha_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
beta_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
beta_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
delta_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
delta_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
epsilon_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
epsilon_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
gamma_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
gamma_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
alpha :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar alpha_tv] _N_ #-}
alpha_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar alpha_tyvar] _N_ #-}
beta :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar beta_tv] _N_ #-}
beta_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar beta_tyvar] _N_ #-}
delta :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar delta_tv] _N_ #-}
delta_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar delta_tyvar] _N_ #-}
epsilon :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar epsilon_tv] _N_ #-}
epsilon_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar epsilon_tyvar] _N_ #-}
gLASGOW_MISC :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
gLASGOW_ST :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
gamma :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar gamma_tv] _N_ #-}
gamma_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar gamma_tyvar] _N_ #-}
pRELUDE :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_BUILTIN :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_CORE :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_IO :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_LIST :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_PRIMIO :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_PS :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_RATIO :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_TEXT :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pcDataCon :: Unique -> _PackedString -> _PackedString -> [TyVarTemplate] -> [(Class, UniType)] -> [UniType] -> TyCon -> SpecEnv -> Id
- {-# GHC_PRAGMA _A_ 8 _U_ 22222222 _N_ _N_ _N_ _N_ #-}
pcDataTyCon :: Unique -> _PackedString -> _PackedString -> [TyVarTemplate] -> [Id] -> TyCon
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-}
pcGenerateDataSpecs :: UniType -> SpecEnv
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
pcGenerateSpecs :: Unique -> Id -> IdInfo -> UniType -> SpecEnv
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
pcMiscPrelId :: Unique -> _PackedString -> _PackedString -> UniType -> IdInfo -> Id
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-}
pcPrimTyCon :: Unique -> _PackedString -> Int -> ([PrimKind] -> PrimKind) -> TyCon
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
import UniType(UniType)
import Unique(Unique)
aBSENT_ERROR_ID :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
buildId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
eRROR_ID :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
errorTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
foldlId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
foldrId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
forkId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integerMinusOneId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integerPlusOneId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integerZeroId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkBuild :: UniType -> TyVar -> Id -> Id -> Id -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _N_ _N_ _N_ #-}
mkFoldl :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-}
mkFoldr :: UniType -> UniType -> Id -> Id -> Id -> CoreExpr a Id
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _N_ _N_ _N_ #-}
pAR_ERROR_ID :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pAT_ERROR_ID :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pRELUDE_FB :: _PackedString
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
packStringForCId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
parId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
pc_bottoming_Id :: Unique -> _PackedString -> _PackedString -> UniType -> Id
- {-# GHC_PRAGMA _A_ 0 _U_ 2222 _N_ _N_ _N_ _N_ #-}
realWorldPrimId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
runSTId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
seqId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
tRACE_ID :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+unpackCString2Id :: Id
unpackCStringAppendId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
unpackCStringId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
voidPrimId :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
unpackCStringId
= pcMiscPrelId unpackCStringIdKey pRELUDE_PS SLIT("unpackPS#")
- (UniFun addrPrimTy{-a char *-} stringTy) noIdInfo
+ (addrPrimTy{-a char *-} `UniFun` stringTy) noIdInfo
+
+unpackCString2Id -- for cases when a string has a NUL in it
+ = pcMiscPrelId unpackCString2IdKey pRELUDE_PS SLIT("unpackPS2#")
+ (addrPrimTy{-a char *-}
+ `UniFun` (intPrimTy -- length
+ `UniFun` stringTy)) noIdInfo
--------------------------------------------------------------------
unpackCStringAppendId
- = pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackCStringAppend#")
+ = pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackCStringAppend#")
(addrPrimTy{-a "char *" pointer-}
`UniFun` (stringTy
`UniFun` stringTy)) noIdInfo
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface PrimKind where
-import Class(Class)
-import Id(DataCon(..), Id, IdDetails)
-import IdInfo(IdInfo)
-import Maybes(Labda)
-import NameTypes(FullName)
+import Id(DataCon(..), Id)
import Outputable(Outputable)
import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
import UniType(UniType)
-import Unique(Unique)
type DataCon = Id
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
data PrimKind = PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data TyCon
+data UniType
getKindInfo :: PrimKind -> ([Char], UniType, TyCon)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-}
getKindSize :: PrimKind -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-}
guessPrimKind :: [Char] -> PrimKind
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
isFloatingKind :: PrimKind -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _F_ _IF_ARGS_ 0 1 C 20 \ (u0 :: PrimKind) -> case u0 of { _ALG_ _ORIG_ PrimKind DoubleKind -> _!_ True [] []; _ORIG_ PrimKind FloatKind -> _!_ True [] []; (u1 :: PrimKind) -> _!_ False [] [] } _N_ #-}
isFollowableKind :: PrimKind -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-}
retKindSize :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
separateByPtrFollowness :: (a -> PrimKind) -> [a] -> ([a], [a])
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
showPrimKind :: PrimKind -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _N_ _N_ #-}
instance Eq PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool)] [_CONSTM_ Eq (==) (PrimKind), _CONSTM_ Eq (/=) (PrimKind)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Ord PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq PrimKind}}, (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> _CMP_TAG)] [_DFUN_ Eq (PrimKind), _CONSTM_ Ord (<) (PrimKind), _CONSTM_ Ord (<=) (PrimKind), _CONSTM_ Ord (>=) (PrimKind), _CONSTM_ Ord (>) (PrimKind), _CONSTM_ Ord max (PrimKind), _CONSTM_ Ord min (PrimKind), _CONSTM_ Ord _tagCmp (PrimKind)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Outputable PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (PrimKind) _N_
- ppr = _A_ 2 _U_ 0120 _N_ _S_ "AL" {_A_ 1 _U_ 120 _N_ _N_ _N_ _N_} _N_ _N_ #-}
interface PrimOps where
import Class(Class)
import HeapOffs(HeapOffset)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
-import Maybes(Labda)
+import Id(Id)
import Name(Name)
import NameTypes(FullName, ShortName)
import Outputable(Outputable)
import Unique(Unique)
data HeapOffset
data HeapRequirement = NoHeapRequired | FixedHeapRequired HeapOffset | VariableHeapRequired
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
+data Id
+data Name
+data PrimKind
data PrimOp
= CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp
data PrimOpInfo = Dyadic _PackedString UniType | Monadic _PackedString UniType | Compare _PackedString UniType | Coerce _PackedString UniType UniType | PrimResult _PackedString [TyVarTemplate] [UniType] TyCon PrimKind [UniType] | AlgResult _PackedString [TyVarTemplate] [UniType] TyCon [UniType]
data PrimOpResultInfo = ReturnsPrim PrimKind | ReturnsAlg TyCon
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data TyCon
+data TyVarTemplate
+data UniType
fragilePrimOp :: PrimOp -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isCompareOp :: PrimOp -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-}
primOpCanTriggerGC :: PrimOp -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
primOpHeapReq :: PrimOp -> HeapRequirement
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
primOpId :: PrimOp -> Id
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
primOpIsCheap :: PrimOp -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
primOpNameInfo :: PrimOp -> (_PackedString, Name)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
primOpNeedsWrapper :: PrimOp -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
primOpOkForSpeculation :: PrimOp -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
showPrimOp :: PprStyle -> PrimOp -> [Char]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
tagOf_PrimOp :: PrimOp -> Int#
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
typeOfPrimOp :: PrimOp -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instance Eq PrimOp
- {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimOp -> PrimOp -> Bool), (PrimOp -> PrimOp -> Bool)] [_CONSTM_ Eq (==) (PrimOp), _CONSTM_ Eq (/=) (PrimOp)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: PrimOp) (u1 :: PrimOp) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u0 ] of { _PRIM_ (u2 :: Int#) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u1 ] of { _PRIM_ (u3 :: Int#) -> _#_ eqInt# [] [u2, u3] } } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Outputable PrimOp
- {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ #-}
-- Int#-related ops:
-- IntAbsOp unused?? ADR
| IntAddOp | IntSubOp | IntMulOp | IntQuotOp
- | IntDivOp | IntRemOp | IntNegOp | IntAbsOp
+ | IntDivOp{-UNUSED-} | IntRemOp | IntNegOp | IntAbsOp
-- Word#-related ops:
| AndOp | OrOp | NotOp
tagOf_PrimOp IntSubOp = ILIT( 40)
tagOf_PrimOp IntMulOp = ILIT( 41)
tagOf_PrimOp IntQuotOp = ILIT( 42)
-tagOf_PrimOp IntDivOp = ILIT( 43)
+--UNUSED:tagOf_PrimOp IntDivOp = ILIT( 43)
tagOf_PrimOp IntRemOp = ILIT( 44)
tagOf_PrimOp IntNegOp = ILIT( 45)
tagOf_PrimOp IntAbsOp = ILIT( 46)
primOpInfo IntSubOp = Dyadic SLIT("minusInt#") intPrimTy
primOpInfo IntMulOp = Dyadic SLIT("timesInt#") intPrimTy
primOpInfo IntQuotOp = Dyadic SLIT("quotInt#") intPrimTy
-primOpInfo IntDivOp = Dyadic SLIT("divInt#") intPrimTy
+--UNUSED:primOpInfo IntDivOp = Dyadic SLIT("divInt#") intPrimTy
primOpInfo IntRemOp = Dyadic SLIT("remInt#") intPrimTy
primOpInfo IntNegOp = Monadic SLIT("negateInt#") intPrimTy
state-interface document).
\begin{verbatim}
-makeStablePointer# :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
-freeStablePointer# :: StablePtr# a -> State# _RealWorld -> State# _RealWorld
-deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
+makeStablePtr# :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
+freeStablePtr# :: StablePtr# a -> State# _RealWorld -> State# _RealWorld
+deRefStablePtr# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
\end{verbatim}
It may seem a bit surprising that @makeStablePtr#@ is a @PrimIO@
@makeStablePtr#@ and we only pass one of the stable pointers over, a
massive space leak can result. Putting it into the PrimIO monad
prevents this. (Another reason for putting them in a monad is to
-ensure correct sequencing wrt the side-effecting @freeStablePointer#@
+ensure correct sequencing wrt the side-effecting @freeStablePtr#@
operation.)
-Note that we can implement @freeStablePointer#@ using @_ccall_@ (and,
+Note that we can implement @freeStablePtr#@ using @_ccall_@ (and,
besides, it's not likely to be used from Haskell) so it's not a
primop.
primOpOkForSpeculation :: PrimOp -> Bool
-- Int.
-primOpOkForSpeculation IntDivOp = False -- Divide by zero
+--UNUSED:primOpOkForSpeculation IntDivOp = False -- Divide by zero
primOpOkForSpeculation IntQuotOp = False -- Divide by zero
primOpOkForSpeculation IntRemOp = False -- Divide by zero
primOpNeedsWrapper (CCallOp _ _ _ _ _) = True
-primOpNeedsWrapper IntDivOp = True
+--UNUSED:primOpNeedsWrapper IntDivOp = True
primOpNeedsWrapper NewArrayOp = True -- ToDo: for nativeGen only!(JSM)
primOpNeedsWrapper (NewByteArrayOp _) = True
import TyCon(TyCon)
import UniType(UniType)
addrPrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
addrPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
arrayPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
byteArrayPrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
byteArrayPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charPrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
doublePrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
doublePrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatPrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intPrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mallocPtrPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkArrayPrimTy :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkMutableArrayPrimTy :: UniType -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
mkMutableByteArrayPrimTy :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkStablePtrPrimTy :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkStatePrimTy :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkSynchVarPrimTy :: UniType -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
mutableArrayPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mutableByteArrayPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
realWorldStatePrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _APP_ _ORIG_ TysPrim mkStatePrimTy [ _ORIG_ TysPrim realWorldTy ] _N_ #-}
realWorldTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
realWorldTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stablePtrPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
statePrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
synchVarPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
voidPrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
wordPrimTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
wordPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
import TyCon(TyCon)
import UniType(UniType)
addrDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
addrTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
addrTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
boolTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
boolTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
charTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
cmpTagTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
cmpTagTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
consDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
doubleDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
doubleTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
doubleTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
eqPrimDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
falseDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
floatTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
getStatePairingConInfo :: UniType -> (Id, UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
gtPrimDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+integerDataCon :: Id
integerTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
integerTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
liftDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
liftTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
listTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
ltPrimDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mallocPtrTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkLiftTy :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkListTy :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkPrimIoTy :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
mkStateTransformerTy :: UniType -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
mkTupleTy :: Int -> [UniType] -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
nilDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
primIoTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
ratioDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
ratioTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
rationalTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
rationalTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
realWorldStateTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
return2GMPsTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
returnIntAndGMPTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stablePtrTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndAddrPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndArrayPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndByteArrayPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndCharPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndDoublePrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndFloatPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndIntPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndMallocPtrPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndMutableArrayPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndMutableByteArrayPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndPtrPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndStablePtrPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndSynchVarPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateAndWordPrimTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stateTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stringTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _APP_ _ORIG_ TysWiredIn mkListTy [ _ORIG_ TysWiredIn charTy ] _N_ #-}
stringTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
trueDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
unitTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
wordDataCon :: Id
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
wordTy :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
wordTyCon :: TyCon
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
intTyCon,
integerTy,
integerTyCon,
+ integerDataCon,
liftDataCon,
liftTyCon,
listTyCon,
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface CostCentre where
import CharSeq(CSeq)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Maybes(Labda)
import PreludePS(_PackedString)
import Pretty(PprStyle)
-import UniType(UniType)
-import Unique(Unique)
import Unpretty(Unpretty(..))
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data CcKind {-# GHC_PRAGMA UserCC _PackedString | AutoCC Id | DictCC Id #-}
-data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data CSeq
+data CcKind
+data CostCentre
+data Id
data IsCafCC = IsCafCC | IsNotCafCC
-data IsDupdCC {-# GHC_PRAGMA AnOriginalCC | ADupdCC #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
+data IsDupdCC
+data Labda a
type Unpretty = CSeq
cafifyCC :: CostCentre -> CostCentre
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
ccFromThisModule :: CostCentre -> _PackedString -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
ccMentionsId :: CostCentre -> Labda Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
cmpCostCentre :: CostCentre -> CostCentre -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
costsAreSubsumed :: CostCentre -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 12 \ (u0 :: CostCentre) -> case u0 of { _ALG_ _ORIG_ CostCentre SubsumedCosts -> _!_ True [] []; (u1 :: CostCentre) -> _!_ False [] [] } _N_ #-}
currentOrSubsumedCosts :: CostCentre -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 13 \ (u0 :: CostCentre) -> case u0 of { _ALG_ _ORIG_ CostCentre SubsumedCosts -> _!_ True [] []; _ORIG_ CostCentre CurrentCC -> _!_ True [] []; (u1 :: CostCentre) -> _!_ False [] [] } _N_ #-}
dontCareCostCentre :: CostCentre
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CostCentre DontCareCC [] [] _N_ #-}
dupifyCC :: CostCentre -> CostCentre
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
isCafCC :: CostCentre -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isDictCC :: CostCentre -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isDupdCC :: CostCentre -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkAllCafsCC :: _PackedString -> _PackedString -> CostCentre
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _ORIG_ CostCentre AllCafsCC [] [u0, u1] _N_ #-}
mkAllDictsCC :: _PackedString -> _PackedString -> Bool -> CostCentre
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _N_ _N_ #-}
mkAutoCC :: Id -> _PackedString -> _PackedString -> IsCafCC -> CostCentre
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
mkDictCC :: Id -> _PackedString -> _PackedString -> IsCafCC -> CostCentre
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
mkUserCC :: _PackedString -> _PackedString -> _PackedString -> CostCentre
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
noCostCentre :: CostCentre
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CostCentre NoCostCentre [] [] _N_ #-}
noCostCentreAttached :: CostCentre -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 12 \ (u0 :: CostCentre) -> case u0 of { _ALG_ _ORIG_ CostCentre NoCostCentre -> _!_ True [] []; (u1 :: CostCentre) -> _!_ False [] [] } _N_ #-}
overheadCostCentre :: CostCentre
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CostCentre OverheadCC [] [] _N_ #-}
preludeCafsCostCentre :: CostCentre
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CostCentre PreludeCafsCC [] [] _N_ #-}
preludeDictsCostCentre :: Bool -> CostCentre
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
setToAbleCostCentre :: CostCentre -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
showCostCentre :: PprStyle -> Bool -> CostCentre -> [Char]
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLS" _N_ _N_ #-}
subsumedCosts :: CostCentre
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CostCentre SubsumedCosts [] [] _N_ #-}
unCafifyCC :: CostCentre -> CostCentre
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
uppCostCentre :: PprStyle -> Bool -> CostCentre -> CSeq
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LLS" _N_ _N_ #-}
uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> CSeq
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LEL" _N_ _N_ #-}
useCurrentCostCentre :: CostCentre
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CostCentre CurrentCC [] [] _N_ #-}
import Id(Id)
import PreludePS(_PackedString)
addAutoCostCentres :: (GlobalSwitch -> SwitchResult) -> _PackedString -> [CoreBinding Id Id] -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLS" _N_ _N_ #-}
import SplitUniq(SplitUniqSupply)
import StgSyn(StgBinding)
stgMassageForProfiling :: _PackedString -> _PackedString -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> [StgBinding Id Id] -> (([CostCentre], [CostCentre]), [StgBinding Id Id])
- {-# GHC_PRAGMA _A_ 5 _U_ 22221 _N_ _N_ _N_ _N_ #-}
type SrcFun = _PackedString
type SrcLine = Int
readInteger :: [Char] -> Integer
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
import PreludePS(_PackedString)
import ProtoName(ProtoName)
cvBinds :: _PackedString -> (RdrBinding -> [Sig ProtoName]) -> RdrBinding -> Binds ProtoName (InPat ProtoName)
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LLS" _N_ _N_ #-}
cvClassOpSig :: RdrBinding -> [Sig ProtoName]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
cvInstDeclSig :: RdrBinding -> [Sig ProtoName]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
cvInstDecls :: Bool -> _PackedString -> _PackedString -> [_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)] -> [InstDecl ProtoName (InPat ProtoName)]
- {-# GHC_PRAGMA _A_ 4 _U_ 2221 _N_ _S_ "LLLS" _N_ _N_ #-}
cvMatches :: _PackedString -> Bool -> [RdrMatch] -> [Match ProtoName (InPat ProtoName)]
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
cvMonoBinds :: _PackedString -> [RdrBinding] -> MonoBinds ProtoName (InPat ProtoName)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
cvSepdBinds :: _PackedString -> (RdrBinding -> [Sig ProtoName]) -> [RdrBinding] -> Binds ProtoName (InPat ProtoName)
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LLS" _N_ _N_ #-}
cvValSig :: RdrBinding -> [Sig ProtoName]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
sepDeclsForInterface :: RdrBinding -> ([TyDecl ProtoName], [ClassDecl ProtoName (InPat ProtoName)], [_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)], [RdrBinding], [IfaceImportDecl])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
sepDeclsForTopBinds :: RdrBinding -> ([TyDecl ProtoName], [DataTypeSig ProtoName], [ClassDecl ProtoName (InPat ProtoName)], [_PackedString -> _PackedString -> Bool -> InstDecl ProtoName (InPat ProtoName)], [SpecialisedInstanceSig ProtoName], [DefaultDecl ProtoName], [RdrBinding])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
sepDeclsIntoSigsAndBinds :: RdrBinding -> ([RdrBinding], [RdrBinding])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
import U_hpragma(U_hpragma)
type ProtoUfBinder = (ProtoName, PolyType ProtoName)
wlkClassPragma :: U_hpragma -> _PackedString -> _State _RealWorld -> (ClassPragmas ProtoName, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "S" _N_ _N_ #-}
wlkDataPragma :: U_hpragma -> _PackedString -> _State _RealWorld -> (DataPragmas ProtoName, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "S" _N_ _N_ #-}
wlkInstPragma :: U_hpragma -> _PackedString -> _State _RealWorld -> ((Labda _PackedString, InstancePragmas ProtoName), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "S" _N_ _N_ #-}
wlkTySigPragmas :: U_hpragma -> _PackedString -> _State _RealWorld -> (RdrTySigPragmas, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "S" _N_ _N_ #-}
wlkTypePragma :: U_hpragma -> _PackedString -> _State _RealWorld -> (TypePragmas, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "SLU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import U_list(U_list)
import U_ttype(U_ttype)
rdConDecl :: _Addr -> _PackedString -> _State _RealWorld -> (ConDecl ProtoName, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdModule :: _State _RealWorld -> ((_PackedString, (_PackedString -> Bool, _PackedString -> Bool), Module ProtoName (InPat ProtoName)), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
wlkList :: (_Addr -> _PackedString -> _State _RealWorld -> (a, _State _RealWorld)) -> U_list -> _PackedString -> _State _RealWorld -> ([a], _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
wlkMonoType :: U_ttype -> _PackedString -> _State _RealWorld -> (MonoType ProtoName, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "S" _N_ _N_ #-}
interface Rename where
import AbsSyn(Module)
import Bag(Bag)
-import CharSeq(CSeq)
import CmdLineOpts(GlobalSwitch)
import ErrUtils(Error(..))
import HsBinds(Binds, Sig)
import Name(Name)
import NameTypes(FullName, ShortName)
import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
+import Pretty(PprStyle, Pretty(..), PrettyRep)
import ProtoName(ProtoName)
import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..), PreludeNameFun(..), PreludeNameFuns(..))
import SplitUniq(SplitUniqSupply)
import SrcLoc(SrcLoc)
import TyCon(TyCon)
import Unique(Unique)
-data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
+data Module a b
+data Bag a
+data GlobalSwitch
type Error = PprStyle -> Int -> Bool -> PrettyRep
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
+data InPat a
type ProtoNamePat = InPat ProtoName
type RenamedPat = InPat Name
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data Labda a
+data Name
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
+data PrettyRep
+data ProtoName
type GlobalNameFun = ProtoName -> Labda Name
type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name)
type PreludeNameFun = _PackedString -> Labda Name
type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name)
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
+data SplitUniqSupply
renameModule :: (GlobalSwitch -> Bool) -> (_PackedString -> Labda Name, _PackedString -> Labda Name) -> Module ProtoName (InPat ProtoName) -> SplitUniqSupply -> (Module Name (InPat Name), [_PackedString], (ProtoName -> Labda Name, ProtoName -> Labda Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 4 _U_ 2121 _N_ _S_ "LU(LL)U(LLSLLLLLLLLAL)U(ALL)" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import SrcLoc(SrcLoc)
import TyCon(TyCon)
import Unique(Unique)
-data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
+data Module a b
+data Bag a
+data InPat a
type ProtoNamePat = InPat ProtoName
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data Labda a
+data Name
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
+data PrettyRep
+data ProtoName
type PreludeNameFun = _PackedString -> Labda Name
type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name)
rnModule1 :: (_PackedString -> Labda Name, _PackedString -> Labda Name) -> Bool -> Module ProtoName (InPat ProtoName) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ((Module ProtoName (InPat ProtoName), [_PackedString]), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 3 _U_ 12122 _N_ _S_ "U(LL)LU(LLSLLLLLLLLAL)" {_A_ 4 _U_ 222122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
doIfaceImport1 orig_to_pn local_to_pn acc (IEThingAll orig_name)
= int_import1_help orig_to_pn local_to_pn acc orig_name
+-- the next ones will go away with 1.3:
+doIfaceImport1 orig_to_pn local_to_pn acc (IEConWithCons orig_name _)
+ = int_import1_help orig_to_pn local_to_pn acc orig_name
+
+doIfaceImport1 orig_to_pn local_to_pn acc (IEClsWithOps orig_name _)
+ = int_import1_help orig_to_pn local_to_pn acc orig_name
+
doIfaceImport1 orig_to_pn local_to_pn (v_bag, tc_bag) other
= panic "Rename1: strange import decl"
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
import ProtoName(ProtoName)
import SrcLoc(SrcLoc)
-data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
+data Module a b
+data Bag a
+data InPat a
type ProtoNamePat = InPat ProtoName
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
+data PrettyRep
+data ProtoName
rnModule2 :: Module ProtoName (InPat ProtoName) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (Module ProtoName (InPat ProtoName), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(LLLSSSSSSLLSL)" _N_ _N_ #-}
interface Rename3 where
import AbsSyn(Module)
import Bag(Bag)
-import CharSeq(CSeq)
-import CmdLineOpts(GlobalSwitch)
import FiniteMap(FiniteMap)
import HsBinds(Binds, Sig)
import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
import NameTypes(FullName, ShortName)
import Outputable(ExportFlag)
import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
+import Pretty(PprStyle, Pretty(..), PrettyRep)
import ProtoName(ProtoName)
import RenameAuxFuns(PreludeNameFun(..), PreludeNameFuns(..))
import RenameMonad3(Rn3M(..), initRn3)
import SrcLoc(SrcLoc)
import TyCon(TyCon)
import Unique(Unique)
-data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
+data Module a b
+data Bag a
+data InPat a
type ProtoNamePat = InPat ProtoName
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data Labda a
+data Name
+data ExportFlag
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
+data PrettyRep
+data ProtoName
type PreludeNameFun = _PackedString -> Labda Name
type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name)
type Rn3M a = (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
+data SplitUniqSupply
initRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> SplitUniqSupply -> a
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
rnModule3 :: (_PackedString -> Labda Name, _PackedString -> Labda Name) -> [_PackedString] -> Module ProtoName (InPat ProtoName) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> ([(ProtoName, Name)], [(ProtoName, Name)], ProtoName -> Labda Name, ProtoName -> Labda Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 6 _U_ 121001 _N_ _S_ "U(LL)LU(LLLASASAAALLA)AAU(ALS)" {_A_ 5 _U_ 22211 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import SrcLoc(SrcLoc)
import TyCon(TyCon)
import Unique(Unique)
-data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
+data Module a b
+data Bag a
type Error = PprStyle -> Int -> Bool -> PrettyRep
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
+data InPat a
type ProtoNamePat = InPat ProtoName
type RenamedPat = InPat Name
-data PolyType a {-# GHC_PRAGMA UnoverloadedTy (MonoType a) | OverloadedTy [(a, a)] (MonoType a) | ForAllTy [a] (MonoType a) #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data PolyType a
+data Labda a
+data Name
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
+data PrettyRep
+data ProtoName
type GlobalNameFun = ProtoName -> Labda Name
type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
type TyVarNamesEnv = [(ProtoName, Name)]
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
+data SplitUniqSupply
+data SrcLoc
initRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> SplitUniqSupply -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 4 _U_ 2212 _N_ _S_ "LLSL" _N_ _N_ #-}
rnGenPragmas4 :: GenPragmas ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (GenPragmas Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-}
rnModule4 :: Module ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Module Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 1222210 _N_ _S_ "U(LLASSSSSSSSSL)LLLLU(ALS)A" {_A_ 6 _U_ 122221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rnPolyType4 :: Bool -> Bool -> [(ProtoName, Name)] -> PolyType ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (PolyType Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 4 _U_ 2221222222 _N_ _S_ "LLLS" _N_ _N_ #-}
import Name(Name)
import PreludePS(_PackedString)
import ProtoName(ProtoName)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
+data Bag a
type GlobalNameFun = ProtoName -> Labda Name
type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name)
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
+data Labda a
type PreludeNameFun = _PackedString -> Labda Name
type PreludeNameFuns = (_PackedString -> Labda Name, _PackedString -> Labda Name)
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
+data ProtoName
mkGlobalNameFun :: _PackedString -> (_PackedString -> Labda Name) -> [(ProtoName, Name)] -> ProtoName -> Labda Name
- {-# GHC_PRAGMA _A_ 3 _U_ 2111 _N_ _N_ _N_ _N_ #-}
mkNameFun :: Bag (_PackedString, a) -> (_PackedString -> Labda a, [[(_PackedString, a)]])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface RenameBinds4 where
import Bag(Bag)
-import CharSeq(CSeq)
import CmdLineOpts(GlobalSwitch)
import ErrUtils(Error(..))
import FiniteMap(FiniteMap)
import Name(Name)
import NameTypes(FullName, ShortName)
import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
+import Pretty(PprStyle, Pretty(..), PrettyRep)
import ProtoName(ProtoName)
import RenameAuxFuns(GlobalNameFun(..))
import SplitUniq(SplitUniqSupply)
import UniqFM(UniqFM)
import UniqSet(UniqSet(..))
import Unique(Unique)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
+data Bag a
type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-}
+data Binds a b
type DefinedVars = UniqFM Name
type FreeVars = UniqFM Name
-data MonoBinds a b {-# GHC_PRAGMA EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc #-}
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data MonoBinds a b
+data InPat a
+data Labda a
+data Name
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
+data PrettyRep
+data ProtoName
type GlobalNameFun = ProtoName -> Labda Name
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data SplitUniqSupply
+data SrcLoc
+data UniqFM a
type UniqSet a = UniqFM a
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Unique
rnBinds4 :: Binds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((Binds Name (InPat Name), UniqFM Name, [Name]), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-}
rnMethodBinds4 :: Name -> MonoBinds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (MonoBinds Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 2 _U_ 22222222 _N_ _S_ "LS" _N_ _N_ #-}
rnTopBinds4 :: Binds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Binds Name (InPat Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-}
case (inline_sigs_in_recursive_binds final_binds) of
Nothing -> happy_answer
Just names_n_locns ->
- addErrRn4 (inlineInRecursiveBindsErr names_n_locns) `thenRn4_`
+-- SLPJ: sometimes want recursive INLINE for worker wrapper style stuff
+-- addErrRn4 (inlineInRecursiveBindsErr names_n_locns) `thenRn4_`
{-not so-}happy_answer
where
f :: (a,b, FreeVars, c,d) -> FreeVars -> FreeVars
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface RenameExpr4 where
import Bag(Bag)
-import CharSeq(CSeq)
import CmdLineOpts(GlobalSwitch)
import FiniteMap(FiniteMap)
import HsBinds(Binds)
import Name(Name)
import NameTypes(FullName, ShortName)
import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
+import Pretty(PprStyle, Pretty(..), PrettyRep)
import ProtoName(ProtoName)
import RenameAuxFuns(GlobalNameFun(..))
import SplitUniq(SplitUniqSupply)
import UniqFM(UniqFM)
import UniqSet(UniqSet(..))
import Unique(Unique)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data GRHSsAndBinds a b {-# GHC_PRAGMA GRHSsAndBindsIn [GRHS a b] (Binds a b) | GRHSsAndBindsOut [GRHS a b] (Binds a b) UniType #-}
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data Bag a
+data GRHSsAndBinds a b
+data InPat a
+data Labda a
+data Name
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
+data PrettyRep
+data ProtoName
type GlobalNameFun = ProtoName -> Labda Name
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data SplitUniqSupply
+data SrcLoc
+data UniqFM a
type UniqSet a = UniqFM a
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Unique
rnGRHSsAndBinds4 :: GRHSsAndBinds ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((GRHSsAndBinds Name (InPat Name), UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-}
rnMatch4 :: Match ProtoName (InPat ProtoName) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((Match Name (InPat Name), UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 2222222 _N_ _S_ "S" _N_ _N_ #-}
rnPat4 :: InPat ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (InPat Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-}
import PreludePS(_PackedString)
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
infixr 9 `thenRn12`
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data Bag a
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
+data PrettyRep
type Rn12M a = _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
addErrRn12 :: (PprStyle -> Int -> Bool -> PrettyRep) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ((), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _S_ "LAL" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
foldrRn12 :: (a -> b -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> b -> [a] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 3 _U_ 22122 _N_ _S_ "LLS" _N_ _N_ #-}
getModuleNameRn12 :: _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (_PackedString, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _TUP_2 [_PackedString, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u0, u1] _N_ #-}
initRn12 :: _PackedString -> (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _F_ _IF_ARGS_ 1 2 XX 5 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> let {(u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) = _!_ _ORIG_ Bag EmptyBag [(PprStyle -> Int -> Bool -> PrettyRep)] []} in _APP_ u2 [ u1, u3 ] _N_ #-}
mapRn12 :: (a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ([b], Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
recoverQuietlyRn12 :: a -> (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _N_ _N_ _N_ #-}
returnRn12 :: a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _PackedString) (u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _TUP_2 [u0, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u1, u3] _N_ #-}
thenRn12 :: (_PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "SSLL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: u0 -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (u1, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u4 :: _PackedString) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> case _APP_ u2 [ u4, u5 ] of { _ALG_ _TUP_2 (u6 :: u0) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ u6, u4, u7 ]; _NO_DEFLT_ } _N_ #-}
zipWithRn12 :: (a -> b -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> (c, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> [b] -> _PackedString -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> ([c], Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 3 _U_ 21122 _N_ _S_ "LSS" _N_ _N_ #-}
import HsImpExp(IE)
import Maybes(Labda)
import Name(Name)
-import NameTypes(FullName, Provenance)
+import NameTypes(FullName)
import Outputable(ExportFlag)
import PreludePS(_PackedString)
import ProtoName(ProtoName)
-import SplitUniq(SplitUniqSupply, splitUniqSupply)
+import SplitUniq(SplitUniqSupply)
import SrcLoc(SrcLoc)
import Unique(Unique)
infixr 9 `thenRn3`
-data IE {-# GHC_PRAGMA IEVar _PackedString | IEThingAbs _PackedString | IEThingAll _PackedString | IEConWithCons _PackedString [_PackedString] | IEClsWithOps _PackedString [_PackedString] | IEModuleContents _PackedString #-}
-data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-}
-data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
+data IE
+data FullName
+data ExportFlag
+data ProtoName
type Rn3M a = (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data SplitUniqSupply
+data Unique
andRn3 :: (a -> a -> a) -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
- {-# GHC_PRAGMA _A_ 6 _U_ 111221 _N_ _S_ "SLLLLU(ALL)" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0 -> u0 -> u0) (u2 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u0) (u3 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u0) (u4 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) (u5 :: _PackedString) (u6 :: SplitUniqSupply) -> case u6 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u7 :: Int) (u8 :: SplitUniqSupply) (u9 :: SplitUniqSupply) -> let {(ua :: u0) = _APP_ u2 [ u4, u5, u8 ]} in let {(ub :: u0) = _APP_ u3 [ u4, u5, u9 ]} in _APP_ u1 [ ua, ub ]; _NO_DEFLT_ } _N_ #-}
fixRn3 :: (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "SLLL" _F_ _IF_ARGS_ 1 4 XXXX 7 _/\_ u0 -> \ (u1 :: u0 -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u0) (u2 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) (u3 :: _PackedString) (u4 :: SplitUniqSupply) -> _LETREC_ {(u5 :: u0) = _APP_ u1 [ u5, u2, u3, u4 ]} in u5 _N_ #-}
initRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> SplitUniqSupply -> a
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
mapRn3 :: (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b) -> [a] -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> [b]
- {-# GHC_PRAGMA _A_ 2 _U_ 21222 _N_ _S_ "LS" _N_ _N_ #-}
newFullNameM3 :: ProtoName -> SrcLoc -> Bool -> Labda ExportFlag -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> (Unique, FullName)
- {-# GHC_PRAGMA _A_ 7 _U_ 1211121 _N_ _N_ _N_ _N_ #-}
newInvisibleNameM3 :: ProtoName -> SrcLoc -> Bool -> Labda ExportFlag -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> (Unique, FullName)
- {-# GHC_PRAGMA _A_ 7 _U_ 1211121 _N_ _N_ _N_ _N_ #-}
putInfoDownM3 :: _PackedString -> [IE] -> ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
- {-# GHC_PRAGMA _A_ 6 _U_ 221002 _N_ _S_ "LLSAAL" {_A_ 4 _U_ 2212 _N_ _N_ _F_ _IF_ARGS_ 1 4 XXXX 7 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: [IE]) (u3 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u0) (u4 :: SplitUniqSupply) -> let {(u5 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) = _APP_ _ORIG_ HsImpExp getIEStrings [ u2 ]} in _APP_ u3 [ u5, u1, u4 ] _N_} _F_ _IF_ARGS_ 1 6 XXXXXX 7 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: [IE]) (u3 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u0) (u4 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) (u5 :: _PackedString) (u6 :: SplitUniqSupply) -> let {(u7 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) = _APP_ _ORIG_ HsImpExp getIEStrings [ u2 ]} in _APP_ u3 [ u7, u1, u6 ] _N_ #-}
returnRn3 :: a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a
- {-# GHC_PRAGMA _A_ 4 _U_ 1000 _N_ _S_ "SLLL" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) (u3 :: _PackedString) (u4 :: SplitUniqSupply) -> u1 _N_ #-}
-splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-}
thenRn3 :: ((FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> a) -> (a -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b) -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> b
- {-# GHC_PRAGMA _A_ 5 _U_ 11221 _N_ _S_ "LSLLU(ALL)" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u0) (u3 :: u0 -> (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ()) -> _PackedString -> SplitUniqSupply -> u1) (u4 :: (FiniteMap _PackedString ExportFlag, FiniteMap _PackedString ())) (u5 :: _PackedString) (u6 :: SplitUniqSupply) -> case u6 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u7 :: Int) (u8 :: SplitUniqSupply) (u9 :: SplitUniqSupply) -> let {(ua :: u0) = _APP_ u2 [ u4, u5, u8 ]} in _APP_ u3 [ ua, u4, u5, u9 ]; _NO_DEFLT_ } _N_ #-}
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
import ProtoName(ProtoName)
import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..))
-import SplitUniq(SplitUniqSupply, splitUniqSupply)
+import SplitUniq(SplitUniqSupply)
import SrcLoc(SrcLoc)
import TyCon(TyCon)
import UniqFM(UniqFM)
import Unique(Unique)
infixr 9 `thenRn4`
infixr 9 `thenRn4_`
-data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
+data Module a b
+data Bag a
+data GlobalSwitch
type Error = PprStyle -> Int -> Bool -> PrettyRep
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
+data InPat a
type RenamedPat = InPat Name
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data Labda a
+data Name
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
+data PrettyRep
+data ProtoName
type GlobalNameFun = ProtoName -> Labda Name
type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name)
type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
+data SplitUniqSupply
+data SrcLoc
type TyVarNamesEnv = [(ProtoName, Name)]
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data UniqFM a
type UniqSet a = UniqFM a
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Unique
addErrRn4 :: (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 2000200 _N_ _S_ "LAAALAA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 XXXXXXX 9 \ (u0 :: PprStyle -> Int -> Bool -> PrettyRep) (u1 :: GlobalSwitch -> Bool) (u2 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u3 :: FiniteMap _PackedString Name) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SplitUniqSupply) (u6 :: SrcLoc) -> let {(u7 :: ()) = _!_ _TUP_0 [] []} in let {(u8 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) = _APP_ _TYAPP_ _ORIG_ Bag snocBag { (PprStyle -> Int -> Bool -> PrettyRep) } [ u4, u0 ]} in _!_ _TUP_2 [(), (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u7, u8] _N_ #-}
andRn4 :: (a -> a -> a) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 9 _U_ 111222212 _N_ _S_ "LSSLLLLU(ALL)L" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0 -> u0 -> u0) (u2 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u4 :: GlobalSwitch -> Bool) (u5 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u6 :: FiniteMap _PackedString Name) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SplitUniqSupply) (u9 :: SrcLoc) -> case u8 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ u4, u5, u6, u7, ub, u9 ] of { _ALG_ _TUP_2 (ud :: u0) (ue :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> case _APP_ u3 [ u4, u5, u6, ue, uc, u9 ] of { _ALG_ _TUP_2 (uf :: u0) (ug :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> let {(uh :: u0) = _APP_ u1 [ ud, uf ]} in _!_ _TUP_2 [u0, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [uh, ug]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
catTyVarNamesEnvs :: [(ProtoName, Name)] -> [(ProtoName, Name)] -> [(ProtoName, Name)]
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ PreludeList (++) { (ProtoName, Name) } _N_ #-}
domTyVarNamesEnv :: [(ProtoName, Name)] -> [ProtoName]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
extendSS :: [Name] -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 11222222 _N_ _S_ "LSSLLLLL" _N_ _N_ #-}
extendSS2 :: [Name] -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((a, UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((a, UniqFM Name), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 21222222 _N_ _S_ "LSSLLLLL" _N_ _N_ #-}
failButContinueRn4 :: a -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 22000200 _N_ _S_ "LLAAALAA" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 1 8 XXXXXXXX 7 _/\_ u0 -> \ (u1 :: u0) (u2 :: PprStyle -> Int -> Bool -> PrettyRep) (u3 :: GlobalSwitch -> Bool) (u4 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u5 :: FiniteMap _PackedString Name) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SplitUniqSupply) (u8 :: SrcLoc) -> let {(u9 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) = _APP_ _TYAPP_ _ORIG_ Bag snocBag { (PprStyle -> Int -> Bool -> PrettyRep) } [ u6, u2 ]} in _!_ _TUP_2 [u0, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u1, u9] _N_ #-}
getSrcLocRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (SrcLoc, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 6 _U_ 000202 _N_ _S_ "AAALAL" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u1 :: SrcLoc) -> _!_ _TUP_2 [SrcLoc, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u1, u0] _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 3 \ (u0 :: GlobalSwitch -> Bool) (u1 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u2 :: FiniteMap _PackedString Name) (u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u4 :: SplitUniqSupply) (u5 :: SrcLoc) -> _!_ _TUP_2 [SrcLoc, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u5, u3] _N_ #-}
getSwitchCheckerRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (GlobalSwitch -> Bool, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 6 _U_ 200200 _N_ _S_ "LAALAA" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: GlobalSwitch -> Bool) (u1 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _TUP_2 [(GlobalSwitch -> Bool), (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u0, u1] _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 3 \ (u0 :: GlobalSwitch -> Bool) (u1 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u2 :: FiniteMap _PackedString Name) (u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u4 :: SplitUniqSupply) (u5 :: SrcLoc) -> _!_ _TUP_2 [(GlobalSwitch -> Bool), (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u0, u3] _N_ #-}
initRn4 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> SplitUniqSupply -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 4 _U_ 2212 _N_ _S_ "LLSL" _N_ _N_ #-}
lookupClass :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 2010202 _N_ _S_ "LAU(AS)ALAL" {_A_ 4 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupClassOp :: Name -> ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 22010202 _N_ _S_ "LLAU(SA)ALAL" {_A_ 5 _U_ 22122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupFixityOp :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Labda Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 3 _U_ 2012222 _N_ _S_ "SAU(LA)" {_A_ 2 _U_ 212222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupTyCon :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 2010212 _N_ _S_ "SALALU(AAA)L" {_A_ 4 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupTyConEvenIfInvisible :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 2010202 _N_ _S_ "SALALAL" {_A_ 4 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupTyVarName :: [(ProtoName, Name)] -> ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 12000212 _N_ _S_ "SLAAALLL" {_A_ 5 _U_ 12212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupValue :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 2012212 _N_ _S_ "SAU(LA)LLU(AAA)L" {_A_ 5 _U_ 21222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupValueEvenIfInvisible :: ProtoName -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (Name, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 2012202 _N_ _S_ "SAU(LA)LLAL" {_A_ 5 _U_ 21222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mapAndUnzipRn4 :: (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ((b, c), Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (([b], [c]), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
mapRn4 :: (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ([b], Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
mkTyVarNamesEnv :: SrcLoc -> [ProtoName] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (([(ProtoName, Name)], [Name]), Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 22222212 _N_ _S_ "LSLLLLU(ASA)L" _N_ _N_ #-}
namesFromProtoNames :: [Char] -> [(ProtoName, SrcLoc)] -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> ([Name], Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 22222212 _N_ _S_ "LSLLLLU(ALS)L" _N_ _N_ #-}
nullTyVarNamesEnv :: [(ProtoName, Name)]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _NIL_ [(ProtoName, Name)] [] _N_ #-}
pushSrcLocRn4 :: SrcLoc -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 21222220 _N_ _S_ "LSLLLLLA" {_A_ 7 _U_ 2122222 _N_ _N_ _F_ _IF_ARGS_ 1 7 XXXXXXX 7 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: GlobalSwitch -> Bool) (u4 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u5 :: FiniteMap _PackedString Name) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SplitUniqSupply) -> _APP_ u2 [ u3, u4, u5, u6, u7, u1 ] _N_} _F_ _IF_ARGS_ 1 8 XXXXXXXX 7 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: GlobalSwitch -> Bool) (u4 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u5 :: FiniteMap _PackedString Name) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SplitUniqSupply) (u8 :: SrcLoc) -> _APP_ u2 [ u3, u4, u5, u6, u7, u1 ] _N_ #-}
recoverQuietlyRn4 :: a -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 21222222 _N_ _N_ _N_ _N_ #-}
returnRn4 :: a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 2000200 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: GlobalSwitch -> Bool) (u3 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u4 :: FiniteMap _PackedString Name) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: SplitUniqSupply) (u7 :: SrcLoc) -> _!_ _TUP_2 [u0, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u1, u5] _N_ #-}
-splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-}
thenRn4 :: ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 11222212 _N_ _S_ "SSLLLLU(ALL)L" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: u0 -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u1, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u4 :: GlobalSwitch -> Bool) (u5 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u6 :: FiniteMap _PackedString Name) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SplitUniqSupply) (u9 :: SrcLoc) -> case u8 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ u4, u5, u6, u7, ub, u9 ] of { _ALG_ _TUP_2 (ud :: u0) (ue :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ ud, u4, u5, u6, ue, uc, u9 ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
thenRn4_ :: ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (b, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 11222212 _N_ _S_ "SSLLLLU(ALL)L" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u0, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (u1, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u4 :: GlobalSwitch -> Bool) (u5 :: (ProtoName -> Labda Name, ProtoName -> Labda Name)) (u6 :: FiniteMap _PackedString Name) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SplitUniqSupply) (u9 :: SrcLoc) -> case u8 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ u4, u5, u6, u7, ub, u9 ] of { _ALG_ _TUP_2 (ud :: u0) (ue :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ u4, u5, u6, ue, uc, u9 ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
#ifdef __GLASGOW_HASKELL__
{-# INLINE andRn4 #-}
{-# INLINE thenRn4 #-}
+{-# INLINE thenLazilyRn4 #-}
{-# INLINE thenRn4_ #-}
{-# INLINE returnRn4 #-}
#endif
initRn4 sw_chkr gnfs renamer init_us
= renamer sw_chkr gnfs emptyFM emptyBag init_us mkUnknownSrcLoc
-thenRn4 :: Rn4M a -> (a -> Rn4M b) -> Rn4M b
+thenRn4, thenLazilyRn4
+ :: Rn4M a -> (a -> Rn4M b) -> Rn4M b
thenRn4_ :: Rn4M a -> Rn4M b -> Rn4M b
andRn4 :: (a -> a -> a) -> Rn4M a -> Rn4M a -> Rn4M a
case (cont res1 sw_chkr gnfs ss errs1 s2 locn) of { (res2, errs2) ->
(res2, errs2) }}}
+thenLazilyRn4 expr cont sw_chkr gnfs ss errs uniqs locn
+ = let
+ (s1, s2) = splitUniqSupply uniqs
+ (res1, errs1) = expr sw_chkr gnfs ss errs s1 locn
+ (res2, errs2) = cont res1 sw_chkr gnfs ss errs1 s2 locn
+ in
+ (res2, errs2)
+
thenRn4_ expr cont sw_chkr gnfs ss errs uniqs locn
= case (splitUniqSupply uniqs) of { (s1, s2) ->
case (expr sw_chkr gnfs ss errs s1 locn) of { (_, errs1) ->
\begin{code}
lookupValue v {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
- = (lookup_val v `thenRn4` \ name ->
+ = (lookup_val v `thenLazilyRn4` \ name ->
if invisibleName name
then failButContinueRn4 (unboundName v) (unknownNameErr "value" v mkUnknownSrcLoc)
else returnRn4 name
-- The global name funs handle Prel things
lookupTyCon tc {-Rn4-} sw_chkr gnfs ss errs_so_far us locn
- = (lookup_tycon tc `thenRn4` \ name ->
+ = (lookup_tycon tc `thenLazilyRn4` \ name ->
if invisibleName name
then failButContinueRn4 (unboundName tc) (unknownNameErr "type constructor" tc mkUnknownSrcLoc)
else returnRn4 name
import CoreSyn(CoreBinding)
import Id(Id)
analFBWW :: (GlobalSwitch -> Bool) -> [CoreBinding Id Id] -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _N_ _N_ _N_ #-}
interface BinderInfo where
import Outputable(Outputable)
data BinderInfo = DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int
-data DuplicationDanger {-# GHC_PRAGMA DupDanger | NoDupDanger #-}
-data FunOrArg {-# GHC_PRAGMA FunOcc | ArgOcc #-}
-data InsideSCC {-# GHC_PRAGMA InsideSCC | NotInsideSCC #-}
+data DuplicationDanger
+data FunOrArg
+data InsideSCC
argOccurrence :: Int -> BinderInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
combineAltsBinderInfo :: BinderInfo -> BinderInfo -> BinderInfo
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
combineBinderInfo :: BinderInfo -> BinderInfo -> BinderInfo
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
funOccurrence :: Int -> BinderInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
getBinderInfoArity :: BinderInfo -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: BinderInfo) -> case u0 of { _ALG_ _ORIG_ BinderInfo DeadCode -> _!_ I# [] [0#]; _ORIG_ BinderInfo ManyOcc (u1 :: Int) -> u1; _ORIG_ BinderInfo OneOcc (u2 :: FunOrArg) (u3 :: DuplicationDanger) (u4 :: InsideSCC) (u5 :: Int) (u6 :: Int) -> u6; _NO_DEFLT_ } _N_ #-}
inlineUnconditionally :: Bool -> BinderInfo -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-}
isDupDanger :: DuplicationDanger -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: DuplicationDanger) -> case u0 of { _ALG_ _ORIG_ BinderInfo NoDupDanger -> _!_ False [] []; _ORIG_ BinderInfo DupDanger -> _!_ True [] []; _NO_DEFLT_ } _N_ #-}
isFun :: FunOrArg -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: FunOrArg) -> case u0 of { _ALG_ _ORIG_ BinderInfo ArgOcc -> _!_ False [] []; _ORIG_ BinderInfo FunOcc -> _!_ True [] []; _NO_DEFLT_ } _N_ #-}
markDangerousToDup :: BinderInfo -> BinderInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
markInsideSCC :: BinderInfo -> BinderInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
markMany :: BinderInfo -> BinderInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
oneSafeOcc :: Bool -> BinderInfo -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-}
oneTextualOcc :: Bool -> BinderInfo -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-}
setBinderInfoArityToZero :: BinderInfo -> BinderInfo
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
instance Outputable BinderInfo
- {-# GHC_PRAGMA _M_ BinderInfo {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BinderInfo) _N_
- ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import SplitUniq(SplitUniqSupply)
import UniType(UniType)
completePrim :: SimplEnv -> PrimOp -> [UniType] -> [CoreAtom Id] -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
- {-# GHC_PRAGMA _A_ 4 _U_ 122222 _N_ _S_ "LSLS" _N_ _N_ #-}
ToDo:
check boundaries before folding, e.g. we can fold the Float addition
(i1 + i2) only if it results in a valid Float.
- See the @IntDivOp@ below.
\begin{code}
#include "HsVersions.h"
don't let the simplifier know that. We also use a special error
value, parError#, which is *not* a bottoming Id, so as far as the
simplifier is concerned, we have to evaluate seq# a before we know
-whether or not b will be evaluated.
+whether or not y will be evaluated.
+
+If we didn't have the extra case, then after inlining the compiler might
+see:
+ f p q = case seq# p of { _ -> p+q }
+
+If it sees that, it can see that f is strict in q, and hence it might
+evaluate q before p! The "0# ->" case prevents this happening.
+By having the parError# branch we make sure that anything in the
+other branch stays there!
This is fine, but we'd like to get rid of the extraneous code. Hence,
we *do* let the simplifier know that seq# is strict in its argument.
twoIntLits IntSubOp i1 i2 = return_int (i1-i2)
twoIntLits IntMulOp i1 i2 = return_int (i1*i2)
twoIntLits IntQuotOp i1 i2 | i2 /= 0 = return_int (i1 `quot` i2)
- twoIntLits IntDivOp i1 i2 | i2 /= 0 = return_int (i1 `div` i2)
twoIntLits IntRemOp i1 i2 | i2 /= 0 = return_int (i1 `rem` i2)
twoIntLits IntGtOp i1 i2 = return_bool (i1 > i2)
twoIntLits IntGeOp i1 i2 = return_bool (i1 >= i2)
import BasicLit(BasicLit)
import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import PlainCore(PlainCoreExpr(..), PlainCoreProgram(..))
import PrimOps(PrimOp)
import TyVar(TyVar)
import UniType(UniType)
-import Unique(Unique)
-data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data CoreBinding a b
+data CoreExpr a b
+data Id
type PlainCoreExpr = CoreExpr Id Id
type PlainCoreProgram = [CoreBinding Id Id]
floatInwards :: [CoreBinding Id Id] -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
import Id(Id)
import SplitUniq(SplitUniqSupply)
floatOutwards :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding Id Id] -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "SLS" _N_ _N_ #-}
floatOutwards sw_chker us pgm
= case (setLevels pgm sw_chker us) of { annotated_w_levels ->
- case unzip3 (map (floatTopBind sw_chker) annotated_w_levels)
- of { (fcs, lcs, final_toplev_binds_s) ->
+ case unzip (map (floatTopBind sw_chker) annotated_w_levels)
+ of { (fss, final_toplev_binds_s) ->
(if sw_chker D_verbose_core2core
then pprTrace "Levels added:\n" (ppr PprDebug annotated_w_levels)
else id
)
- ( if sw_chker D_simplifier_stats
- then pprTrace "FloatOut stats: " (ppBesides [
- ppInt (sum fcs), ppStr " Lets floated out of ",
- ppInt (sum lcs), ppStr " Lambdas"])
- else id
+ ( if not (sw_chker D_simplifier_stats) then
+ id
+ else
+ let
+ (tlets, ntlets, lams) = get_stats (sum_stats fss)
+ in
+ pprTrace "FloatOut stats: " (ppBesides [
+ ppInt tlets, ppStr " Lets floated to top level; ",
+ ppInt ntlets, ppStr " Lets floated elsewhere; from ",
+ ppInt lams, ppStr " Lambda groups"])
)
concat final_toplev_binds_s
}}
floatTopBind sw bind@(CoNonRec _ _)
- = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fc,lc, floats, bind', _) ->
- (fc,lc, floatsToBinds floats ++ [bind'])
+ = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, bind', _) ->
+ (fs, floatsToBinds floats ++ [bind'])
}
floatTopBind sw bind@(CoRec _)
- = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fc,lc, floats, CoRec pairs', _) ->
+ = case (floatBind sw nullIdEnv tOP_LEVEL bind) of { (fs, floats, CoRec pairs', _) ->
-- Actually floats will be empty
--false:ASSERT(null floats)
- (fc,lc, [CoRec (floatsToBindPairs floats ++ pairs')])
+ (fs, [CoRec (floatsToBindPairs floats ++ pairs')])
}
\end{code}
-> IdEnv Level
-> Level
-> LevelledBind
- -> (Int,Int, FloatingBinds, PlainCoreBinding, IdEnv Level)
+ -> (FloatStats, FloatingBinds, PlainCoreBinding, IdEnv Level)
floatBind sw env lvl (CoNonRec (name,level) rhs)
- = case (floatExpr sw env level rhs) of { (fc,lc, rhs_floats, rhs') ->
+ = case (floatExpr sw env level rhs) of { (fs, rhs_floats, rhs') ->
-- A good dumping point
case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
- (fc,lc, rhs_floats',CoNonRec name (install heres rhs'), addOneToIdEnv env name level)
+ (fs, rhs_floats',CoNonRec name (install heres rhs'), addOneToIdEnv env name level)
}}
floatBind sw env lvl bind@(CoRec pairs)
- = case (unzip4 (map do_pair pairs)) of { (fcs,lcs, rhss_floats, new_pairs) ->
+ = case (unzip3 (map do_pair pairs)) of { (fss, rhss_floats, new_pairs) ->
if not (isTopLvl bind_level) then
-- Standard case
- (sum fcs,sum lcs, concat rhss_floats, CoRec new_pairs, new_env)
+ (sum_stats fss, concat rhss_floats, CoRec new_pairs, new_env)
else
{- In a recursive binding, destined for the top level (only),
the rhs floats may contain
with the top binding. Later dependency analysis will unravel it.
-}
- (sum fcs,sum lcs, [],
+ (sum_stats fss,
+ [],
CoRec (new_pairs ++ floatsToBindPairs (concat rhss_floats)),
new_env)
bind_level = getBindLevel bind
do_pair ((name, level), rhs)
- = case (floatExpr sw new_env level rhs) of { (fc,lc, rhs_floats, rhs') ->
+ = case (floatExpr sw new_env level rhs) of { (fs, rhs_floats, rhs') ->
-- A good dumping point
case (partitionByMajorLevel level rhs_floats) of { (rhs_floats', heres) ->
- (fc,lc, rhs_floats', (name, install heres rhs'))
+ (fs, rhs_floats', (name, install heres rhs'))
}}
\end{code}
-> IdEnv Level
-> Level
-> LevelledExpr
- -> (Int,Int, FloatingBinds, PlainCoreExpr)
+ -> (FloatStats, FloatingBinds, PlainCoreExpr)
-floatExpr sw env _ (CoVar v) = (0,0, [], CoVar v)
+floatExpr sw env _ (CoVar v) = (zero_stats, [], CoVar v)
-floatExpr sw env _ (CoLit l) = (0,0, [], CoLit l)
+floatExpr sw env _ (CoLit l) = (zero_stats, [], CoLit l)
-floatExpr sw env _ (CoPrim op ty as) = (0,0, [], CoPrim op ty as)
-floatExpr sw env _ (CoCon con ty as) = (0,0, [], CoCon con ty as)
+floatExpr sw env _ (CoPrim op ty as) = (zero_stats, [], CoPrim op ty as)
+floatExpr sw env _ (CoCon con ty as) = (zero_stats, [], CoCon con ty as)
floatExpr sw env lvl (CoApp e a)
- = case (floatExpr sw env lvl e) of { (fc,lc, floating_defns, e') ->
- (fc,lc, floating_defns, CoApp e' a) }
+ = case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
+ (fs, floating_defns, CoApp e' a) }
floatExpr sw env lvl (CoTyApp e ty)
- = case (floatExpr sw env lvl e) of { (fc,lc, floating_defns, e') ->
- (fc,lc, floating_defns, CoTyApp e' ty) }
+ = case (floatExpr sw env lvl e) of { (fs, floating_defns, e') ->
+ (fs, floating_defns, CoTyApp e' ty) }
floatExpr sw env lvl (CoTyLam tv e)
= let
incd_lvl = incMinorLvl lvl
in
- case (floatExpr sw env incd_lvl e) of { (fc,lc, floats, e') ->
+ case (floatExpr sw env incd_lvl e) of { (fs, floats, e') ->
-- Dump any bindings which absolutely cannot go any further
case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
- (fc,lc, floats', CoTyLam tv (install heres e'))
+ (fs, floats', CoTyLam tv (install heres e'))
}}
floatExpr sw env lvl (CoLam args@((_,incd_lvl):_) rhs)
args' = map fst args
new_env = growIdEnvList env args
in
- case (floatExpr sw new_env incd_lvl rhs) of { (fc,lc, floats, rhs') ->
+ case (floatExpr sw new_env incd_lvl rhs) of { (fs, floats, rhs') ->
-- Dump any bindings which absolutely cannot go any further
case (partitionByLevel incd_lvl floats) of { (floats', heres) ->
- (fc + length floats', lc + 1,
- floats', mkCoLam args' (install heres rhs'))
+ (add_to_stats fs floats',
+ floats',
+ mkCoLam args' (install heres rhs'))
}}
floatExpr sw env lvl (CoSCC cc expr)
- = case (floatExpr sw env lvl expr) of { (fc,lc, floating_defns, expr') ->
+ = case (floatExpr sw env lvl expr) of { (fs, floating_defns, expr') ->
let
-- annotate bindings floated outwards past an scc expression
-- with the cc. We mark that cc as "duplicated", though.
annotated_defns = annotate (dupifyCC cc) floating_defns
in
- (fc,lc, annotated_defns, CoSCC cc expr') }
+ (fs, annotated_defns, CoSCC cc expr') }
where
annotate :: CostCentre -> FloatingBinds -> FloatingBinds
-- cost centre stack profiling (Durham)
floatExpr sw env lvl (CoLet bind body)
- = case (floatBind sw env lvl bind) of { (fcb,lcb, rhs_floats, bind', new_env) ->
- case (floatExpr sw new_env lvl body) of { (fce,lce, body_floats, body') ->
- (fcb + fce, lcb + lce,
- rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats, body')
+ = case (floatBind sw env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
+ case (floatExpr sw new_env lvl body) of { (fse, body_floats, body') ->
+ (add_stats fsb fse,
+ rhs_floats ++ [(bind_lvl, LetFloater bind')] ++ body_floats,
+ body')
}}
where
bind_lvl = getBindLevel bind
floatExpr sw env lvl (CoCase scrut alts)
- = case (floatExpr sw env lvl scrut) of { (fce,lce, fde, scrut') ->
+ = case (floatExpr sw env lvl scrut) of { (fse, fde, scrut') ->
case (scrut', float_alts alts) of
END OF CASE FLOATING DROPPED -}
- (_, (fca,lca, fda, alts')) ->
+ (_, (fsa, fda, alts')) ->
- (fce + fca, lce + lca, fda ++ fde, CoCase scrut' alts')
+ (add_stats fse fsa, fda ++ fde, CoCase scrut' alts')
}
where
incd_lvl = incMinorLvl lvl
-}
float_alts (CoAlgAlts alts deflt)
- = case (float_deflt deflt) of { (fcd,lcd, fdd, deflt') ->
- case (unzip4 (map float_alg_alt alts)) of { (fcas,lcas, fdas, alts') ->
- (fcd + sum fcas, lcd + sum lcas,
- concat fdas ++ fdd, CoAlgAlts alts' deflt') }}
+ = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
+ case (unzip3 (map float_alg_alt alts)) of { (fsas, fdas, alts') ->
+ (foldr add_stats fsd fsas,
+ concat fdas ++ fdd,
+ CoAlgAlts alts' deflt') }}
float_alts (CoPrimAlts alts deflt)
- = case (float_deflt deflt) of { (fcd,lcd, fdd, deflt') ->
- case (unzip4 (map float_prim_alt alts)) of { (fcas,lcas, fdas, alts') ->
- (fcd + sum fcas, lcd + sum lcas,
- concat fdas ++ fdd, CoPrimAlts alts' deflt') }}
+ = case (float_deflt deflt) of { (fsd, fdd, deflt') ->
+ case (unzip3 (map float_prim_alt alts)) of { (fsas, fdas, alts') ->
+ (foldr add_stats fsd fsas,
+ concat fdas ++ fdd,
+ CoPrimAlts alts' deflt') }}
-------------
float_alg_alt (con, bs, rhs)
bs' = map fst bs
new_env = growIdEnvList env bs
in
- case (floatExpr sw new_env incd_lvl rhs) of { (fc,lc, rhs_floats, rhs') ->
+ case (floatExpr sw new_env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
- (fc, lc, rhs_floats', (con, bs', install heres rhs'))
- }}
+ (fs, rhs_floats', (con, bs', install heres rhs')) }}
--------------
float_prim_alt (lit, rhs)
- = case (floatExpr sw env incd_lvl rhs) of { (fc,lc, rhs_floats, rhs') ->
+ = case (floatExpr sw env incd_lvl rhs) of { (fs, rhs_floats, rhs') ->
case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
- (fc,lc, rhs_floats', (lit, install heres rhs'))
- }}
+ (fs, rhs_floats', (lit, install heres rhs')) }}
--------------
- float_deflt CoNoDefault = (0,0, [], CoNoDefault)
+ float_deflt CoNoDefault = (zero_stats, [], CoNoDefault)
float_deflt (CoBindDefault (b,lvl) rhs)
- = case (floatExpr sw new_env lvl rhs) of { (fc,lc, rhs_floats, rhs') ->
+ = case (floatExpr sw new_env lvl rhs) of { (fs, rhs_floats, rhs') ->
case (partition_fn incd_lvl rhs_floats) of { (rhs_floats', heres) ->
- (fc,lc, rhs_floats', CoBindDefault b (install heres rhs'))
- }}
+ (fs, rhs_floats', CoBindDefault b (install heres rhs')) }}
where
new_env = addOneToIdEnv env b lvl
\end{code}
%************************************************************************
%* *
-\subsection[FloatOut-utils]{Utility bits for floating}
+\subsection{Utility bits for floating stats}
+%* *
+%************************************************************************
+
+I didn't implement this with unboxed numbers. I don't want to be too
+strict in this stuff, as it is rarely turned on. (WDP 95/09)
+
+\begin{code}
+data FloatStats
+ = FlS Int -- Number of top-floats * lambda groups they've been past
+ Int -- Number of non-top-floats * lambda groups they've been past
+ Int -- Number of lambda (groups) seen
+
+get_stats (FlS a b c) = (a, b, c)
+
+zero_stats = FlS 0 0 0
+
+sum_stats xs = foldr add_stats zero_stats xs
+
+add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
+ = FlS (a1 + a2) (b1 + b2) (c1 + c2)
+
+add_to_stats (FlS a b c) floats
+ = FlS (a + length top_floats) (b + length other_floats) (c + 1)
+ where
+ (top_floats, other_floats) = partition to_very_top floats
+
+ to_very_top (my_lvl, _) = isTopLvl my_lvl
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Utility bits for floating}
%* *
%************************************************************************
import Id(Id)
import SplitUniq(SplitUniqSupply)
mkFoldrBuildWW :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding Id Id] -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LU(ALA)S" {_A_ 3 _U_ 221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import CoreSyn(CoreBinding)
import Id(Id)
liberateCase :: Int -> [CoreBinding Id Id] -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface MagicUFs where
import BasicLit(BasicLit)
-import Class(Class)
-import CmdLineOpts(SimplifierSwitch, SwitchResult)
import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Maybes(Labda)
import PlainCore(PlainCoreArg(..), PlainCoreAtom(..), PlainCoreExpr(..))
import PreludePS(_PackedString)
import PrimOps(PrimOp)
-import SimplEnv(EnclosingCcDetails, IdVal, SimplEnv, UnfoldEnv)
+import SimplEnv(SimplEnv)
import SimplMonad(SimplCount, SmplM(..), TickType)
import SplitUniq(SplitUniqSupply)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import TyVar(TyVar)
import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique)
-data CoreArg a {-# GHC_PRAGMA TypeArg UniType | ValArg (CoreAtom a) #-}
-data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data MagicUnfoldingFun {-# GHC_PRAGMA MUF (SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)) #-}
+data CoreArg a
+data CoreAtom a
+data CoreExpr a b
+data Id
+data Labda a
+data MagicUnfoldingFun
type PlainCoreArg = CoreArg Id
type PlainCoreAtom = CoreAtom Id
type PlainCoreExpr = CoreExpr Id Id
-data SimplEnv {-# GHC_PRAGMA SimplEnv (SimplifierSwitch -> SwitchResult) EnclosingCcDetails (UniqFM UniType) (UniqFM IdVal) UnfoldEnv #-}
-data SimplCount {-# GHC_PRAGMA SimplCount Int# [(TickType, Int)] #-}
+data SimplEnv
+data SimplCount
type SmplM a = SplitUniqSupply -> SimplCount -> (a, SimplCount)
-data TickType {-# GHC_PRAGMA UnfoldingDone | FoldrBuild | MagicUnfold | ConReused | CaseFloatFromLet | CaseOfCase | LetFloatFromLet | LetFloatFromCase | KnownBranch | Let2Case | CaseMerge | CaseElim | CaseIdentity | AtomicRhs | EtaExpansion | CaseOfError | FoldrConsNil | Foldr_Nil | FoldrFoldr | Foldr_List | FoldrCons | FoldrInline | TyBetaReduction | BetaReduction #-}
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data TickType
+data SplitUniqSupply
+data UniType
applyMagicUnfoldingFun :: MagicUnfoldingFun -> SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)
- {-# GHC_PRAGMA _A_ 3 _U_ 12222 _N_ _S_ "U(S)LL" {_A_ 3 _U_ 12222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 3 \ (u0 :: SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)) (u1 :: SimplEnv) (u2 :: [CoreArg Id]) -> _APP_ u0 [ u1, u2 ] _N_} _F_ _IF_ARGS_ 0 3 CXX 4 \ (u0 :: MagicUnfoldingFun) (u1 :: SimplEnv) (u2 :: [CoreArg Id]) -> case u0 of { _ALG_ _ORIG_ MagicUFs MUF (u3 :: SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)) -> _APP_ u3 [ u1, u2 ]; _NO_DEFLT_ } _N_ #-}
mkMagicUnfoldingFun :: _PackedString -> MagicUnfoldingFun
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
import CmdLineOpts(GlobalSwitch, SimplifierSwitch)
import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import PlainCore(PlainCoreExpr(..), PlainCoreProgram(..))
import PrimOps(PrimOp)
import TaggedCore(SimplifiableCoreBinding(..), SimplifiableCoreExpr(..))
import TyVar(TyVar)
import UniType(UniType)
import UniqFM(UniqFM)
-import Unique(Unique)
-data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data BinderInfo
+data GlobalSwitch
+data CoreBinding a b
+data CoreExpr a b
+data Id
type PlainCoreExpr = CoreExpr Id Id
type PlainCoreProgram = [CoreBinding Id Id]
type SimplifiableCoreBinding = CoreBinding (Id, BinderInfo) Id
type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id
newOccurAnalyseBinds :: [CoreBinding Id Id] -> (GlobalSwitch -> Bool) -> (SimplifierSwitch -> Bool) -> [CoreBinding (Id, BinderInfo) Id]
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "LSL" _N_ _N_ #-}
newOccurAnalyseExpr :: UniqFM Id -> CoreExpr Id Id -> (UniqFM BinderInfo, CoreExpr (Id, BinderInfo) Id)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
import CmdLineOpts(GlobalSwitch, SimplifierSwitch)
import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import PlainCore(PlainCoreExpr(..), PlainCoreProgram(..))
import PrimOps(PrimOp)
import TaggedCore(SimplifiableCoreBinding(..), SimplifiableCoreExpr(..))
import TyVar(TyVar)
import UniType(UniType)
import UniqFM(UniqFM)
-import Unique(Unique)
-data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data BinderInfo
+data GlobalSwitch
+data CoreBinding a b
+data CoreExpr a b
+data Id
type PlainCoreExpr = CoreExpr Id Id
type PlainCoreProgram = [CoreBinding Id Id]
type SimplifiableCoreBinding = CoreBinding (Id, BinderInfo) Id
type SimplifiableCoreExpr = CoreExpr (Id, BinderInfo) Id
occurAnalyseBinds :: [CoreBinding Id Id] -> (GlobalSwitch -> Bool) -> (SimplifierSwitch -> Bool) -> [CoreBinding (Id, BinderInfo) Id]
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "LSL" _N_ _N_ #-}
occurAnalyseExpr :: UniqFM Id -> CoreExpr Id Id -> (UniqFM BinderInfo, CoreExpr (Id, BinderInfo) Id)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
occurAnalyseGlobalExpr :: CoreExpr Id Id -> CoreExpr (Id, BinderInfo) Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
import BasicLit(BasicLit)
import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import PlainCore(PlainCoreProgram(..))
import PrimOps(PrimOp)
import SplitUniq(SplitUniqSupply)
import TyVar(TyVar)
import UniType(UniType)
-import Unique(Unique)
-data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data CoreBinding a b
+data CoreExpr a b
+data Id
type PlainCoreProgram = [CoreBinding Id Id]
doStaticArgs :: [CoreBinding Id Id] -> SplitUniqSupply -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _S_ "S" _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface SATMonad where
-import Class(Class)
import CoreSyn(CoreBinding, CoreExpr)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Maybes(Labda)
import PlainCore(PlainCoreExpr(..))
import SplitUniq(SplitUniqSupply)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
import UniType(UniType)
import UniqFM(UniqFM)
-import Unique(Unique)
infixr 9 `thenSAT`
infixr 9 `thenSAT_`
data Arg a = Static a | NotStatic
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
type PlainCoreExpr = CoreExpr Id Id
type SATEnv = UniqFM ([Arg UniType], [Arg Id])
type SATInfo = ([Arg UniType], [Arg Id])
type SatM a = SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (a, UniqFM ([Arg UniType], [Arg Id]))
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data SplitUniqSupply
+data UniType
dropStatics :: [Arg a] -> [b] -> [b]
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SS" _N_ _N_ #-}
emptyEnvSAT :: SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> ((), UniqFM ([Arg UniType], [Arg Id]))
- {-# GHC_PRAGMA _A_ 2 _U_ 00 _N_ _S_ "AA" {_A_ 0 _N_ _N_ _N_ _N_ _N_} _N_ _N_ #-}
getArgLists :: CoreExpr Id Id -> ([Arg UniType], [Arg Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
getSATInfo :: Id -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (Labda ([Arg UniType], [Arg Id]), UniqFM ([Arg UniType], [Arg Id]))
- {-# GHC_PRAGMA _A_ 3 _U_ 102 _N_ _S_ "LAL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
initSAT :: (SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (a, UniqFM ([Arg UniType], [Arg Id]))) -> SplitUniqSupply -> a
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
insSAEnv :: Id -> ([Arg UniType], [Arg Id]) -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> ((), UniqFM ([Arg UniType], [Arg Id]))
- {-# GHC_PRAGMA _A_ 4 _U_ 1202 _N_ _S_ "LLAL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isStatic :: Arg a -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 4 _/\_ u0 -> \ (u1 :: Arg u0) -> case u1 of { _ALG_ _ORIG_ SATMonad Static (u2 :: u0) -> _!_ True [] []; _ORIG_ SATMonad NotStatic -> _!_ False [] []; _NO_DEFLT_ } _N_ #-}
mapSAT :: (a -> SplitUniqSupply -> c -> (b, c)) -> [a] -> SplitUniqSupply -> c -> ([b], c)
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
newSATName :: Id -> UniType -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (Id, UniqFM ([Arg UniType], [Arg Id]))
- {-# GHC_PRAGMA _A_ 4 _U_ 1212 _N_ _N_ _N_ _N_ #-}
returnSAT :: b -> a -> c -> (b, c)
- {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _S_ "LAL" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 3 2 XX 3 _/\_ u0 u1 u2 -> \ (u3 :: u1) (u4 :: u2) -> _!_ _TUP_2 [u1, u2] [u3, u4] _N_} _F_ _IF_ARGS_ 3 3 XXX 3 _/\_ u0 u1 u2 -> \ (u3 :: u1) (u4 :: u0) (u5 :: u2) -> _!_ _TUP_2 [u1, u2] [u3, u5] _N_ #-}
saTransform :: Id -> CoreExpr Id Id -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (CoreBinding Id Id, UniqFM ([Arg UniType], [Arg Id]))
- {-# GHC_PRAGMA _A_ 2 _U_ 2212 _N_ _N_ _N_ _N_ #-}
thenSAT :: (SplitUniqSupply -> c -> (a, b)) -> (a -> SplitUniqSupply -> b -> d) -> SplitUniqSupply -> c -> d
- {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "SSU(ALL)L" {_A_ 5 _U_ 11222 _N_ _N_ _F_ _IF_ARGS_ 4 5 XXXXX 8 _/\_ u0 u1 u2 u3 -> \ (u4 :: SplitUniqSupply -> u2 -> (u0, u1)) (u5 :: u0 -> SplitUniqSupply -> u1 -> u3) (u6 :: SplitUniqSupply) (u7 :: SplitUniqSupply) (u8 :: u2) -> case _APP_ u4 [ u6, u8 ] of { _ALG_ _TUP_2 (u9 :: u0) (ua :: u1) -> _APP_ u5 [ u9, u7, ua ]; _NO_DEFLT_ } _N_} _F_ _ALWAYS_ _/\_ u0 u1 u2 u3 -> \ (u4 :: SplitUniqSupply -> u2 -> (u0, u1)) (u5 :: u0 -> SplitUniqSupply -> u1 -> u3) (u6 :: SplitUniqSupply) (u7 :: u2) -> case u6 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u8 :: Int) (u9 :: SplitUniqSupply) (ua :: SplitUniqSupply) -> case _APP_ u4 [ u9, u7 ] of { _ALG_ _TUP_2 (ub :: u0) (uc :: u1) -> _APP_ u5 [ ub, ua, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
thenSAT_ :: (SplitUniqSupply -> c -> (a, b)) -> (SplitUniqSupply -> b -> d) -> SplitUniqSupply -> c -> d
- {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "SSU(ALL)L" {_A_ 5 _U_ 11222 _N_ _N_ _F_ _IF_ARGS_ 4 5 XXXXX 7 _/\_ u0 u1 u2 u3 -> \ (u4 :: SplitUniqSupply -> u2 -> (u0, u1)) (u5 :: SplitUniqSupply -> u1 -> u3) (u6 :: SplitUniqSupply) (u7 :: SplitUniqSupply) (u8 :: u2) -> case _APP_ u4 [ u6, u8 ] of { _ALG_ _TUP_2 (u9 :: u0) (ua :: u1) -> _APP_ u5 [ u7, ua ]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 4 4 XXCX 8 _/\_ u0 u1 u2 u3 -> \ (u4 :: SplitUniqSupply -> u2 -> (u0, u1)) (u5 :: SplitUniqSupply -> u1 -> u3) (u6 :: SplitUniqSupply) (u7 :: u2) -> case u6 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u8 :: Int) (u9 :: SplitUniqSupply) (ua :: SplitUniqSupply) -> case _APP_ u4 [ u9, u7 ] of { _ALG_ _TUP_2 (ub :: u0) (uc :: u1) -> _APP_ u5 [ ua, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
updSAEnv :: Labda (Id, ([Arg UniType], [Arg Id])) -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> ((), UniqFM ([Arg UniType], [Arg Id]))
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "S" _N_ _N_ #-}
instance Eq a => Eq (Arg a)
- {-# GHC_PRAGMA _M_ SATMonad {-dfun-} _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
import SplitUniq(SplitUniqSupply)
data Level = Level Int Int | Top
incMinorLvl :: Level -> Level
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isTopLvl :: Level -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: Level) -> case u0 of { _ALG_ _ORIG_ SetLevels Level (u1 :: Int) (u2 :: Int) -> _!_ False [] []; _ORIG_ SetLevels Top -> _!_ True [] []; _NO_DEFLT_ } _N_ #-}
ltLvl :: Level -> Level -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-}
ltMajLvl :: Level -> Level -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ #-}
setLevels :: [CoreBinding Id Id] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding (Id, Level) Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "S" _N_ _N_ #-}
tOP_LEVEL :: Level
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ SetLevels Top [] [] _N_ #-}
instance Outputable Level
- {-# GHC_PRAGMA _M_ SetLevels {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Level) _N_
- ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import SplitUniq(SplitUniqSupply)
import UniType(UniType)
bindLargeRhs :: SimplEnv -> [(Id, BinderInfo)] -> UniType -> (SimplEnv -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)) -> SplitUniqSupply -> SimplCount -> ((CoreBinding Id Id, CoreExpr (Id, BinderInfo) Id), SimplCount)
- {-# GHC_PRAGMA _A_ 4 _U_ 212222 _N_ _S_ "LSLS" _N_ _N_ #-}
simplCase :: SimplEnv -> CoreExpr (Id, BinderInfo) Id -> CoreCaseAlternatives (Id, BinderInfo) Id -> (SimplEnv -> CoreExpr (Id, BinderInfo) Id -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)) -> UniType -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
- {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _S_ "LSLLL" _N_ _N_ #-}
-> SmplM OutExpr
simplCase env (CoLet bind body) alts rhs_c result_ty
- = -- Float the let outside the case scrutinee
+ | not (switchIsSet env SimplNoLetFromCase)
+ = -- Float the let outside the case scrutinee (if not disabled by flag)
tick LetFloatFromCase `thenSmpl_`
simplBind env bind (\env -> simplCase env body alts rhs_c result_ty) result_ty
\end{code}
import UniType(UniType)
import UniqFM(UniqFM)
import Unique(Unique)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
+data Bag a
type IdEnv a = UniqFM a
-data UnfoldingDetails {-# GHC_PRAGMA NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance #-}
+data UnfoldingDetails
data SpecialiseData = SpecData Bool Bool [TyCon] [TyCon] (FiniteMap TyCon [[Labda UniType]]) (Bag (Id, [Labda UniType])) (Bag (Id, [Labda UniType])) (Bag (TyCon, [Labda UniType]))
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data UniqFM a
+data Unique
core2core :: [CoreToDo] -> (GlobalSwitch -> SwitchResult) -> _PackedString -> PprStyle -> SplitUniqSupply -> [TyCon] -> FiniteMap TyCon [[Labda UniType]] -> [CoreBinding Id Id] -> _State _RealWorld -> (([CoreBinding Id Id], UniqFM UnfoldingDetails, SpecialiseData), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 9 _U_ 222222222 _N_ _S_ "SLLLLLLLL" _N_ _N_ #-}
interface SimplEnv where
import BasicLit(BasicLit)
import BinderInfo(BinderInfo(..), DuplicationDanger, FunOrArg, InsideSCC)
-import Class(Class)
import CmdLineOpts(GlobalSwitch, SimplifierSwitch, SwitchResult)
import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr)
import CostCentre(CostCentre)
import FiniteMap(FiniteMap)
-import Id(Id, IdDetails, applyTypeEnvToId)
-import IdEnv(IdEnv(..), lookupIdEnv)
-import IdInfo(IdInfo, StrictnessInfo)
+import Id(Id)
+import IdEnv(IdEnv(..))
+import IdInfo(StrictnessInfo)
import MagicUFs(MagicUnfoldingFun)
import Maybes(Labda)
-import NameTypes(ShortName)
-import Outputable(NamedThing, Outputable)
+import Outputable(Outputable)
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
import Pretty(PrettyRep)
import PrimKind(PrimKind)
import PrimOps(PrimOp)
-import SimplMonad(SimplCount)
-import SplitUniq(SplitUniqSupply)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import TyVar(TyVar)
import TyVarEnv(TyVarEnv(..), nullTyVarEnv)
-import UniTyFuns(applyTypeEnvToTy)
import UniType(UniType)
-import UniqFM(UniqFM, emptyUFM, lookupUFM)
+import UniqFM(UniqFM)
import Unique(Unique)
-data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-}
+data BasicLit
data BinderInfo = DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int
-data DuplicationDanger {-# GHC_PRAGMA DupDanger | NoDupDanger #-}
-data FunOrArg {-# GHC_PRAGMA FunOcc | ArgOcc #-}
-data InsideSCC {-# GHC_PRAGMA InsideSCC | NotInsideSCC #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data SimplifierSwitch {-# GHC_PRAGMA SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings #-}
-data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-}
-data CoreCaseAlternatives a b {-# GHC_PRAGMA CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b) #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
+data DuplicationDanger
+data FunOrArg
+data InsideSCC
+data GlobalSwitch
+data SimplifierSwitch
+data CoreAtom a
+data CoreCaseAlternatives a b
+data CoreExpr a b
data EnclosingCcDetails = NoEnclosingCcDetails | EnclosingCC CostCentre
data FormSummary = WhnfForm | BottomForm | OtherForm
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
type IdEnv a = UniqFM a
data IdVal = InlineIt (UniqFM IdVal) (UniqFM UniType) (CoreExpr (Id, BinderInfo) Id) | ItsAnAtom (CoreAtom Id)
type InAlts = CoreCaseAlternatives (Id, BinderInfo) Id
type InType = UniType
type InTypeEnv = UniqFM UniType
type InUniType = UniType
-data MagicUnfoldingFun {-# GHC_PRAGMA MUF (SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)) #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
+data MagicUnfoldingFun
+data Labda a
type OutAlts = CoreCaseAlternatives Id Id
type OutArg = CoreArg Id
type OutAtom = CoreAtom Id
type OutId = Id
type OutType = UniType
type OutUniType = UniType
-data SimplEnv {-# GHC_PRAGMA SimplEnv (SimplifierSwitch -> SwitchResult) EnclosingCcDetails (UniqFM UniType) (UniqFM IdVal) UnfoldEnv #-}
+data SimplEnv
type SwitchChecker a = a -> SwitchResult
-data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
+data SwitchResult
+data TyVar
type TyVarEnv a = UniqFM a
-data UnfoldConApp {-# GHC_PRAGMA UCA Id [UniType] [CoreAtom Id] #-}
-data UnfoldEnv {-# GHC_PRAGMA UFE (UniqFM UnfoldItem) (UniqFM Id) (FiniteMap UnfoldConApp Id) #-}
-data UnfoldItem {-# GHC_PRAGMA UnfoldItem Id UnfoldingDetails EnclosingCcDetails #-}
+data UnfoldConApp
+data UnfoldEnv
+data UnfoldItem
data UnfoldingDetails = NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance
data UnfoldingGuidance = UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
-applyTypeEnvToId :: UniqFM UniType -> Id -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LLLS)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-applyTypeEnvToTy :: UniqFM UniType -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
-emptyUFM :: UniqFM a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
+data UniType
+data UniqFM a
+data Unique
extendIdEnvWithAtom :: SimplEnv -> (Id, BinderInfo) -> CoreAtom Id -> SimplEnv
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(LLLLL)U(LL)S" {_A_ 4 _U_ 1122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
extendIdEnvWithAtomList :: SimplEnv -> [((Id, BinderInfo), CoreAtom Id)] -> SimplEnv
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
extendIdEnvWithClone :: SimplEnv -> (Id, BinderInfo) -> Id -> SimplEnv
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(LLLLL)U(LA)L" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
extendIdEnvWithClones :: SimplEnv -> [(Id, BinderInfo)] -> [Id] -> SimplEnv
- {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "U(LLLLL)LL" _N_ _N_ #-}
extendIdEnvWithInlining :: SimplEnv -> SimplEnv -> (Id, BinderInfo) -> CoreExpr (Id, BinderInfo) Id -> SimplEnv
- {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "U(LLLLL)LU(LA)L" {_A_ 4 _U_ 1112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
extendTyEnv :: SimplEnv -> TyVar -> UniType -> SimplEnv
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(LLLLL)LL" _N_ _N_ #-}
extendTyEnvList :: SimplEnv -> [(TyVar, UniType)] -> SimplEnv
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LLLLL)L" _N_ _N_ #-}
extendUnfoldEnvGivenConstructor :: SimplEnv -> Id -> Id -> [Id] -> SimplEnv
- {-# GHC_PRAGMA _A_ 4 _U_ 1221 _N_ _S_ "U(LLLLL)LLL" _N_ _N_ #-}
extendUnfoldEnvGivenFormDetails :: SimplEnv -> Id -> UnfoldingDetails -> SimplEnv
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(LLLLL)LS" _N_ _N_ #-}
extendUnfoldEnvGivenRhs :: SimplEnv -> (Id, BinderInfo) -> Id -> CoreExpr Id Id -> SimplEnv
- {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "U(LLLLL)U(AL)LL" {_A_ 4 _U_ 1122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
filterUnfoldEnvForInlines :: SimplEnv -> SimplEnv
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LLLLA)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getSwitchChecker :: SimplEnv -> SimplifierSwitch -> SwitchResult
- {-# GHC_PRAGMA _A_ 1 _U_ 12 _N_ _S_ "U(SAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SimplifierSwitch -> SwitchResult) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: SimplEnv) -> case u0 of { _ALG_ _ORIG_ SimplEnv SimplEnv (u1 :: SimplifierSwitch -> SwitchResult) (u2 :: EnclosingCcDetails) (u3 :: UniqFM UniType) (u4 :: UniqFM IdVal) (u5 :: UnfoldEnv) -> u1; _NO_DEFLT_ } _N_ #-}
lookForConstructor :: SimplEnv -> Id -> [UniType] -> [CoreAtom Id] -> Labda Id
- {-# GHC_PRAGMA _A_ 4 _U_ 1222 _N_ _S_ "U(AAAAU(AAL))LLL" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupId :: SimplEnv -> Id -> Labda IdVal
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AAASA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-lookupIdEnv :: UniqFM a -> Id -> Labda a
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
lookupUnfolding :: SimplEnv -> Id -> UnfoldingDetails
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AAAAL)U(LALS)" {_A_ 4 _U_ 1112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkFormSummary :: StrictnessInfo -> CoreExpr a Id -> FormSummary
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "LS" _N_ _N_ #-}
nullInEnvs :: (UniqFM UniType, UniqFM IdVal)
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
nullSimplEnv :: (SimplifierSwitch -> SwitchResult) -> SimplEnv
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
nullTyVarEnv :: UniqFM a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
pprSimplEnv :: SimplEnv -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(AAAAU(LAA))" {_A_ 1 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
replaceInEnvs :: SimplEnv -> (UniqFM UniType, UniqFM IdVal) -> SimplEnv
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(LLAAL)U(LL)" {_A_ 5 _U_ 22222 _N_ _N_ _F_ _IF_ARGS_ 0 5 XXXXX 6 \ (u0 :: SimplifierSwitch -> SwitchResult) (u1 :: EnclosingCcDetails) (u2 :: UnfoldEnv) (u3 :: UniqFM UniType) (u4 :: UniqFM IdVal) -> _!_ _ORIG_ SimplEnv SimplEnv [] [u0, u1, u3, u4, u2] _N_} _F_ _ALWAYS_ \ (u0 :: SimplEnv) (u1 :: (UniqFM UniType, UniqFM IdVal)) -> case u0 of { _ALG_ _ORIG_ SimplEnv SimplEnv (u2 :: SimplifierSwitch -> SwitchResult) (u3 :: EnclosingCcDetails) (u4 :: UniqFM UniType) (u5 :: UniqFM IdVal) (u6 :: UnfoldEnv) -> case u1 of { _ALG_ _TUP_2 (u7 :: UniqFM UniType) (u8 :: UniqFM IdVal) -> _!_ _ORIG_ SimplEnv SimplEnv [] [u2, u3, u7, u8, u6]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LALLL)L" {_A_ 5 _U_ 22222 _N_ _N_ _F_ _IF_ARGS_ 0 5 XXXXX 6 \ (u0 :: SimplifierSwitch -> SwitchResult) (u1 :: UniqFM UniType) (u2 :: UniqFM IdVal) (u3 :: UnfoldEnv) (u4 :: EnclosingCcDetails) -> _!_ _ORIG_ SimplEnv SimplEnv [] [u0, u4, u1, u2, u3] _N_} _F_ _ALWAYS_ \ (u0 :: SimplEnv) (u1 :: EnclosingCcDetails) -> case u0 of { _ALG_ _ORIG_ SimplEnv SimplEnv (u2 :: SimplifierSwitch -> SwitchResult) (u3 :: EnclosingCcDetails) (u4 :: UniqFM UniType) (u5 :: UniqFM IdVal) (u6 :: UnfoldEnv) -> _!_ _ORIG_ SimplEnv SimplEnv [] [u2, u1, u4, u5, u6]; _NO_DEFLT_ } _N_ #-}
simplTy :: SimplEnv -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AALAA)S" {_A_ 2 _U_ 21 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns applyTypeEnvToTy _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: SimplEnv) (u1 :: UniType) -> case u0 of { _ALG_ _ORIG_ SimplEnv SimplEnv (u2 :: SimplifierSwitch -> SwitchResult) (u3 :: EnclosingCcDetails) (u4 :: UniqFM UniType) (u5 :: UniqFM IdVal) (u6 :: UnfoldEnv) -> _APP_ _ORIG_ UniTyFuns applyTypeEnvToTy [ u4, u1 ]; _NO_DEFLT_ } _N_ #-}
simplTyInId :: SimplEnv -> Id -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AALAA)U(LLLS)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(SAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _TYAPP_ _ORIG_ CmdLineOpts switchIsOn { SimplifierSwitch } _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: SimplEnv) (u1 :: SimplifierSwitch) -> case u0 of { _ALG_ _ORIG_ SimplEnv SimplEnv (u2 :: SimplifierSwitch -> SwitchResult) (u3 :: EnclosingCcDetails) (u4 :: UniqFM UniType) (u5 :: UniqFM IdVal) (u6 :: UnfoldEnv) -> _APP_ _TYAPP_ _ORIG_ CmdLineOpts switchIsOn { SimplifierSwitch } [ u2, u1 ]; _NO_DEFLT_ } _N_ #-}
instance Eq UnfoldConApp
- {-# GHC_PRAGMA _M_ SimplEnv {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UnfoldConApp -> UnfoldConApp -> Bool), (UnfoldConApp -> UnfoldConApp -> Bool)] [_CONSTM_ Eq (==) (UnfoldConApp), _CONSTM_ Eq (/=) (UnfoldConApp)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord UnfoldConApp
- {-# GHC_PRAGMA _M_ SimplEnv {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq UnfoldConApp}}, (UnfoldConApp -> UnfoldConApp -> Bool), (UnfoldConApp -> UnfoldConApp -> Bool), (UnfoldConApp -> UnfoldConApp -> Bool), (UnfoldConApp -> UnfoldConApp -> Bool), (UnfoldConApp -> UnfoldConApp -> UnfoldConApp), (UnfoldConApp -> UnfoldConApp -> UnfoldConApp), (UnfoldConApp -> UnfoldConApp -> _CMP_TAG)] [_DFUN_ Eq (UnfoldConApp), _CONSTM_ Ord (<) (UnfoldConApp), _CONSTM_ Ord (<=) (UnfoldConApp), _CONSTM_ Ord (>=) (UnfoldConApp), _CONSTM_ Ord (>) (UnfoldConApp), _CONSTM_ Ord max (UnfoldConApp), _CONSTM_ Ord min (UnfoldConApp), _CONSTM_ Ord _tagCmp (UnfoldConApp)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)AAA)LL)U(U(U(P)AAA)LL)" {_A_ 4 _U_ 2111 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable FormSummary
- {-# GHC_PRAGMA _M_ SimplEnv {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (FormSummary) _N_
- ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable UnfoldingGuidance
- {-# GHC_PRAGMA _M_ SimplEnv {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (UnfoldingGuidance) _N_
- ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
interface SimplMonad where
import BasicLit(BasicLit)
import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
-import Class(Class)
import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
-import NameTypes(ShortName)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
+import Id(Id)
import PrimOps(PrimOp)
import SimplEnv(SimplEnv)
-import SplitUniq(SplitUniqSupply, splitUniqSupply)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import SplitUniq(SplitUniqSupply)
+import TyVar(TyVar)
import UniType(UniType)
-import Unique(Unique)
infixr 9 `thenSmpl`
infixr 9 `thenSmpl_`
-data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
-data SimplCount {-# GHC_PRAGMA SimplCount Int# [(TickType, Int)] #-}
+data BinderInfo
+data CoreExpr a b
+data Id
+data PrimOp
+data SimplCount
type SmplM a = SplitUniqSupply -> SimplCount -> (a, SimplCount)
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
+data SplitUniqSupply
data TickType = UnfoldingDone | FoldrBuild | MagicUnfold | ConReused | CaseFloatFromLet | CaseOfCase | LetFloatFromLet | LetFloatFromCase | KnownBranch | Let2Case | CaseMerge | CaseElim | CaseIdentity | AtomicRhs | EtaExpansion | CaseOfError | FoldrConsNil | Foldr_Nil | FoldrFoldr | Foldr_List | FoldrCons | FoldrInline | TyBetaReduction | BetaReduction
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data TyVar
+data UniType
cloneId :: SimplEnv -> (Id, BinderInfo) -> SplitUniqSupply -> SimplCount -> (Id, SimplCount)
- {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "LU(LA)LL" {_A_ 4 _U_ 1112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
cloneIds :: SimplEnv -> [(Id, BinderInfo)] -> SplitUniqSupply -> SimplCount -> ([Id], SimplCount)
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
cloneTyVarSmpl :: TyVar -> SplitUniqSupply -> SimplCount -> (TyVar, SimplCount)
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _N_ _N_ _N_ #-}
combineSimplCounts :: SimplCount -> SimplCount -> SimplCount
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(PL)U(PA)" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: Int#) (u1 :: [(TickType, Int)]) (u2 :: Int#) -> case _#_ plusInt# [] [u0, u2] of { _PRIM_ (u3 :: Int#) -> _!_ _ORIG_ SimplMonad SimplCount [] [u3, u1] } _N_} _F_ _IF_ARGS_ 0 2 CC 6 \ (u0 :: SimplCount) (u1 :: SimplCount) -> case u0 of { _ALG_ _ORIG_ SimplMonad SimplCount (u2 :: Int#) (u3 :: [(TickType, Int)]) -> case u1 of { _ALG_ _ORIG_ SimplMonad SimplCount (u4 :: Int#) (u5 :: [(TickType, Int)]) -> case _#_ plusInt# [] [u2, u4] of { _PRIM_ (u6 :: Int#) -> _!_ _ORIG_ SimplMonad SimplCount [] [u6, u3] }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
detailedSimplCount :: SplitUniqSupply -> SimplCount -> (SimplCount, SimplCount)
- {-# GHC_PRAGMA _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: SimplCount) -> _!_ _TUP_2 [SimplCount, SimplCount] [u0, u0] _N_} _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: SplitUniqSupply) (u1 :: SimplCount) -> _!_ _TUP_2 [SimplCount, SimplCount] [u1, u1] _N_ #-}
initSmpl :: SplitUniqSupply -> (SplitUniqSupply -> SimplCount -> (a, SimplCount)) -> (a, SimplCount)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: SplitUniqSupply) (u2 :: SplitUniqSupply -> SimplCount -> (u0, SimplCount)) -> _APP_ u2 [ u1, _ORIG_ SimplMonad zeroSimplCount ] _N_ #-}
mapAndUnzipSmpl :: (a -> SplitUniqSupply -> SimplCount -> ((b, c), SimplCount)) -> [a] -> SplitUniqSupply -> SimplCount -> (([b], [c]), SimplCount)
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
mapSmpl :: (a -> SplitUniqSupply -> SimplCount -> (b, SimplCount)) -> [a] -> SplitUniqSupply -> SimplCount -> ([b], SimplCount)
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
newId :: UniType -> SplitUniqSupply -> SimplCount -> (Id, SimplCount)
- {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _N_ _N_ _N_ #-}
newIds :: [UniType] -> SplitUniqSupply -> SimplCount -> ([Id], SimplCount)
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
returnSmpl :: a -> SplitUniqSupply -> SimplCount -> (a, SimplCount)
- {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: SplitUniqSupply) (u3 :: SimplCount) -> _!_ _TUP_2 [u0, SimplCount] [u1, u3] _N_ #-}
showSimplCount :: SimplCount -> [Char]
- {-# GHC_PRAGMA _A_ 0 _U_ 1 _N_ _N_ _N_ _N_ #-}
simplCount :: SplitUniqSupply -> SimplCount -> (Int, SimplCount)
- {-# GHC_PRAGMA _A_ 2 _U_ 01 _N_ _S_ "AU(PL)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-}
thenSmpl :: (SplitUniqSupply -> SimplCount -> (a, SimplCount)) -> (a -> SplitUniqSupply -> SimplCount -> (b, SimplCount)) -> SplitUniqSupply -> SimplCount -> (b, SimplCount)
- {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "SSSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: SplitUniqSupply -> SimplCount -> (u0, SimplCount)) (u3 :: u0 -> SplitUniqSupply -> SimplCount -> (u1, SimplCount)) (u4 :: SplitUniqSupply) (u5 :: SimplCount) -> case u4 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u6 :: Int) (u7 :: SplitUniqSupply) (u8 :: SplitUniqSupply) -> case _APP_ u2 [ u7, u5 ] of { _ALG_ _TUP_2 (u9 :: u0) (ua :: SimplCount) -> _APP_ u3 [ u9, u8, ua ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
thenSmpl_ :: (SplitUniqSupply -> SimplCount -> (a, SimplCount)) -> (SplitUniqSupply -> SimplCount -> (b, SimplCount)) -> SplitUniqSupply -> SimplCount -> (b, SimplCount)
- {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "SSSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: SplitUniqSupply -> SimplCount -> (u0, SimplCount)) (u3 :: SplitUniqSupply -> SimplCount -> (u1, SimplCount)) (u4 :: SplitUniqSupply) (u5 :: SimplCount) -> case u4 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u6 :: Int) (u7 :: SplitUniqSupply) (u8 :: SplitUniqSupply) -> case _APP_ u2 [ u7, u5 ] of { _ALG_ _TUP_2 (u9 :: u0) (ua :: SimplCount) -> _APP_ u3 [ u8, ua ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
tick :: TickType -> SplitUniqSupply -> SimplCount -> ((), SimplCount)
- {-# GHC_PRAGMA _A_ 3 _U_ 001 _N_ _S_ "AAU(PL)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
tickN :: TickType -> Int -> SplitUniqSupply -> SimplCount -> ((), SimplCount)
- {-# GHC_PRAGMA _A_ 4 _U_ 0101 _N_ _S_ "AU(P)AU(PL)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
zeroSimplCount :: SimplCount
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
instance Eq TickType
- {-# GHC_PRAGMA _M_ SimplMonad {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TickType -> TickType -> Bool), (TickType -> TickType -> Bool)] [_CONSTM_ Eq (==) (TickType), _CONSTM_ Eq (/=) (TickType)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Ix TickType
- {-# GHC_PRAGMA _M_ SimplMonad {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [{{Ord TickType}}, ((TickType, TickType) -> [TickType]), ((TickType, TickType) -> TickType -> Int), ((TickType, TickType) -> TickType -> Bool)] [_DFUN_ Ord (TickType), _CONSTM_ Ix range (TickType), _CONSTM_ Ix index (TickType), _CONSTM_ Ix inRange (TickType)] _N_
- range = _A_ 1 _U_ 1 _N_ _S_ "U(EE)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_,
- index = _A_ 2 _U_ 12 _N_ _S_ "U(EE)E" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _N_ _N_,
- inRange = _A_ 2 _U_ 11 _N_ _S_ "U(EE)E" {_A_ 3 _U_ 111 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord TickType
- {-# GHC_PRAGMA _M_ SimplMonad {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TickType}}, (TickType -> TickType -> Bool), (TickType -> TickType -> Bool), (TickType -> TickType -> Bool), (TickType -> TickType -> Bool), (TickType -> TickType -> TickType), (TickType -> TickType -> TickType), (TickType -> TickType -> _CMP_TAG)] [_DFUN_ Eq (TickType), _CONSTM_ Ord (<) (TickType), _CONSTM_ Ord (<=) (TickType), _CONSTM_ Ord (>=) (TickType), _CONSTM_ Ord (>) (TickType), _CONSTM_ Ord max (TickType), _CONSTM_ Ord min (TickType), _CONSTM_ Ord _tagCmp (TickType)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text TickType
- {-# GHC_PRAGMA _M_ SimplMonad {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(TickType, [Char])]), (Int -> TickType -> [Char] -> [Char]), ([Char] -> [([TickType], [Char])]), ([TickType] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (TickType), _CONSTM_ Text showsPrec (TickType), _CONSTM_ Text readList (TickType), _CONSTM_ Text showList (TickType)] _N_
- readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(TickType, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
import SimplMonad(SimplCount)
import SplitUniq(SplitUniqSupply)
simplifyPgm :: [CoreBinding Id Id] -> (GlobalSwitch -> SwitchResult) -> (SimplifierSwitch -> SwitchResult) -> SimplCount -> SplitUniqSupply -> ([CoreBinding Id Id], Int, SimplCount)
- {-# GHC_PRAGMA _A_ 5 _U_ 12211 _N_ _S_ "LSSLU(ALL)" _N_ _N_ #-}
import TyVar(TyVar)
import UniType(UniType)
etaExpandCount :: CoreExpr a Id -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
floatExposesHNF :: Bool -> Bool -> Bool -> CoreExpr a Id -> Bool
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "LLLS" _N_ _N_ #-}
mkCoLamTryingEta :: [Id] -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
mkCoTyLamTryingEta :: [TyVar] -> CoreExpr Id Id -> CoreExpr Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
mkIdentityAlts :: UniType -> SplitUniqSupply -> SimplCount -> (CoreCaseAlternatives (Id, BinderInfo) Id, SimplCount)
- {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-}
simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LU(SAAAA)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-}
type_ok_for_let_to_case :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
import SplitUniq(SplitUniqSupply)
import UniType(UniType)
completeVar :: SimplEnv -> Id -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "U(LLLLL)U(LLLS)L" _N_ _N_ #-}
leastItCouldCost :: Int -> Int -> Int -> [Bool] -> [UniType] -> Int
- {-# GHC_PRAGMA _A_ 5 _U_ 21111 _N_ _S_ "LLLSL" _N_ _N_ #-}
import SplitUniq(SplitUniqSupply)
import UniType(UniType)
simplBind :: SimplEnv -> CoreBinding (Id, BinderInfo) Id -> (SimplEnv -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)) -> UniType -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
- {-# GHC_PRAGMA _A_ 4 _U_ 212222 _N_ _S_ "LSLL" _N_ _N_ #-}
simplExpr :: SimplEnv -> CoreExpr (Id, BinderInfo) Id -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (CoreExpr Id Id, SimplCount)
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "LSL" _N_ _N_ #-}
simplTopBinds :: SimplEnv -> [CoreBinding (Id, BinderInfo) Id] -> SplitUniqSupply -> SimplCount -> ([CoreBinding Id Id], SimplCount)
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
\begin{code}
simplExpr env (CoLet bind body) args
- = simplBind env bind (\env -> simplExpr env body args) (computeResultType env body args)
+ | not (switchIsSet env SimplNoLetFromApp) -- The common case
+ = simplBind env bind (\env -> simplExpr env body args)
+ (computeResultType env body args)
+
+ | otherwise -- No float from application
+ = simplBind env bind (\env -> simplExpr env body [])
+ (computeResultType env body []) `thenSmpl` \ let_expr' ->
+ returnSmpl (applyToArgs let_expr' args)
\end{code}
Case expressions
its body (obviously).
-}
- | will_be_demanded ||
+ | (will_be_demanded && not no_float) ||
always_float_let_from_let ||
floatExposesHNF float_lets float_primops ok_to_dup rhs
= try_float env rhs body_c
ok_to_dup = switchIsSet env SimplOkToDupCode
always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
try_let_to_case = switchIsSet env SimplLetToCase
+ no_float = switchIsSet env SimplNoLetFromStrictLet
-------------------------------------------
done_float env rhs body_c
import SplitUniq(SplitUniqSupply)
import StgSyn(StgBinding)
liftProgram :: SplitUniqSupply -> [StgBinding Id Id] -> [StgBinding Id Id]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
import SplitUniq(SplitUniqSupply)
import StgSyn(StgBinding)
satStgRhs :: [StgBinding Id Id] -> SplitUniqSupply -> [StgBinding Id Id]
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "S" _N_ _N_ #-}
import SplitUniq(SplitUniqSupply)
import StgSyn(StgBinding)
stg2stg :: [StgToDo] -> (GlobalSwitch -> SwitchResult) -> _PackedString -> PprStyle -> SplitUniqSupply -> [StgBinding Id Id] -> _State _RealWorld -> (([StgBinding Id Id], ([CostCentre], [CostCentre])), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 7 _U_ 1222122 _N_ _S_ "SSLLU(ALL)LL" _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface StgSAT where
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import PrimOps(PrimOp)
import SplitUniq(SplitUniqSupply)
import StgSyn(PlainStgProgram(..), StgAtom, StgBinding, StgCaseAlternatives, StgExpr, StgRhs)
import UniType(UniType)
import UniqFM(UniqFM)
import Unique(Unique)
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
type PlainStgProgram = [StgBinding Id Id]
-data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-}
-data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-}
+data StgBinding a b
+data StgExpr a b
doStaticArgs :: [StgBinding Id Id] -> SplitUniqSupply -> [StgBinding Id Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _S_ "S" _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface StgSATMonad where
-import Class(Class)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import SATMonad(Arg)
import SplitUniq(SplitUniqSupply)
import StgSyn(PlainStgExpr(..), StgBinding, StgExpr, StgRhs)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
import UniType(UniType)
import UniqFM(UniqFM)
-import Unique(Unique)
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
+data Id
+data SplitUniqSupply
type PlainStgExpr = StgExpr Id Id
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data UniType
getArgLists :: StgRhs Id Id -> ([Arg UniType], [Arg Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
saTransform :: Id -> StgRhs Id Id -> SplitUniqSupply -> UniqFM ([Arg UniType], [Arg Id]) -> (StgBinding Id Id, UniqFM ([Arg UniType], [Arg Id]))
- {-# GHC_PRAGMA _A_ 4 _U_ 2212 _N_ _S_ "LLU(LLL)L" _N_ _N_ #-}
import Id(Id)
import StgSyn(StgBinding)
showStgStats :: [StgBinding Id Id] -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
\begin{code}
data CounterType
- = AlgCases
- | PrimCases
- | LetNoEscapes
- | NonUpdatableLets
- | UpdatableLets
+ = Literals
| Applications
+ | ConstructorApps
| PrimitiveApps
+ | LetNoEscapes
+ | AlgCases
+ | PrimCases
| FreeVariables
- | Closures -- does not include lets bound to constructors
---| UpdatableTopLevelDefs
---| NonUpdatableTopLevelDefs
- | Constructors
- deriving (Eq, Ord, Text)
+ | ConstructorBinds Bool{-True<=>top-level-}
+ | ReEntrantBinds Bool{-ditto-}
+ | SingleEntryBinds Bool{-ditto-}
+ | UpdatableBinds Bool{-ditto-}
+ deriving (Eq, Ord)
type Count = Int
type StatEnv = FiniteMap CounterType Count
\begin{code}
showStgStats :: PlainStgProgram -> String
-showStgStats prog = concat (map showc (fmToList (gatherStgStats prog)))
+
+showStgStats prog
+ = "STG Statistics:\n\n"
+ ++ concat (map showc (fmToList (gatherStgStats prog)))
where
- showc (AlgCases,n) = "AlgCases " ++ show n ++ "\n"
- showc (PrimCases,n) = "PrimCases " ++ show n ++ "\n"
- showc (LetNoEscapes,n) = "LetNoEscapes " ++ show n ++ "\n"
- showc (NonUpdatableLets,n) = "NonUpdatableLets " ++ show n ++ "\n"
- showc (UpdatableLets,n) = "UpdatableLets " ++ show n ++ "\n"
- showc (Applications,n) = "Applications " ++ show n ++ "\n"
- showc (PrimitiveApps,n) = "PrimitiveApps " ++ show n ++ "\n"
- showc (Closures,n) = "Closures " ++ show n ++ "\n"
- showc (FreeVariables,n) = "Free Vars in Closures " ++ show n ++ "\n"
- showc (Constructors,n) = "Constructors " ++ show n ++ "\n"
+ showc (x,n) = (showString (s x) . shows n) "\n"
+
+ s Literals = "Literals "
+ s Applications = "Applications "
+ s ConstructorApps = "ConstructorApps "
+ s PrimitiveApps = "PrimitiveApps "
+ s LetNoEscapes = "LetNoEscapes "
+ s AlgCases = "AlgCases "
+ s PrimCases = "PrimCases "
+ s FreeVariables = "FreeVariables "
+ s (ConstructorBinds True) = "ConstructorBinds_Top "
+ s (ReEntrantBinds True) = "ReEntrantBinds_Top "
+ s (SingleEntryBinds True) = "SingleEntryBinds_Top "
+ s (UpdatableBinds True) = "UpdatableBinds_Top "
+ s (ConstructorBinds _) = "ConstructorBinds_Nested "
+ s (ReEntrantBinds _) = "ReEntrantBindsBinds_Nested "
+ s (SingleEntryBinds _) = "SingleEntryBinds_Nested "
+ s (UpdatableBinds _) = "UpdatableBinds_Nested "
gatherStgStats :: PlainStgProgram -> StatEnv
gatherStgStats binds
- = combineSEs (map statBinding binds)
+ = combineSEs (map (statBinding True{-top-level-}) binds)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-statBinding :: PlainStgBinding -> StatEnv
+statBinding :: Bool -- True <=> top-level; False <=> nested
+ -> PlainStgBinding
+ -> StatEnv
-statBinding (StgNonRec b rhs)
- = statRhs (b, rhs)
+statBinding top (StgNonRec b rhs)
+ = statRhs top (b, rhs)
-statBinding (StgRec pairs)
- = combineSEs (map statRhs pairs)
+statBinding top (StgRec pairs)
+ = combineSEs (map (statRhs top) pairs)
-statRhs :: (Id, PlainStgRhs) -> StatEnv
+statRhs :: Bool -> (Id, PlainStgRhs) -> StatEnv
-statRhs (b, StgRhsCon cc con args)
- = countOne Constructors `combineSE`
- countOne NonUpdatableLets
+statRhs top (b, StgRhsCon cc con args)
+ = countOne (ConstructorBinds top)
-statRhs (b, StgRhsClosure cc bi fv u args body)
+statRhs top (b, StgRhsClosure cc bi fv u args body)
= statExpr body `combineSE`
countN FreeVariables (length fv) `combineSE`
- countOne Closures `combineSE`
- (case u of
- Updatable -> countOne UpdatableLets
- _ -> countOne NonUpdatableLets)
-
+ countOne (
+ case u of
+ ReEntrant -> ReEntrantBinds top
+ Updatable -> UpdatableBinds top
+ SingleEntry -> SingleEntryBinds top
+ )
\end{code}
%************************************************************************
statExpr :: PlainStgExpr -> StatEnv
statExpr (StgApp _ [] lvs)
- = emptySE
+ = countOne Literals
statExpr (StgApp _ _ lvs)
= countOne Applications
statExpr (StgConApp con as lvs)
- = countOne Constructors
+ = countOne ConstructorApps
statExpr (StgPrimApp op as lvs)
= countOne PrimitiveApps
= statExpr e
statExpr (StgLetNoEscape lvs_whole lvs_rhss binds body)
- = statBinding binds `combineSE`
- statExpr body `combineSE`
+ = statBinding False{-not top-level-} binds `combineSE`
+ statExpr body `combineSE`
countOne LetNoEscapes
statExpr (StgLet binds body)
- = statBinding binds `combineSE`
+ = statBinding False{-not top-level-} binds `combineSE`
statExpr body
statExpr (StgCase expr lve lva uniq alts)
stat_alts alts
where
stat_alts (StgAlgAlts ty alts def)
- = combineSEs (map stat_alg_alt alts) `combineSE`
- stat_deflt def `combineSE`
+ = combineSEs (map statExpr [ e | (_,_,_,e) <- alts ])
+ `combineSE`
+ stat_deflt def `combineSE`
countOne AlgCases
- where
- stat_alg_alt (id, bs, use_mask, e)
- = statExpr e
stat_alts (StgPrimAlts ty alts def)
- = combineSEs (map stat_prim_alt alts) `combineSE`
- stat_deflt def `combineSE`
+ = combineSEs (map statExpr [ e | (_,e) <- alts ])
+ `combineSE`
+ stat_deflt def `combineSE`
countOne PrimCases
- where
- stat_prim_alt (l, e)
- = statExpr e
- stat_deflt StgNoDefault
- = emptySE
+ stat_deflt StgNoDefault = emptySE
- stat_deflt (StgBindDefault b u expr)
- = statExpr expr
+ stat_deflt (StgBindDefault b u expr) = statExpr expr
\end{code}
import Id(Id)
import StgSyn(StgBinding)
setStgVarInfo :: Bool -> [StgBinding Id Id] -> [StgBinding Id Id]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
import Id(Id)
import StgSyn(StgBinding)
updateAnalyse :: [StgBinding Id Id] -> [StgBinding Id Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
import Maybes(Labda(..))
import Pretty(PprStyle, Pretty(..), PrettyRep)
import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import TyVar(TyVarTemplate)
import UniType(UniType)
type ConstraintVector = [Bool]
data Labda a = Hamna | Ni a
type Pretty = Int -> Bool -> PrettyRep
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data UniType
argTysMatchSpecTys_error :: [Labda UniType] -> [UniType] -> Labda (Int -> Bool -> PrettyRep)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
isUnboxedSpecialisation :: [Labda UniType] -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkConstraintVector :: [TyVarTemplate] -> [(Class, TyVarTemplate)] -> [Bool]
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-}
mkSpecialisedCon :: Id -> [UniType] -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(LLLL)S" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
pprSpecErrs :: PprStyle -> Bag (Id, [Labda UniType]) -> Bag (Id, [Labda UniType]) -> Bag (TyCon, [Labda UniType]) -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222222 _N_ _S_ "LSLL" _N_ _N_ #-}
specialiseCallTys :: Bool -> Bool -> Bool -> [Bool] -> [UniType] -> [Labda UniType]
- {-# GHC_PRAGMA _A_ 5 _U_ 12211 _N_ _S_ "ELLLL" _N_ _N_ #-}
specialiseConstrTys :: [UniType] -> [Labda UniType]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
import SplitUniq(SplitUniqSupply)
import TyCon(TyCon)
import UniType(UniType)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
+data Bag a
+data FiniteMap a b
data SpecialiseData = SpecData Bool Bool [TyCon] [TyCon] (FiniteMap TyCon [[Labda UniType]]) (Bag (Id, [Labda UniType])) (Bag (Id, [Labda UniType])) (Bag (TyCon, [Labda UniType]))
initSpecData :: [TyCon] -> FiniteMap TyCon [[Labda UniType]] -> SpecialiseData
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
specProgram :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> [CoreBinding Id Id] -> SpecialiseData -> ([CoreBinding Id Id], SpecialiseData)
- {-# GHC_PRAGMA _A_ 4 _U_ 2121 _N_ _S_ "LU(ALL)LU(EALALLLL)" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import BasicLit(BasicLit)
import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import PrimOps(PrimOp)
import SplitUniq(SplitUniqSupply)
import StgSyn(StgAtom, StgBinderInfo, StgBinding, StgExpr, StgRhs, UpdateFlag)
import TyVar(TyVar)
import UniType(UniType)
-import Unique(Unique)
-data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data StgBinderInfo {-# GHC_PRAGMA NoStgBinderInfo | StgBinderInfo Bool Bool Bool Bool Bool #-}
-data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-}
-data StgRhs a b {-# GHC_PRAGMA StgRhsClosure CostCentre StgBinderInfo [b] UpdateFlag [a] (StgExpr a b) | StgRhsCon CostCentre Id [StgAtom b] #-}
+data CoreBinding a b
+data CoreExpr a b
+data Id
+data SplitUniqSupply
+data StgBinderInfo
+data StgBinding a b
+data StgRhs a b
topCoreBindsToStg :: SplitUniqSupply -> [CoreBinding Id Id] -> [StgBinding Id Id]
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(ALA)S" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import SplitUniq
import Unique -- the UniqueSupply monadery used herein
-import AbsPrel ( unpackCStringId, stringTy,
+import AbsPrel ( unpackCStringId, unpackCString2Id, stringTy,
integerTy, rationalTy, ratioDataCon,
PrimOp(..), -- For Int2IntegerOp etc
integerZeroId, integerPlusOneId, integerMinusOneId
\begin{code}
bOGUS_LVs :: PlainStgLiveVars
-bOGUS_LVs = panic "bOGUS_LVs"
+bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
bOGUS_FVs :: [Id]
-bOGUS_FVs = panic "bOGUS_FVs"
+bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
\end{code}
\begin{code}
do_top_bind env bind@(CoNonRec var rhs)
= coreBindToStg env bind `thenSUs` \ (stg_binds, new_env, float_binds) ->
-
+{- TESTING:
+ let
+ ppr_blah xs = ppInterleave ppComma (map pp_x xs)
+ pp_x (u,x) = ppBesides [pprUnique u, ppStr ": ", ppr PprDebug x]
+ in
+ pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $
+-}
case stg_binds of
[StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
-- Mega-special case; there's still a binding there
-- but instead be unpacked each time. But on some programs that costs a lot
-- [eg hpg], so now we update them.
- val = StgApp (StgVarAtom unpackCStringId)
- [StgLitAtom (MachStr s)]
+ val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string
+ StgApp (StgVarAtom unpackCString2Id)
+ [StgLitAtom (MachStr s),
+ StgLitAtom (mkMachInt (toInteger (_LENGTH_ s)))]
+ bOGUS_LVs
+ else
+ StgApp (StgVarAtom unpackCStringId)
+ [StgLitAtom (MachStr s)]
bOGUS_LVs
in
returnSUs (StgVarAtom var, unitBag (StgNonRec var rhs))
+ where
+ is_NUL c = c == '\0'
litToStgAtom (NoRepInteger i)
-- extremely convenient to look out for a few very common
returnSUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
rhs_binds)
where
-
-
+ --
-- We convert case x of {...; x' -> ...x'...}
-- to
-- case x of {...; _ -> ...x... }
-- default binder to the scrutinee.
--
new_env = case discrim of
- CoVar v -> addOneToIdEnv env binder (StgVarAtom v)
+ CoVar v -> addOneToIdEnv env binder (stgLookup env v)
other -> env
\end{code}
\end{code}
\begin{code}
+#ifdef DEBUG
coreExprToStg env other = panic "coreExprToStg: it really failed here"
+#endif
\end{code}
%************************************************************************
import Id(Id)
import StgSyn(StgRhs)
mapStgBindeesRhs :: (Id -> Id) -> StgRhs Id Id -> StgRhs Id Id
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface StgLint where
import CmdLineOpts(GlobalSwitch)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Pretty(PprStyle)
import StgSyn(PlainStgBinding(..), StgBinding, StgRhs)
-import UniType(UniType)
-import Unique(Unique)
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data Id
+data PprStyle
type PlainStgBinding = StgBinding Id Id
-data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-}
+data StgBinding a b
lintStgBindings :: PprStyle -> [Char] -> [StgBinding Id Id] -> [StgBinding Id Id]
- {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LLS" _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface StgSyn where
import Bag(Bag)
-import BasicLit(BasicLit, isLitLitLit)
+import BasicLit(BasicLit)
import CharSeq(CSeq)
-import Class(Class, ClassOp, cmpClass)
+import Class(Class, ClassOp)
import CmdLineOpts(GlobalSwitch)
-import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC)
-import HsBinds(Bind, Binds, Sig)
-import HsExpr(ArithSeqInfo, Expr, Qual)
-import HsLit(Literal)
-import HsMatches(GRHS, GRHSsAndBinds, Match)
+import CostCentre(CostCentre)
+import HsBinds(Binds)
+import HsExpr(Expr)
+import HsMatches(GRHS, GRHSsAndBinds)
import HsPat(InPat)
-import HsTypes(PolyType)
-import Id(Id, IdDetails)
+import Id(Id)
import IdEnv(IdEnv(..))
-import IdInfo(ArgUsageInfo, ArityInfo, DeforestInfo, DemandInfo, FBTypeInfo, IdInfo, SpecEnv, StrictnessInfo, UpdateInfo)
-import Inst(Inst)
-import InstEnv(InstTemplate)
+import IdInfo(IdInfo)
import Maybes(Labda)
import Name(Name)
-import NameTypes(FullName, Provenance, ShortName)
+import NameTypes(FullName, ShortName)
import Outputable(ExportFlag, NamedThing(..), Outputable(..))
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
import PrimKind(PrimKind)
import PrimOps(PrimOp)
-import SimplEnv(UnfoldingDetails)
import SrcLoc(SrcLoc)
-import TyCon(TyCon, cmpTyCon)
-import TyVar(TyVar, TyVarTemplate, cmpTyVar)
+import TyCon(TyCon)
+import TyVar(TyVar, TyVarTemplate)
import TyVarEnv(TyVarEnv(..))
-import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType, cmpUniType)
+import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType)
import UniqFM(UniqFM)
import UniqSet(UniqSet(..))
import Unique(Unique)
class NamedThing a where
getExportFlag :: a -> ExportFlag
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-}
isLocallyDefined :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-}
getOrigName :: a -> (_PackedString, _PackedString)
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-}
getOccurrenceName :: a -> _PackedString
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-}
getInformingModules :: a -> [_PackedString]
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-}
getSrcLoc :: a -> SrcLoc
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-}
getTheUnique :: a -> Unique
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-}
hasType :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-}
getType :: a -> UniType
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-}
fromPreludeCore :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-}
class Outputable a where
ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_
- {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-}
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
-data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-}
-data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-}
-data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-}
-data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-}
-data GRHS a b {-# GHC_PRAGMA GRHS (Expr a b) (Expr a b) SrcLoc | OtherwiseGRHS (Expr a b) SrcLoc #-}
-data GRHSsAndBinds a b {-# GHC_PRAGMA GRHSsAndBindsIn [GRHS a b] (Binds a b) | GRHSsAndBindsOut [GRHS a b] (Binds a b) UniType #-}
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Bag a
+data BasicLit
+data Class
+data ClassOp
+data CostCentre
+data Binds a b
+data Expr a b
+data GRHS a b
+data GRHSsAndBinds a b
+data InPat a
+data Id
type IdEnv a = UniqFM a
-data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-}
-data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-}
-data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-}
+data IdInfo
+data Labda a
+data Name
+data FullName
+data ShortName
+data ExportFlag
type PlainStgAtom = StgAtom Id
type PlainStgBinding = StgBinding Id Id
type PlainStgCaseAlternatives = StgCaseAlternatives Id Id
type PlainStgLiveVars = UniqFM Id
type PlainStgProgram = [StgBinding Id Id]
type PlainStgRhs = StgRhs Id Id
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
+data PrettyRep
+data PrimKind
+data PrimOp
+data SrcLoc
data StgAtom a = StgVarAtom a | StgLitAtom BasicLit
data StgBinderInfo = NoStgBinderInfo | StgBinderInfo Bool Bool Bool Bool Bool
data StgBinding a b = StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)]
data StgExpr a b = StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b)
type StgLiveVars a = UniqFM a
data StgRhs a b = StgRhsClosure CostCentre StgBinderInfo [b] UpdateFlag [a] (StgExpr a b) | StgRhsCon CostCentre Id [StgAtom b]
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
+data TyCon
+data TyVar
+data TyVarTemplate
type TyVarEnv a = UniqFM a
type SigmaType = UniType
type TauType = UniType
type ThetaType = [(Class, UniType)]
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data UniType
+data UniqFM a
type UniqSet a = UniqFM a
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Unique
data UpdateFlag = ReEntrant | Updatable | SingleEntry
-isLitLitLit :: BasicLit -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 12 \ (u0 :: BasicLit) -> case u0 of { _ALG_ _ORIG_ BasicLit MachLitLit (u1 :: _PackedString) (u2 :: PrimKind) -> _!_ True [] []; (u3 :: BasicLit) -> _!_ False [] [] } _N_ #-}
-cmpClass :: Class -> Class -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-cmpTyCon :: TyCon -> TyCon -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-cmpTyVar :: TyVar -> TyVar -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-cmpUniType :: Bool -> UniType -> UniType -> Int#
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
collectExportedStgBinders :: [StgBinding Id Id] -> [Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
getAtomKind :: StgAtom Id -> PrimKind
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: StgAtom Id) -> case u0 of { _ALG_ _ORIG_ StgSyn StgVarAtom (u1 :: Id) -> _APP_ _ORIG_ Id getIdKind [ u1 ]; _ORIG_ StgSyn StgLitAtom (u2 :: BasicLit) -> _APP_ _ORIG_ BasicLit kindOfBasicLit [ u2 ]; _NO_DEFLT_ } _N_ #-}
isLitLitStgAtom :: StgAtom a -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 5 _/\_ u0 -> \ (u1 :: StgAtom u0) -> case u1 of { _ALG_ _ORIG_ StgSyn StgVarAtom (u2 :: u0) -> _!_ False [] []; _ORIG_ StgSyn StgLitAtom (u3 :: BasicLit) -> _APP_ _ORIG_ BasicLit isLitLitLit [ u3 ]; _NO_DEFLT_ } _N_ #-}
pprPlainStgBinding :: PprStyle -> StgBinding Id Id -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
stgArgOcc :: StgBinderInfo
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgArity :: StgRhs Id Id -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: StgRhs Id Id) -> case u0 of { _ALG_ _ORIG_ StgSyn StgRhsCon (u1 :: CostCentre) (u2 :: Id) (u3 :: [StgAtom Id]) -> _!_ I# [] [0#]; _ORIG_ StgSyn StgRhsClosure (u4 :: CostCentre) (u5 :: StgBinderInfo) (u6 :: [Id]) (u7 :: UpdateFlag) (u8 :: [Id]) (u9 :: StgExpr Id Id) -> _APP_ _TYAPP_ _ORIG_ PreludeList length { Id } [ u8 ]; _NO_DEFLT_ } _N_ #-}
stgFakeFunAppOcc :: StgBinderInfo
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgNoUpdHeapOcc :: StgBinderInfo
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgNormalOcc :: StgBinderInfo
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgStdHeapOcc :: StgBinderInfo
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
stgUnsatOcc :: StgBinderInfo
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
instance Eq BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool)] [_CONSTM_ Eq (==) (BasicLit), _CONSTM_ Eq (/=) (BasicLit)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Class -> Class -> Bool), (Class -> Class -> Bool)] [_CONSTM_ Eq (==) (Class), _CONSTM_ Eq (/=) (Class)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ eqInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Eq (/=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Eq ClassOp
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool)] [_CONSTM_ Eq (==) (ClassOp), _CONSTM_ Eq (/=) (ClassOp)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Eq Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Id -> Id -> Bool), (Id -> Id -> Bool)] [_CONSTM_ Eq (==) (Id), _CONSTM_ Eq (/=) (Id)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool)] [_CONSTM_ Eq (==) (PrimKind), _CONSTM_ Eq (/=) (PrimKind)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Eq PrimOp
- {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(PrimOp -> PrimOp -> Bool), (PrimOp -> PrimOp -> Bool)] [_CONSTM_ Eq (==) (PrimOp), _CONSTM_ Eq (/=) (PrimOp)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: PrimOp) (u1 :: PrimOp) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u0 ] of { _PRIM_ (u2 :: Int#) -> case _APP_ _ORIG_ PrimOps tagOf_PrimOp [ u1 ] of { _PRIM_ (u3 :: Int#) -> _#_ eqInt# [] [u2, u3] } } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Eq TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool)] [_CONSTM_ Eq (==) (TyCon), _CONSTM_ Eq (/=) (TyCon)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool)] [_CONSTM_ Eq (==) (TyVar), _CONSTM_ Eq (/=) (TyVar)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq TyVarTemplate
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool)] [_CONSTM_ Eq (==) (TyVarTemplate), _CONSTM_ Eq (/=) (TyVarTemplate)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq UniType
- {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UniType -> UniType -> Bool), (UniType -> UniType -> Bool)] [_CONSTM_ Eq (==) (UniType), _CONSTM_ Eq (/=) (UniType)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Ord BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq BasicLit}}, (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> Bool), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> BasicLit), (BasicLit -> BasicLit -> _CMP_TAG)] [_DFUN_ Eq (BasicLit), _CONSTM_ Ord (<) (BasicLit), _CONSTM_ Ord (<=) (BasicLit), _CONSTM_ Ord (>=) (BasicLit), _CONSTM_ Ord (>) (BasicLit), _CONSTM_ Ord max (BasicLit), _CONSTM_ Ord min (BasicLit), _CONSTM_ Ord _tagCmp (BasicLit)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Class}}, (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Class), (Class -> Class -> Class), (Class -> Class -> _CMP_TAG)] [_DFUN_ Eq (Class), _CONSTM_ Ord (<) (Class), _CONSTM_ Ord (<=) (Class), _CONSTM_ Ord (>=) (Class), _CONSTM_ Ord (>) (Class), _CONSTM_ Ord max (Class), _CONSTM_ Ord min (Class), _CONSTM_ Ord _tagCmp (Class)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ ltInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ leInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord ClassOp
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq ClassOp}}, (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> _CMP_TAG)] [_DFUN_ Eq (ClassOp), _CONSTM_ Ord (<) (ClassOp), _CONSTM_ Ord (<=) (ClassOp), _CONSTM_ Ord (>=) (ClassOp), _CONSTM_ Ord (>) (ClassOp), _CONSTM_ Ord max (ClassOp), _CONSTM_ Ord min (ClassOp), _CONSTM_ Ord _tagCmp (ClassOp)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ ltInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ leInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ geInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ geInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ gtInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ gtInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Ord Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Id}}, (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Bool), (Id -> Id -> Id), (Id -> Id -> Id), (Id -> Id -> _CMP_TAG)] [_DFUN_ Eq (Id), _CONSTM_ Ord (<) (Id), _CONSTM_ Ord (<=) (Id), _CONSTM_ Ord (>=) (Id), _CONSTM_ Ord (>) (Id), _CONSTM_ Ord max (Id), _CONSTM_ Ord min (Id), _CONSTM_ Ord _tagCmp (Id)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq PrimKind}}, (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> Bool), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> PrimKind), (PrimKind -> PrimKind -> _CMP_TAG)] [_DFUN_ Eq (PrimKind), _CONSTM_ Ord (<) (PrimKind), _CONSTM_ Ord (<=) (PrimKind), _CONSTM_ Ord (>=) (PrimKind), _CONSTM_ Ord (>) (PrimKind), _CONSTM_ Ord max (PrimKind), _CONSTM_ Ord min (PrimKind), _CONSTM_ Ord _tagCmp (PrimKind)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _S_ "EE" _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Ord TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyCon}}, (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> _CMP_TAG)] [_DFUN_ Eq (TyCon), _CONSTM_ Ord (<) (TyCon), _CONSTM_ Ord (<=) (TyCon), _CONSTM_ Ord (>=) (TyCon), _CONSTM_ Ord (>) (TyCon), _CONSTM_ Ord max (TyCon), _CONSTM_ Ord min (TyCon), _CONSTM_ Ord _tagCmp (TyCon)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVar}}, (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> _CMP_TAG)] [_DFUN_ Eq (TyVar), _CONSTM_ Ord (<) (TyVar), _CONSTM_ Ord (<=) (TyVar), _CONSTM_ Ord (>=) (TyVar), _CONSTM_ Ord (>) (TyVar), _CONSTM_ Ord max (TyVar), _CONSTM_ Ord min (TyVar), _CONSTM_ Ord _tagCmp (TyVar)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord TyVarTemplate
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVarTemplate}}, (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> _CMP_TAG)] [_DFUN_ Eq (TyVarTemplate), _CONSTM_ Ord (<) (TyVarTemplate), _CONSTM_ Ord (<=) (TyVarTemplate), _CONSTM_ Ord (>=) (TyVarTemplate), _CONSTM_ Ord (>) (TyVarTemplate), _CONSTM_ Ord max (TyVarTemplate), _CONSTM_ Ord min (TyVarTemplate), _CONSTM_ Ord _tagCmp (TyVarTemplate)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Class -> ExportFlag), (Class -> Bool), (Class -> (_PackedString, _PackedString)), (Class -> _PackedString), (Class -> [_PackedString]), (Class -> SrcLoc), (Class -> Unique), (Class -> Bool), (Class -> UniType), (Class -> Bool)] [_CONSTM_ NamedThing getExportFlag (Class), _CONSTM_ NamedThing isLocallyDefined (Class), _CONSTM_ NamedThing getOrigName (Class), _CONSTM_ NamedThing getOccurrenceName (Class), _CONSTM_ NamedThing getInformingModules (Class), _CONSTM_ NamedThing getSrcLoc (Class), _CONSTM_ NamedThing getTheUnique (Class), _CONSTM_ NamedThing hasType (Class), _CONSTM_ NamedThing getType (Class), _CONSTM_ NamedThing fromPreludeCore (Class)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(LLAAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [ub, uc]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(ALSAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAAAS)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ug; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Unique) } [ _NOREP_S_ "NamedThing.Class.getTheUnique", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Bool) } [ _NOREP_S_ "NamedThing.Class.hasType", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> UniType) } [ _NOREP_S_ "NamedThing.Class.getType", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing a => NamedThing (InPat a)
- {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 0 _N_ _N_ _N_ _N_ #-}
instance NamedThing Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Id -> ExportFlag), (Id -> Bool), (Id -> (_PackedString, _PackedString)), (Id -> _PackedString), (Id -> [_PackedString]), (Id -> SrcLoc), (Id -> Unique), (Id -> Bool), (Id -> UniType), (Id -> Bool)] [_CONSTM_ NamedThing getExportFlag (Id), _CONSTM_ NamedThing isLocallyDefined (Id), _CONSTM_ NamedThing getOrigName (Id), _CONSTM_ NamedThing getOccurrenceName (Id), _CONSTM_ NamedThing getInformingModules (Id), _CONSTM_ NamedThing getSrcLoc (Id), _CONSTM_ NamedThing getTheUnique (Id), _CONSTM_ NamedThing hasType (Id), _CONSTM_ NamedThing getType (Id), _CONSTM_ NamedThing fromPreludeCore (Id)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Id) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:Id" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AALS)" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u1; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Id) -> _!_ True [] [] _N_,
- getType = _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing FullName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(FullName -> ExportFlag), (FullName -> Bool), (FullName -> (_PackedString, _PackedString)), (FullName -> _PackedString), (FullName -> [_PackedString]), (FullName -> SrcLoc), (FullName -> Unique), (FullName -> Bool), (FullName -> UniType), (FullName -> Bool)] [_CONSTM_ NamedThing getExportFlag (FullName), _CONSTM_ NamedThing isLocallyDefined (FullName), _CONSTM_ NamedThing getOrigName (FullName), _CONSTM_ NamedThing getOccurrenceName (FullName), _CONSTM_ NamedThing getInformingModules (FullName), _CONSTM_ NamedThing getSrcLoc (FullName), _CONSTM_ NamedThing getTheUnique (FullName), _CONSTM_ NamedThing hasType (FullName), _CONSTM_ NamedThing getType (FullName), _CONSTM_ NamedThing fromPreludeCore (FullName)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAEAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u4; _NO_DEFLT_ } _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ThisModule -> _!_ True [] []; _ORIG_ NameTypes InventedInThisModule -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LLAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [u1, u2]; _NO_DEFLT_ } _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(ALSAAA)" {_A_ 2 _U_ 11 _N_ _N_ _F_ _IF_ARGS_ 0 2 XC 10 \ (u0 :: _PackedString) (u1 :: Provenance) -> case u1 of { _ALG_ _ORIG_ NameTypes OtherPrelude (u2 :: _PackedString) -> u2; _ORIG_ NameTypes OtherModule (u3 :: _PackedString) (u4 :: [_PackedString]) -> u3; (u5 :: Provenance) -> u0 } _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ExportedByPreludeCore -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_ #-}
instance NamedThing ShortName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(ShortName -> ExportFlag), (ShortName -> Bool), (ShortName -> (_PackedString, _PackedString)), (ShortName -> _PackedString), (ShortName -> [_PackedString]), (ShortName -> SrcLoc), (ShortName -> Unique), (ShortName -> Bool), (ShortName -> UniType), (ShortName -> Bool)] [_CONSTM_ NamedThing getExportFlag (ShortName), _CONSTM_ NamedThing isLocallyDefined (ShortName), _CONSTM_ NamedThing getOrigName (ShortName), _CONSTM_ NamedThing getOccurrenceName (ShortName), _CONSTM_ NamedThing getInformingModules (ShortName), _CONSTM_ NamedThing getSrcLoc (ShortName), _CONSTM_ NamedThing getTheUnique (ShortName), _CONSTM_ NamedThing hasType (ShortName), _CONSTM_ NamedThing getType (ShortName), _CONSTM_ NamedThing fromPreludeCore (ShortName)] _N_
- getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ _ORIG_ Outputable NotExported [] [] _N_,
- isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ True [] [] _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(SA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: _PackedString) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u1; _NO_DEFLT_ } _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u2; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AA)" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> _!_ False [] []; _NO_DEFLT_ } _N_ #-}
instance NamedThing TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyCon -> ExportFlag), (TyCon -> Bool), (TyCon -> (_PackedString, _PackedString)), (TyCon -> _PackedString), (TyCon -> [_PackedString]), (TyCon -> SrcLoc), (TyCon -> Unique), (TyCon -> Bool), (TyCon -> UniType), (TyCon -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyCon), _CONSTM_ NamedThing isLocallyDefined (TyCon), _CONSTM_ NamedThing getOrigName (TyCon), _CONSTM_ NamedThing getOccurrenceName (TyCon), _CONSTM_ NamedThing getInformingModules (TyCon), _CONSTM_ NamedThing getSrcLoc (TyCon), _CONSTM_ NamedThing getTheUnique (TyCon), _CONSTM_ NamedThing hasType (TyCon), _CONSTM_ NamedThing getType (TyCon), _CONSTM_ NamedThing fromPreludeCore (TyCon)] _N_
- getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getTheUnique = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Unique } [ _NOREP_S_ "NamedThing.TyCon.getTheUnique" ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> Bool) } [ _NOREP_S_ "NamedThing.TyCon.hasType", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> UniType) } [ _NOREP_S_ "NamedThing.TyCon.getType", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
instance NamedThing TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVar -> ExportFlag), (TyVar -> Bool), (TyVar -> (_PackedString, _PackedString)), (TyVar -> _PackedString), (TyVar -> [_PackedString]), (TyVar -> SrcLoc), (TyVar -> Unique), (TyVar -> Bool), (TyVar -> UniType), (TyVar -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVar), _CONSTM_ NamedThing isLocallyDefined (TyVar), _CONSTM_ NamedThing getOrigName (TyVar), _CONSTM_ NamedThing getOccurrenceName (TyVar), _CONSTM_ NamedThing getInformingModules (TyVar), _CONSTM_ NamedThing getSrcLoc (TyVar), _CONSTM_ NamedThing getTheUnique (TyVar), _CONSTM_ NamedThing hasType (TyVar), _CONSTM_ NamedThing getType (TyVar), _CONSTM_ NamedThing fromPreludeCore (TyVar)] _N_
- getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ _ORIG_ Outputable NotExported [] [] _N_,
- isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ True [] [] _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVar" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar UserTyVar (u1 :: Unique) (u2 :: ShortName) -> case u2 of { _ALG_ _ORIG_ NameTypes ShortName (u3 :: _PackedString) (u4 :: SrcLoc) -> u4; _NO_DEFLT_ }; (u5 :: TyVar) -> _ORIG_ SrcLoc mkUnknownSrcLoc } _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar PolySysTyVar (u1 :: Unique) -> u1; _ORIG_ TyVar PrimSysTyVar (u2 :: Unique) -> u2; _ORIG_ TyVar OpenSysTyVar (u3 :: Unique) -> u3; _ORIG_ TyVar UserTyVar (u4 :: Unique) (u5 :: ShortName) -> u4; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ False [] [] _N_ #-}
instance NamedThing TyVarTemplate
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVarTemplate -> ExportFlag), (TyVarTemplate -> Bool), (TyVarTemplate -> (_PackedString, _PackedString)), (TyVarTemplate -> _PackedString), (TyVarTemplate -> [_PackedString]), (TyVarTemplate -> SrcLoc), (TyVarTemplate -> Unique), (TyVarTemplate -> Bool), (TyVarTemplate -> UniType), (TyVarTemplate -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVarTemplate), _CONSTM_ NamedThing isLocallyDefined (TyVarTemplate), _CONSTM_ NamedThing getOrigName (TyVarTemplate), _CONSTM_ NamedThing getOccurrenceName (TyVarTemplate), _CONSTM_ NamedThing getInformingModules (TyVarTemplate), _CONSTM_ NamedThing getSrcLoc (TyVarTemplate), _CONSTM_ NamedThing getTheUnique (TyVarTemplate), _CONSTM_ NamedThing hasType (TyVarTemplate), _CONSTM_ NamedThing getType (TyVarTemplate), _CONSTM_ NamedThing fromPreludeCore (TyVarTemplate)] _N_
- getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ _ORIG_ Outputable NotExported [] [] _N_,
- isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ True [] [] _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVarTemplate" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> _ORIG_ SrcLoc mkUnknownSrcLoc; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> case u4 of { _ALG_ _ORIG_ NameTypes ShortName (u5 :: _PackedString) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> u1; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> u3; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ False [] [] _N_ #-}
instance (Outputable a, Outputable b) => Outputable (a, b)
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-}
instance Outputable BasicLit
- {-# GHC_PRAGMA _M_ BasicLit {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (BasicLit) _N_
- ppr = _A_ 0 _U_ 2122 _N_ _N_ _N_ _N_ #-}
instance Outputable Bool
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_
- ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Class) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(AU(LLLLAA)AAAAAAAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable ClassOp
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Binds a b)
- {-# GHC_PRAGMA _M_ HsBinds {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (Expr a b)
- {-# GHC_PRAGMA _M_ HsExpr {-dfun-} _A_ 4 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHS a b)
- {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHS u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr: GRHSs", u8, u9 ] _N_ #-}
instance (NamedThing a, Outputable a, NamedThing b, Outputable b) => Outputable (GRHSsAndBinds a b)
- {-# GHC_PRAGMA _M_ HsMatches {-dfun-} _A_ 8 _U_ 2222 _N_ _S_ _!_ _F_ _IF_ARGS_ 2 8 XXXXXXXX 4 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: {{Outputable u0}}) (u4 :: {{NamedThing u1}}) (u5 :: {{Outputable u1}}) (u6 :: PprStyle) (u7 :: GRHSsAndBinds u0 u1) (u8 :: Int) (u9 :: Bool) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Int -> Bool -> PrettyRep) } [ _NOREP_S_ "ppr:GRHSsAndBinds", u8, u9 ] _N_ #-}
instance Outputable a => Outputable (InPat a)
- {-# GHC_PRAGMA _M_ HsPat {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Outputable Id
- {-# GHC_PRAGMA _M_ Id {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _N_ _N_ #-}
instance Outputable FullName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (FullName) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LLLLAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable ShortName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (ShortName) _N_
- ppr = _A_ 4 _U_ 0120 _N_ _S_ "AU(LA)LA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable PrimKind
- {-# GHC_PRAGMA _M_ PrimKind {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (PrimKind) _N_
- ppr = _A_ 2 _U_ 0120 _N_ _S_ "AL" {_A_ 1 _U_ 120 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable PrimOp
- {-# GHC_PRAGMA _M_ PrimOps {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PrimOps pprPrimOp _N_ #-}
instance Outputable a => Outputable (StgAtom a)
- {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _F_ _IF_ARGS_ 1 3 XXC 8 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: StgAtom u0) -> case u3 of { _ALG_ _ORIG_ StgSyn StgVarAtom (u4 :: u0) -> _APP_ u1 [ u2, u4 ]; _ORIG_ StgSyn StgLitAtom (u5 :: BasicLit) -> _APP_ _CONSTM_ Outputable ppr (BasicLit) [ u2, u5 ]; _NO_DEFLT_ } _N_ #-}
instance (Outputable a, Outputable b, Ord b) => Outputable (StgBinding a b)
- {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
instance (Outputable a, Outputable b, Ord b) => Outputable (StgExpr a b)
- {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 3 _U_ 222 _N_ _N_ _N_ _N_ #-}
instance (Outputable a, Outputable b, Ord b) => Outputable (StgRhs a b)
- {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLS" _N_ _N_ #-}
instance Outputable UpdateFlag
- {-# GHC_PRAGMA _M_ StgSyn {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (UpdateFlag) _N_
- ppr = _A_ 4 _U_ 0120 _N_ _S_ "ALLA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyCon) _N_
- ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVar) _N_
- ppr = _A_ 2 _U_ 1122 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable TyVarTemplate
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVarTemplate) _N_
- ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable UniType
- {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ #-}
instance Outputable a => Outputable [a]
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-}
instance Text Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_
- readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_,
- showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
import SaLib(AbsVal, AbsValEnv, AnalysisKind)
import UniType(UniType)
absEval :: AnalysisKind -> CoreExpr Id Id -> AbsValEnv -> AbsVal
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSL" _N_ _N_ #-}
findDemand :: AbsValEnv -> AbsValEnv -> CoreExpr Id Id -> Id -> Demand
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "LLLU(LSLL)" _N_ _N_ #-}
-findStrictness :: [UniType] -> AbsVal -> AbsVal -> [Demand]
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ #-}
+findStrictness :: (Bool, Bool) -> [UniType] -> AbsVal -> AbsVal -> [Demand]
fixpoint :: AnalysisKind -> [Id] -> [CoreExpr Id Id] -> AbsValEnv -> [AbsVal]
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "LSLL" _N_ _N_ #-}
isBot :: AbsVal -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
widen :: AnalysisKind -> AbsVal -> AbsVal
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "ES" _N_ _N_ #-}
--import FiniteMap
import Outputable
-import AbsPrel ( PrimOp(..), PrimKind )
+import AbsPrel ( PrimOp(..),
+ intTyCon, integerTyCon, doubleTyCon,
+ floatTyCon, wordTyCon, addrTyCon,
+ PrimKind
+ )
import AbsUniType ( isPrimType, getUniDataTyCon_maybe,
maybeSingleConstructorTyCon,
returnsRealWorld,
See notes on @addStrictnessInfoToId@.
\begin{code}
-findStrictness :: [UniType] -- Types of args in which strictness is wanted
+findStrictness :: StrAnalFlags
+ -> [UniType] -- Types of args in which strictness is wanted
-> AbsVal -- Abstract strictness value of function
-> AbsVal -- Abstract absence value of function
-> [Demand] -- Resulting strictness annotation
-findStrictness [] str_val abs_val = []
+findStrictness strflags [] str_val abs_val = []
-findStrictness (ty:tys) str_val abs_val
+findStrictness strflags (ty:tys) str_val abs_val
= let
- demand = findRecDemand [] str_fn abs_fn ty
+ demand = findRecDemand strflags [] str_fn abs_fn ty
str_fn val = absApply StrAnal str_val val
abs_fn val = absApply AbsAnal abs_val val
- demands = findStrictness tys (absApply StrAnal str_val AbsTop)
- (absApply AbsAnal abs_val AbsTop)
+ demands = findStrictness strflags tys
+ (absApply StrAnal str_val AbsTop)
+ (absApply AbsAnal abs_val AbsTop)
in
- -- pprTrace "findRecDemand:" (ppCat [ppr PprDebug demand, ppr PprDebug ty]) (
demand : demands
- -- )
\end{code}
\begin{code}
findDemandStrOnly str_env expr binder -- Only strictness environment available
- = findRecDemand [] str_fn abs_fn (getIdUniType binder)
+ = findRecDemand strflags [] str_fn abs_fn (getIdUniType binder)
where
str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
abs_fn val = AbsBot -- Always says poison; so it looks as if
-- nothing is absent; safe
-
+ strflags = getStrAnalFlags str_env
findDemandAbsOnly abs_env expr binder -- Only absence environment available
- = findRecDemand [] str_fn abs_fn (getIdUniType binder)
+ = findRecDemand strflags [] str_fn abs_fn (getIdUniType binder)
where
str_fn val = AbsBot -- Always says non-termination;
-- that'll make findRecDemand peer into the
-- structure of the value.
abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
+ strflags = getStrAnalFlags abs_env
findDemand str_env abs_env expr binder
- = findRecDemand [] str_fn abs_fn (getIdUniType binder)
+ = findRecDemand strflags [] str_fn abs_fn (getIdUniType binder)
where
str_fn val = absEval StrAnal expr (addOneToAbsValEnv str_env binder val)
abs_fn val = absEval AbsAnal expr (addOneToAbsValEnv abs_env binder val)
+ strflags = getStrAnalFlags str_env
\end{code}
@findRecDemand@ is where we finally convert strictness/absence info
Ho hum.
\begin{code}
-findRecDemand :: [TyCon] -- TyCons already seen; used to avoid
+findRecDemand :: StrAnalFlags
+ -> [TyCon] -- TyCons already seen; used to avoid
-- zooming into recursive types
-> (AbsVal -> AbsVal) -- The strictness function
-> (AbsVal -> AbsVal) -- The absence function
-> UniType -- The type of the argument
-> Demand
-findRecDemand seen str_fn abs_fn ty
+findRecDemand strflags seen str_fn abs_fn ty
= if isPrimType ty then -- It's a primitive type!
wwPrim
-- We prefer absence over strictness: see NOTE above.
WwLazy True
- else if not (isBot (str_fn AbsBot)) then -- It's not strict
- WwLazy False
+ else if not (all_strict ||
+ (num_strict && is_numeric_type ty) ||
+ (isBot (str_fn AbsBot))) then
+ WwLazy False -- It's not strict and we're not pretending
- else -- It's strict!
+ else -- It's strict (or we're pretending it is)!
case getUniDataTyCon_maybe ty of
prod_len = length cmpnt_tys
compt_strict_infos
- = [ findRecDemand (tycon:seen)
+ = [ findRecDemand strflags (tycon:seen)
(\ cmpnt_val ->
str_fn (mkMainlyTopProd prod_len i cmpnt_val)
)
else
wwStrict
where
+ (all_strict, num_strict) = strflags
+
+ is_numeric_type ty
+ = case (getUniDataTyCon_maybe ty) of -- NB: duplicates stuff done above
+ Nothing -> False
+ Just (tycon, _, _)
+ | tycon `is_elem`
+ [intTyCon, integerTyCon,
+ doubleTyCon, floatTyCon,
+ wordTyCon, addrTyCon]
+ -> True
+ _{-something else-} -> False
+ where
+ is_elem = isIn "is_numeric_type"
+
-- mkMainlyTopProd: make an AbsProd that is all AbsTops ("n"-1 of
-- them) except for a given value in the "i"th position.
import BasicLit(BasicLit)
import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
+import Id(Id)
import IdEnv(IdEnv(..))
-import IdInfo(Demand, IdInfo, StrictnessInfo)
+import IdInfo(Demand, StrictnessInfo)
import Maybes(Labda)
import Outputable(Outputable)
import PlainCore(PlainCoreExpr(..))
import UniqFM(UniqFM)
import Unique(Unique)
data AbsVal = AbsTop | AbsBot | AbsProd [AbsVal] | AbsFun [Id] (CoreExpr Id Id) AbsValEnv | AbsApproxFun [Demand]
-data AbsValEnv {-# GHC_PRAGMA AbsValEnv Bool (UniqFM AbsVal) #-}
+data AbsValEnv
type AbsenceEnv = AbsValEnv
data AnalysisKind = StrAnal | AbsAnal
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data CoreExpr a b
+data Id
type IdEnv a = UniqFM a
-data Demand {-# GHC_PRAGMA WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum #-}
+data Demand
type PlainCoreExpr = CoreExpr Id Id
+type StrAnalFlags = (Bool, Bool)
type StrictEnv = AbsValEnv
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data UniqFM a
+data Unique
absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "LS" _N_ _N_ #-}
addOneToAbsValEnv :: AbsValEnv -> Id -> AbsVal -> AbsValEnv
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(LL)LL" {_A_ 4 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+getStrAnalFlags :: AbsValEnv -> (Bool, Bool)
growAbsValEnvList :: AbsValEnv -> [(Id, AbsVal)] -> AbsValEnv
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(LL)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupAbsValEnv :: AbsValEnv -> Id -> Labda AbsVal
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(EL)L" {_A_ 3 _U_ 121 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-nullAbsValEnv :: Bool -> AbsValEnv
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
+nullAbsValEnv :: (Bool, Bool) -> AbsValEnv
instance Outputable AbsVal
- {-# GHC_PRAGMA _M_ SaLib {-dfun-} _A_ 2 _N_ _N_ _N_ _N_ _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
instance Text AnalysisKind
- {-# GHC_PRAGMA _M_ SaLib {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(AnalysisKind, [Char])]), (Int -> AnalysisKind -> [Char] -> [Char]), ([Char] -> [([AnalysisKind], [Char])]), ([AnalysisKind] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (AnalysisKind), _CONSTM_ Text showsPrec (AnalysisKind), _CONSTM_ Text readList (AnalysisKind), _CONSTM_ Text showList (AnalysisKind)] _N_
- readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(AnalysisKind, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
AbsVal(..),
AnalysisKind(..),
AbsValEnv{-abstract-}, StrictEnv(..), AbsenceEnv(..),
+ StrAnalFlags(..), getStrAnalFlags,
nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList,
lookupAbsValEnv,
absValFromStrictness,
\begin{code}
data AbsValEnv = AbsValEnv StrAnalFlags (IdEnv AbsVal)
-type StrAnalFlags = Bool -- True <=> make everything strict
+
+type StrAnalFlags
+ = (Bool, -- True <=> AllStrict flag is set
+ Bool) -- True <=> NumbersStrict flag is set
type StrictEnv = AbsValEnv -- Environment for strictness analysis
type AbsenceEnv = AbsValEnv -- Environment for absence analysis
-nullAbsValEnv x = AbsValEnv x nullIdEnv
+nullAbsValEnv flags -- this is the one and only way to create AbsValEnvs
+ = AbsValEnv flags nullIdEnv
+
addOneToAbsValEnv (AbsValEnv x idenv) y z = AbsValEnv x (addOneToIdEnv idenv y z)
growAbsValEnvList (AbsValEnv x idenv) ys = AbsValEnv x (growIdEnvList idenv ys)
-lookupAbsValEnv (AbsValEnv do_all_strict idenv) y
- = if do_all_strict
- then Just AbsBot
- else lookupIdEnv idenv y
+lookupAbsValEnv (AbsValEnv _ idenv) y
+ = lookupIdEnv idenv y
+
+getStrAnalFlags (AbsValEnv flags _) = flags
\end{code}
\begin{code}
import CoreSyn(CoreBinding)
import Id(Id)
import SplitUniq(SplitUniqSupply)
-saTopBinds :: Bool -> [CoreBinding Id Id] -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
+saTopBinds :: (Bool, Bool) -> [CoreBinding Id Id] -> [CoreBinding Id Id]
saWwTopBinds :: SplitUniqSupply -> (GlobalSwitch -> Bool) -> [CoreBinding Id Id] -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "LSL" _N_ _N_ #-}
saWwTopBinds us switch_chker binds
= let
- do_all_strict = switch_chker AllStrict
+ strflags = (switch_chker AllStrict, switch_chker NumbersStrict)
-- mark each binder with its strictness
#ifndef OMIT_STRANAL_STATS
(binds_w_strictness, sa_stats)
- = sa_top_binds do_all_strict binds nullSaStats
+ = sa_top_binds strflags binds nullSaStats
#else
binds_w_strictness
- = sa_top_binds do_all_strict binds
+ = sa_top_binds strflags binds
#endif
in
-- possibly show what we decided about strictness...
@AbsValEnv@ maps an @Id@ to its @AbsVal@).
\begin{code}
-saTopBinds :: Bool -> [PlainCoreBinding] -> [PlainCoreBinding] -- exported
-sa_top_binds :: Bool -> [PlainCoreBinding] -> SaM [PlainCoreBinding] -- not exported
+saTopBinds :: StrAnalFlags -> [PlainCoreBinding] -> [PlainCoreBinding] -- exported
+sa_top_binds :: StrAnalFlags -> [PlainCoreBinding] -> SaM [PlainCoreBinding] -- not exported
-saTopBinds do_all_strict binds
+saTopBinds strflags binds
#ifndef OMIT_STRANAL_STATS
- = fst (sa_top_binds do_all_strict binds nullSaStats)
+ = fst (sa_top_binds strflags binds nullSaStats)
#else
- = sa_top_binds do_all_strict binds
+ = sa_top_binds strflags binds
#endif
-sa_top_binds do_all_strict binds
- = do_it (nullAbsValEnv do_all_strict) (nullAbsValEnv False) binds
+sa_top_binds strflags binds
+ = let
+ starting_abs_env = nullAbsValEnv strflags
+ in
+ do_it starting_abs_env starting_abs_env binds
where
do_it _ _ [] = returnSa []
do_it senv aenv (b:bs)
saTopBind str_env abs_env (CoNonRec binder rhs)
= saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
let
- str_rhs = absEval StrAnal rhs str_env
- abs_rhs = absEval AbsAnal rhs abs_env
+ strflags = getStrAnalFlags str_env
+
+ str_rhs = absEval StrAnal rhs str_env
+ abs_rhs = absEval AbsAnal rhs abs_env
widened_str_rhs = widen StrAnal str_rhs
widened_abs_rhs = widen AbsAnal abs_rhs
-- The widening above is done for efficiency reasons.
-- See notes on CoLet case in SaAbsInt.lhs
- new_binder = addStrictnessInfoToId widened_str_rhs widened_abs_rhs
- binder
- rhs
+ new_binder
+ = addStrictnessInfoToId
+ strflags
+ widened_str_rhs widened_abs_rhs
+ binder
+ rhs
-- Augment environments with a mapping of the
-- binder to its abstract values, computed by absEval
saTopBind str_env abs_env (CoRec pairs)
= let
+ strflags = getStrAnalFlags str_env
(binders,rhss) = unzip pairs
str_rhss = fixpoint StrAnal binders rhss str_env
abs_rhss = fixpoint AbsAnal binders rhss abs_env
-- fixpoint returns widened values
new_str_env = growAbsValEnvList str_env (binders `zip` str_rhss)
new_abs_env = growAbsValEnvList abs_env (binders `zip` abs_rhss)
- new_binders = zipWith4 addStrictnessInfoToId str_rhss abs_rhss binders rhss
+ new_binders = zipWith4 (addStrictnessInfoToId strflags)
+ str_rhss abs_rhss binders rhss
in
mapSa (saExpr new_str_env new_abs_env) rhss `thenSa` \ new_rhss ->
let
= -- Analyse the RHS in the environment at hand
saExpr str_env abs_env rhs `thenSa` \ new_rhs ->
let
+ strflags = getStrAnalFlags str_env
+
-- Bind this binder to the abstract value of the RHS; analyse
-- the body of the `let' in the extended environment.
str_rhs_val = absEval StrAnal rhs str_env
-- Now determine the strictness of this binder; use that info
-- to record DemandInfo/StrictnessInfo in the binder.
- new_binder = addStrictnessInfoToId widened_str_rhs widened_abs_rhs
+ new_binder = addStrictnessInfoToId strflags
+ widened_str_rhs widened_abs_rhs
(addDemandInfoToId str_env abs_env body binder)
rhs
in
saExpr str_env abs_env (CoLet (CoRec pairs) body)
= let
+ strflags = getStrAnalFlags str_env
(binders,rhss) = unzip pairs
str_vals = fixpoint StrAnal binders rhss str_env
abs_vals = fixpoint AbsAnal binders rhss abs_env
-- deciding that y is absent, which is plain wrong!
-- It's much easier simply not to do this.
- improved_binders = zipWith4 addStrictnessInfoToId str_vals abs_vals binders rhss
+ improved_binders = zipWith4 (addStrictnessInfoToId strflags)
+ str_vals abs_vals binders rhss
+
whiter_than_white_binders = launder improved_binders
new_pairs = whiter_than_white_binders `zip` new_rhss
%* *
%************************************************************************
-Important note (Sept 93). @addStrictnessInfoToId@ is used only for let(rec)
-bound variables, and is use to attach the strictness (not demand) info
-to the binder. We are careful to restrict this strictness info to the
-lambda-bound arguments which are actually visible, at the top level,
-lest we accidentally lose laziness by eagerly looking for an "extra" argument.
-So we "dig for lambdas" in a rather syntactic way.
+Important note (Sept 93). @addStrictnessInfoToId@ is used only for
+let(rec) bound variables, and is use to attach the strictness (not
+demand) info to the binder. We are careful to restrict this
+strictness info to the lambda-bound arguments which are actually
+visible, at the top level, lest we accidentally lose laziness by
+eagerly looking for an "extra" argument. So we "dig for lambdas" in a
+rather syntactic way.
A better idea might be to have some kind of arity analysis to
tell how many args could safely be grabbed.
\begin{code}
addStrictnessInfoToId
- :: AbsVal -- Abstract strictness value
+ :: StrAnalFlags
+ -> AbsVal -- Abstract strictness value
-> AbsVal -- Ditto absence
-> Id -- The id
-> PlainCoreExpr -- Its RHS
-> Id -- Augmented with strictness
-addStrictnessInfoToId str_val abs_val binder body
+addStrictnessInfoToId strflags str_val abs_val binder body
= if isWrapperId binder then
binder -- Avoid clobbering existing strictness info
-- (and, more importantly, worker info).
case (digForLambdas body) of { (_, lambda_bounds, rhs) ->
let
tys = map getIdUniType lambda_bounds
- strictness = findStrictness tys str_val abs_val
+ strictness = findStrictness strflags tys str_val abs_val
in
binder `addIdStrictness` mkStrictnessInfo strictness Nothing
}
import Id(Id)
import SplitUniq(SplitUniqSupply)
workersAndWrappers :: [CoreBinding Id Id] -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> [CoreBinding Id Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 112 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface WwLib where
import BasicLit(BasicLit)
-import Class(Class)
import CmdLineOpts(GlobalSwitch)
import CoreSyn(CoreAtom, CoreBinding, CoreCaseAlternatives, CoreExpr)
import CostCentre(CostCentre)
-import Id(Id, IdDetails)
-import IdInfo(Demand, IdInfo, StrictnessInfo)
+import Id(Id)
+import IdInfo(Demand, StrictnessInfo)
import Maybes(Labda, MaybeErr)
-import NameTypes(ShortName)
import PlainCore(PlainCoreBinding(..), PlainCoreExpr(..))
import PrimOps(PrimOp)
-import SplitUniq(SUniqSM(..), SplitUniqSupply, getSUnique, splitUniqSupply)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import SplitUniq(SUniqSM(..), SplitUniqSupply)
+import TyVar(TyVar)
import UniType(UniType)
-import Unique(Unique, mkUniqueGrimily)
+import Unique(Unique)
infixr 9 `thenWw`
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Demand {-# GHC_PRAGMA WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum #-}
-data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-}
+data GlobalSwitch
+data CoreBinding a b
+data CoreExpr a b
+data Id
+data Demand
+data MaybeErr a b
type PlainCoreBinding = CoreBinding Id Id
type PlainCoreExpr = CoreExpr Id Id
type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data SplitUniqSupply
+data TyVar
+data UniType
+data Unique
data WwBinding = WwLet [CoreBinding Id Id] | WwCase (CoreExpr Id Id -> CoreExpr Id Id)
type WwM a = SplitUniqSupply -> (GlobalSwitch -> Bool) -> a
-getSUnique :: SplitUniqSupply -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> case u1 of { _ALG_ I# (u4 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u4]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getUniqueWw :: SplitUniqSupply -> (GlobalSwitch -> Bool) -> Unique
- {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _S_ "U(U(P)AA)A" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 2 CX 4 \ (u0 :: SplitUniqSupply) (u1 :: GlobalSwitch -> Bool) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u2 :: Int) (u3 :: SplitUniqSupply) (u4 :: SplitUniqSupply) -> case u2 of { _ALG_ I# (u5 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u5]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
mAX_WORKER_ARGS :: Int
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ I# [] [6#] _N_ #-}
mapWw :: (a -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> b) -> [a] -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> [b]
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
-mkUniqueGrimily :: Int# -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_ #-}
mkWwBodies :: UniType -> [TyVar] -> [Id] -> [Demand] -> SplitUniqSupply -> Labda (Id -> CoreExpr Id Id, CoreExpr Id Id -> CoreExpr Id Id, StrictnessInfo, UniType -> UniType)
- {-# GHC_PRAGMA _A_ 4 _U_ 12222 _N_ _S_ "LLLS" _N_ _N_ #-}
returnWw :: a -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> a
- {-# GHC_PRAGMA _A_ 3 _U_ 100 _N_ _S_ "SLL" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: SplitUniqSupply) (u3 :: GlobalSwitch -> Bool) -> u1 _N_ #-}
-splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-}
thenWw :: (SplitUniqSupply -> (GlobalSwitch -> Bool) -> a) -> (a -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> b) -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> b
- {-# GHC_PRAGMA _A_ 4 _U_ 1112 _N_ _S_ "LSSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: SplitUniqSupply -> (GlobalSwitch -> Bool) -> u0) (u3 :: u0 -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> u1) (u4 :: SplitUniqSupply) (u5 :: GlobalSwitch -> Bool) -> case u4 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u6 :: Int) (u7 :: SplitUniqSupply) (u8 :: SplitUniqSupply) -> let {(u9 :: u0) = _APP_ u2 [ u7, u5 ]} in _APP_ u3 [ u9, u8, u5 ]; _NO_DEFLT_ } _N_ #-}
uniqSMtoWwM :: (SplitUniqSupply -> a) -> SplitUniqSupply -> (GlobalSwitch -> Bool) -> a
- {-# GHC_PRAGMA _A_ 3 _U_ 120 _N_ _S_ "SLA" {_A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 2 _/\_ u0 -> \ (u1 :: SplitUniqSupply -> u0) (u2 :: SplitUniqSupply) -> _APP_ u1 [ u2 ] _N_} _F_ _IF_ARGS_ 1 3 XXX 2 _/\_ u0 -> \ (u1 :: SplitUniqSupply -> u0) (u2 :: SplitUniqSupply) (u3 :: GlobalSwitch -> Bool) -> _APP_ u1 [ u2 ] _N_ #-}
import HsLit(Literal)
import HsMatches(GRHSsAndBinds, Match)
import HsPat(TypecheckedPat)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Inst(Inst)
-import Maybes(Labda)
-import PreludeGlaST(_MutableArray)
import Pretty(PprStyle, PrettyRep)
import SplitUniq(SplitUniqSupply)
import SrcLoc(SrcLoc)
import Subst(Subst)
import TyVar(TyVar)
import UniType(UniType)
-import Unique(Unique)
-data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-}
-data MonoBinds a b {-# GHC_PRAGMA EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc #-}
-data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-}
+data Binds a b
+data MonoBinds a b
+data TypecheckedPat
+data Id
+data Subst
applyTcSubstToBinds :: Binds Id TypecheckedPat -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Binds Id TypecheckedPat, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 2222222 _N_ _S_ "S" _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Disambig where
import Bag(Bag)
-import CharSeq(CSeq)
import Class(Class)
import CmdLineOpts(GlobalSwitch)
import ErrUtils(Error(..))
import Id(Id)
import Inst(Inst, InstOrigin, OverloadedLit)
-import Maybes(Labda)
-import PreludeGlaST(_MutableArray)
-import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
+import Pretty(PprStyle, Pretty(..), PrettyRep)
import SplitUniq(SplitUniqSupply)
import SrcLoc(SrcLoc)
import Subst(Subst)
import TcMonad(TcResult)
import UniType(UniType)
import Unique(Unique, UniqueSupply)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
+data Bag a
type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data Inst
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-}
-data TcResult a {-# GHC_PRAGMA TcSucceeded a Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) | TcFailed Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) #-}
-data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-}
+data PrettyRep
+data SrcLoc
+data Subst
+data TcResult a
+data UniqueSupply
disambiguateDicts :: [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
- {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-}
import HsExpr(Expr)
import HsLit(Literal)
import HsPat(TypecheckedPat)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Inst(Inst, InstOrigin, OverloadedLit)
import LIE(LIE)
import Maybes(Labda)
import Name(Name)
import NameTypes(FullName, ShortName)
-import PreludeGlaST(_MutableArray)
import PreludePS(_PackedString)
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
import SimplEnv(UnfoldingGuidance)
import Subst(Subst)
import TcMonad(TcResult)
import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import TyVar(TyVar)
import UniType(UniType)
-import UniqFM(UniqFM)
import Unique(Unique, UniqueSupply)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data E {-# GHC_PRAGMA MkE (UniqFM TyCon) (UniqFM Id) (UniqFM Id) (UniqFM Class) #-}
+data Bag a
+data E
type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Bind a b {-# GHC_PRAGMA EmptyBind | NonRecBind (MonoBinds a b) | RecBind (MonoBinds a b) #-}
-data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-}
-data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
-data LIE {-# GHC_PRAGMA MkLIE [Inst] #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data Bind a b
+data Binds a b
+data TypecheckedPat
+data Id
+data Inst
+data LIE
+data Name
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
+data PrettyRep
data SignatureInfo = TySigInfo Id [TyVar] [Inst] UniType SrcLoc | ValSpecInfo Name UniType (Labda Name) SrcLoc | ValInlineInfo Name UnfoldingGuidance SrcLoc | ValDeforestInfo Name SrcLoc | ValMagicUnfoldingInfo Name _PackedString SrcLoc
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-}
-data TcResult a {-# GHC_PRAGMA TcSucceeded a Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) | TcFailed Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-}
+data SrcLoc
+data Subst
+data TcResult a
+data TyVar
+data UniType
+data UniqueSupply
checkSigTyVars :: [TyVar] -> [TyVar] -> UniType -> UniType -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [TyVar]
- {-# GHC_PRAGMA _A_ 11 _U_ 22222222122 _N_ _S_ "LSLSLLLLU(AAS)LL" _N_ _N_ #-}
genBinds :: Bool -> E -> Bind Id TypecheckedPat -> LIE -> [(Name, Id)] -> [SignatureInfo] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Binds Id TypecheckedPat, LIE, [(Name, Id)])
- {-# GHC_PRAGMA _A_ 12 _U_ 212112222122 _N_ _S_ "LU(AASA)LLLSLLLU(AAS)LL" _N_ _N_ #-}
import TyVar(TyVar)
import UniType(UniType)
specId :: Id -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((Expr Id TypecheckedPat, LIE, UniType), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 2002222 _N_ _S_ "U(LSLL)AALLLL" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
specTy :: InstOrigin -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (([TyVar], [Inst], UniType), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 2 _U_ 22002120 _N_ _N_ _N_ _N_ #-}
import Bag(Bag)
import Class(Class)
import Maybes(Labda)
-import NameTypes(ShortName)
import PreludeGlaST(_MutableArray)
import TyCon(TyCon)
import TyVar(TyVar, TyVarTemplate)
import UniType(UniType)
import Unique(Unique)
-data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-}
+data Subst
data SubstResult = SubstOK | OccursCheck TyVar UniType | AlreadyBound UniType
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
+data TyVar
+data UniType
applySubstToThetaTy :: Subst -> [(Class, UniType)] -> (Subst, [(Class, UniType)])
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
applySubstToTy :: Subst -> UniType -> (Subst, UniType)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
applySubstToTyVar :: Subst -> TyVar -> (Subst, UniType)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
combineSubstUndos :: Subst -> Subst
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LSLL)" {_A_ 4 _U_ 2122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
extendSubst :: TyVar -> UniType -> Subst -> (Subst, SubstResult)
- {-# GHC_PRAGMA _A_ 2 _U_ 221 _N_ _N_ _N_ _N_ #-}
getSubstTyVarUnique :: Subst -> (Subst, Unique)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(U(LU(P))P)LLU(P))" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getSubstTyVarUniques :: Int -> Subst -> (Subst, [Unique])
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(U(U(LU(P))P)LLU(P))" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mkEmptySubst :: Int -> Subst
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
pushSubstUndos :: Subst -> Subst
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LLLL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
undoSubstUndos :: Subst -> Subst
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LSLL)" {_A_ 4 _U_ 2112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import TcMonad(TcResult)
import UniType(UniType)
tcLocalBindsAndThen :: E -> (Binds Id TypecheckedPat -> a -> a) -> Binds Name (InPat Name) -> (E -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)
- {-# GHC_PRAGMA _A_ 4 _U_ 2212222222 _N_ _S_ "LLSL" _N_ _N_ #-}
tcTopBindsAndThen :: E -> (Binds Id TypecheckedPat -> a -> a) -> Binds Name (InPat Name) -> (E -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (a, LIE, b)
- {-# GHC_PRAGMA _A_ 4 _U_ 2212222222 _N_ _S_ "LLSL" _N_ _N_ #-}
import TcMonad(TcResult)
import UniType(UniType)
import UniqFM(UniqFM)
-data ClassInfo {-# GHC_PRAGMA ClassInfo Class (MonoBinds Name (InPat Name)) #-}
+data ClassInfo
tcClassDecls1 :: E -> (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) -> [ClassDecl Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([ClassInfo], UniqFM Class, [(Name, Id)])
- {-# GHC_PRAGMA _A_ 9 _U_ 221222122 _N_ _S_ "LLSLLLLLL" _N_ _N_ #-}
tcClassDecls2 :: E -> [ClassInfo] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((LIE, Binds Id TypecheckedPat), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
import UniType(UniType)
import UniqFM(UniqFM)
tcClassSigs :: E -> UniqFM UniType -> Class -> (ClassOp -> SpecEnv) -> TyVarTemplate -> [Sig Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult ([ClassOp], [(Name, Id)], [Id], [Id])
- {-# GHC_PRAGMA _A_ 6 _U_ 2222212122 _N_ _S_ "LLLLLS" _N_ _N_ #-}
import UniType(UniType)
import UniqFM(UniqFM)
tcConDecls :: UniqFM TyCon -> UniqFM UniType -> TyCon -> [TyVarTemplate] -> SpecEnv -> [ConDecl Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [(Name, Id)]
- {-# GHC_PRAGMA _A_ 10 _U_ 2222212122 _N_ _S_ "LLLLLSLLLL" _N_ _N_ #-}
import UniType(UniType)
import UniqFM(UniqFM)
tcContext :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> [(Name, Name)] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [(Class, UniType)]
- {-# GHC_PRAGMA _A_ 4 _U_ 22212222 _N_ _S_ "LLLS" _N_ _N_ #-}
import TcMonad(TcResult)
import UniType(UniType)
tcDefaults :: E -> [DefaultDecl Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [UniType]
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
type DerivEqn = (Class, TyCon, [TyVar], [(Class, UniType)])
data TagThingWanted = GenCon2Tag | GenTag2Con | GenMaxTag
con2tag_PN :: TyCon -> ProtoName
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
maxtag_PN :: TyCon -> ProtoName
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
tag2con_PN :: TyCon -> ProtoName
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
tcDeriving :: _PackedString -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> Bag InstInfo -> UniqFM TyCon -> [FixityDecl Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Bag InstInfo, Binds Name (InPat Name), PprStyle -> Int -> Bool -> PrettyRep)
- {-# GHC_PRAGMA _A_ 5 _U_ 22220222222 _N_ _S_ "LLLSA" {_A_ 4 _U_ 2222222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
if not (isEmptyBag errs) then
pprPanic "gen_inst_info:renamer errs!\n" (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
else
- --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) (
+-- pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
-- All done
let
-- and here comes the main point...
(if from_here then mbinds else EmptyMonoBinds)
from_here modname locn [])
- --)
where
clas_key = getClassKey clas
clas_Name
import TcMonad(TcResult)
import UniType(UniType)
tcExpr :: E -> Expr Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Expr Id TypecheckedPat, LIE, UniType)
- {-# GHC_PRAGMA _A_ 2 _U_ 22222222 _N_ _S_ "LS" _N_ _N_ #-}
import E
import CE ( lookupCE )
-#ifndef DPH
-import Errors ( badMatchErr, UnifyErrContext(..) )
-#else
-import Errors ( badMatchErr, podCompLhsError, UnifyErrContext(..) )
-#endif {- Data Parallel Haskell -}
-
+import Errors
import GenSpecEtc ( checkSigTyVars )
import Id ( mkInstId, getIdUniType, Id )
import Inst
-- isTauTy is over-paranoid, because we don't expect
-- any submerged polymorphism other than rank-2 polymorphism
- checkTc (not (isTauTy ty)) (error "tcExpr Var: MISSING ERROR MESSAGE") -- ToDo:
- `thenTc_`
+ getSrcLocTc `thenNF_Tc` \ loc ->
+ checkTc (not (isTauTy ty)) (lurkingRank2Err name ty loc) `thenTc_`
returnTc stuff
\end{code}
unify_args (arg_no+1) (App fun arg'') (lie `plusLIE` lie_arg') args arg_tys fun_res_ty
unify_args arg_no fun lie [] arg_tys fun_res_ty
- = -- We've run out of actual arguments Check that none of
- -- arg_tys has a for-all at the top For example, "build" on
+ = -- We've run out of actual arguments. Check that none of
+ -- arg_tys has a for-all at the top. For example, "build" on
-- its own is no good; it must be applied to something.
let
result_ty = glueTyArgs arg_tys fun_res_ty
in
+ getSrcLocTc `thenNF_Tc` \ loc ->
checkTc (not (isTauTy result_ty))
- (error "ERROR: 2 rank failure (NEED ERROR MSG [ToDo])") `thenTc_`
+ (underAppliedTyErr result_ty loc) `thenTc_`
returnTc (fun, lie, result_ty)
-- When we run out of arg_tys we go back to unify_fun in the hope
import TcMonad(TcResult)
import UniType(UniType)
tcGRHSsAndBinds :: E -> GRHSsAndBinds Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (GRHSsAndBinds Id TypecheckedPat, LIE, UniType)
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
import TcDeriv(TagThingWanted)
import TyCon(TyCon)
a_Expr :: Expr ProtoName a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv a_PN] _N_ #-}
a_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
a_Pat :: InPat ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ HsPat VarPatIn [ProtoName] [_ORIG_ TcGenDeriv a_PN] _N_ #-}
ah_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
b_Expr :: Expr ProtoName a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv b_PN] _N_ #-}
b_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
b_Pat :: InPat ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ HsPat VarPatIn [ProtoName] [_ORIG_ TcGenDeriv b_PN] _N_ #-}
bh_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
c_Expr :: Expr ProtoName a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv c_PN] _N_ #-}
c_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
c_Pat :: InPat ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ HsPat VarPatIn [ProtoName] [_ORIG_ TcGenDeriv c_PN] _N_ #-}
ch_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
cmp_eq_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
d_Expr :: Expr ProtoName a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv d_PN] _N_ #-}
d_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
d_Pat :: InPat ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ HsPat VarPatIn [ProtoName] [_ORIG_ TcGenDeriv d_PN] _N_ #-}
dh_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
eqH_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
eq_TAG_Expr :: Expr ProtoName a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv eq_TAG_PN] _N_ #-}
eq_TAG_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
error_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
false_Expr :: Expr ProtoName a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv false_PN] _N_ #-}
false_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
geH_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
gen_Binary_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
- {-# GHC_PRAGMA _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (MonoBinds ProtoName (InPat ProtoName)) } [ _NOREP_S_ "gen_Binary_binds" ] _N_ #-}
gen_Enum_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
gen_Eq_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
- {-# GHC_PRAGMA _A_ 0 _U_ 2 _N_ _N_ _N_ _N_ #-}
gen_Ix_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
- {-# GHC_PRAGMA _A_ 0 _U_ 2 _N_ _N_ _N_ _N_ #-}
gen_Ord_binds :: TyCon -> MonoBinds ProtoName (InPat ProtoName)
- {-# GHC_PRAGMA _A_ 0 _U_ 2 _N_ _N_ _N_ _N_ #-}
gen_Text_binds :: [FixityDecl Name] -> Bool -> TyCon -> MonoBinds ProtoName (InPat ProtoName)
- {-# GHC_PRAGMA _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
gen_tag_n_con_monobind :: (ProtoName, Name, TyCon, TagThingWanted) -> MonoBinds ProtoName (InPat ProtoName)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LALE)" {_A_ 3 _U_ 211 _N_ _N_ _N_ _N_} _N_ _N_ #-}
gt_TAG_Expr :: Expr ProtoName a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv gt_TAG_PN] _N_ #-}
gt_TAG_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
leH_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
ltH_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
lt_TAG_Expr :: Expr ProtoName a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv lt_TAG_PN] _N_ #-}
lt_TAG_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
minusH_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
mkInt_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
rangeSize_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
true_Expr :: Expr ProtoName a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _!_ _ORIG_ HsExpr Var [ProtoName, u0] [_ORIG_ TcGenDeriv true_PN] _N_ #-}
true_PN :: ProtoName
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
data_con_PN = Prel (WiredInVal data_con)
bs_needed = take (getDataConArity data_con) bs_PNs
con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
+ is_nullary_con = isNullaryDataCon data_con
show_con
= let (mod, nm) = getOrigName data_con
- space_maybe = if isNullaryDataCon data_con then _NIL_ else SLIT(" ")
+ space_maybe = if is_nullary_con then _NIL_ else SLIT(" ")
in
App (Var showString_PN) (Lit (StringLit (nm _APPEND_ space_maybe)))
= [ App (App (Var showsPrec_PN) (Lit (IntLit 10))) (Var b)
| b <- bs_needed ]
in
- ([a_Pat, con_pat],
- showParen_Expr (OpApp a_Expr (Var ge_PN) (Lit (IntLit 10)))
- (nested_compose_Expr show_thingies))
+ if is_nullary_con then -- skip the showParen junk...
+ ASSERT(null bs_needed)
+ ([a_Pat, con_pat], show_con)
+ else
+ ([a_Pat, con_pat],
+ showParen_Expr (OpApp a_Expr (Var ge_PN) (Lit (IntLit 10)))
+ (nested_compose_Expr show_thingies))
where
spacified [] = []
spacified [x] = [x]
read_con_comprehensions
= map read_con (getTyConDataCons tycon)
in
- mk_easy_FunMonoBind readsPrec_PN [a_Pat] [] (
- readParen_Expr (OpApp a_Expr (Var gt_PN) (Lit (IntLit 9))) (
- Lam (mk_easy_Match [b_Pat] [] (
+ mk_easy_FunMonoBind readsPrec_PN [a_Pat, b_Pat] [] (
foldl1 append_Expr read_con_comprehensions
- ))))
+ )
where
read_con data_con -- note: "b" is the string being "read"
= let
as_needed = take (getDataConArity data_con) as_PNs
bs_needed = take (getDataConArity data_con) bs_PNs
con_expr = foldl App (Var data_con_PN) (map Var as_needed)
+ is_nullary_con = isNullaryDataCon data_con
con_qual
= GeneratorQual
- (TuplePatIn [LitPatIn (StringLit data_con_str), c_Pat])
- (App (Var lex_PN) b_Expr)
+ (TuplePatIn [LitPatIn (StringLit data_con_str), d_Pat])
+ (App (Var lex_PN) c_Expr)
+
+ field_quals = snd (mapAccumL mk_qual d_Expr (as_needed `zip` bs_needed))
- field_quals = snd (mapAccumL mk_qual c_Expr (as_needed `zip` bs_needed))
+ read_paren_arg
+ = if is_nullary_con then -- must be False (parens are surely optional)
+ false_Expr
+ else -- parens depend on precedence...
+ OpApp a_Expr (Var gt_PN) (Lit (IntLit 9))
in
- ListComp (ExplicitTuple [con_expr,
- if null bs_needed then c_Expr else Var (last bs_needed)])
- (con_qual : field_quals)
+ App (
+ readParen_Expr read_paren_arg (
+ Lam (mk_easy_Match [c_Pat] [] (
+ ListComp (ExplicitTuple [con_expr,
+ if null bs_needed then d_Expr else Var (last bs_needed)])
+ (con_qual : field_quals)))
+ )) (Var b_PN)
where
mk_qual draw_from (con_field, str_left)
= (Var str_left, -- what to draw from down the line...
import SrcLoc(SrcLoc)
import TcMonad(Baby_TcResult)
tcInterfaceSigs :: E -> [Sig Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [(Name, Id)]
- {-# GHC_PRAGMA _A_ 6 _U_ 212122 _N_ _S_ "LSLLLL" _N_ _N_ #-}
import UniqFM(UniqFM)
data InstInfo = InstInfo Class [TyVarTemplate] UniType [(Class, UniType)] [(Class, UniType)] Id [Id] (MonoBinds Name (InPat Name)) Bool _PackedString SrcLoc [Sig Name]
buildInstanceEnvs :: Bag InstInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv))
- {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _N_ _N_ #-}
mkInstanceRelatedIds :: E -> Bool -> InstancePragmas Name -> a -> Class -> [TyVarTemplate] -> UniType -> [(Class, UniType)] -> [Sig Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Id, [(Class, UniType)], [Id])
- {-# GHC_PRAGMA _A_ 15 _U_ 222022221222122 _N_ _S_ "LLSALSLLLLLLU(ALS)LL" {_A_ 14 _U_ 22222221222122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
processInstBinds :: E -> [TyVar] -> (Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Expr Id TypecheckedPat, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [TyVar] -> [Inst] -> [Id] -> MonoBinds Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], MonoBinds Id TypecheckedPat)
- {-# GHC_PRAGMA _A_ 7 _U_ 2222222222122 _N_ _S_ "LLLLLLS" _N_ _N_ #-}
tcInstDecls1 :: E -> UniqFM Class -> UniqFM TyCon -> [InstDecl Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Bag InstInfo, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 4 _U_ 2221222222 _N_ _S_ "LLLS" _N_ _N_ #-}
tcInstDecls2 :: E -> Bag InstInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((LIE, Binds Id TypecheckedPat), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
tcSpecInstSigs :: E -> UniqFM Class -> UniqFM TyCon -> Bag InstInfo -> [SpecialisedInstanceSig Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Bag InstInfo)
- {-# GHC_PRAGMA _A_ 5 _U_ 22222222222 _N_ _S_ "LLLLS" _N_ _N_ #-}
import TcMonad(TcResult)
import UniType(UniType)
tcMatch :: E -> Match Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Match Id TypecheckedPat, LIE, UniType)
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
tcMatchesCase :: E -> [Match Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Match Id TypecheckedPat], LIE, UniType)
- {-# GHC_PRAGMA _A_ 2 _U_ 22222122 _N_ _S_ "LS" _N_ _N_ #-}
tcMatchesFun :: E -> Name -> UniType -> [Match Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Match Id TypecheckedPat], LIE)
- {-# GHC_PRAGMA _A_ 4 _U_ 2222222222 _N_ _S_ "LLLS" _N_ _N_ #-}
import HsMatches(Match)
import HsPat(InPat, RenamedPat(..), TypecheckedPat)
import HsTypes(PolyType)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
-import Inst(Inst, InstOrigin, OverloadedLit)
+import Id(Id)
+import Inst(Inst)
import Maybes(Labda)
import Name(Name)
import NameTypes(FullName, ShortName)
-import PreludeGlaST(_MutableArray)
import PreludePS(_PackedString)
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
import ProtoName(ProtoName)
import UniType(UniType)
import UniqFM(UniqFM)
import Unique(Unique)
-data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
+data Module a b
+data Bag a
type CE = UniqFM Class
-data E {-# GHC_PRAGMA MkE (UniqFM TyCon) (UniqFM Id) (UniqFM Id) (UniqFM Class) #-}
+data E
type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-}
-data FixityDecl a {-# GHC_PRAGMA InfixL a Int | InfixR a Int | InfixN a Int #-}
-data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-}
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
+data Binds a b
+data FixityDecl a
+data Expr a b
+data InPat a
type RenamedPat = InPat Name
-data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data TypecheckedPat
+data Id
+data Inst
+data Labda a
+data Name
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-}
+data PrettyRep
+data ProtoName
+data SrcLoc
+data Subst
type TCE = UniqFM TyCon
-data InstInfo {-# GHC_PRAGMA InstInfo Class [TyVarTemplate] UniType [(Class, UniType)] [(Class, UniType)] Id [Id] (MonoBinds Name (InPat Name)) Bool _PackedString SrcLoc [Sig Name] #-}
-data TcResult a {-# GHC_PRAGMA TcSucceeded a Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) | TcFailed Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data InstInfo
+data TcResult a
+data UniqFM a
tcModule :: E -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> Module Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ((Binds Id TypecheckedPat, Binds Id TypecheckedPat, Binds Id TypecheckedPat, [(Inst, Expr Id TypecheckedPat)]), ([FixityDecl Name], [Id], UniqFM Class, UniqFM TyCon, Bag InstInfo), FiniteMap TyCon [[Labda UniType]], E, PprStyle -> Int -> Bool -> PrettyRep)
- {-# GHC_PRAGMA _A_ 9 _U_ 221222120 _N_ _S_ "LLU(LAALSLLLLLLLL)LLLU(ALL)LA" {_A_ 8 _U_ 22122212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
interface TcMonad where
import Bag(Bag)
import CharSeq(CSeq)
-import Class(Class, ClassOp)
+import Class(Class)
import CmdLineOpts(GlobalSwitch)
import ErrUtils(Error(..))
import ErrsTc(UnifyErrContext)
import HsMatches(GRHS, GRHSsAndBinds, Match)
import HsPat(InPat, TypecheckedPat)
import HsTypes(PolyType)
-import Id(Id, IdDetails, applySubstToId)
-import IdInfo(ArgUsageInfo, ArityInfo, DeforestInfo, DemandInfo, FBTypeInfo, IdInfo, SpecEnv, StrictnessInfo, UpdateInfo)
-import Inst(Inst, InstOrigin, OverloadedLit, applySubstToInst)
-import InstEnv(InstTemplate)
+import Id(Id)
+import IdInfo(IdInfo)
+import Inst(Inst)
import Maybes(Labda, MaybeErr)
import Name(Name)
import NameTypes(FullName, ShortName)
-import PreludeGlaST(_MutableArray)
import PreludePS(_PackedString)
import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
-import PrimKind(PrimKind)
import ProtoName(ProtoName)
import RenameAuxFuns(GlobalNameFun(..), GlobalNameFuns(..))
import RenameMonad4(Rn4M(..))
-import SimplEnv(UnfoldingDetails)
-import SplitUniq(SUniqSM(..), SplitUniqSupply, getSUnique, getSUniques, splitUniqSupply)
+import SplitUniq(SUniqSM(..), SplitUniqSupply)
import SrcLoc(SrcLoc)
-import Subst(Subst, applySubstToThetaTy, applySubstToTy, applySubstToTyVar)
+import Subst(Subst)
import TyCon(TyCon)
import TyVar(TyVar, TyVarTemplate)
import UniType(SigmaType(..), TauType(..), ThetaType(..), UniType)
-import Unique(Unique, UniqueSupply, mkUniqueGrimily)
+import Unique(Unique, UniqueSupply)
+infixr 9 `thenLazilyNF_Tc`
infixr 9 `thenNF_Tc`
infixr 9 `thenTc`
infixr 9 `thenTc_`
type Baby_TcM a = (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
-data Baby_TcResult a {-# GHC_PRAGMA BabyTcFailed (Bag (PprStyle -> Int -> Bool -> PrettyRep)) | BabyTcSucceeded a (Bag (PprStyle -> Int -> Bool -> PrettyRep)) #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
+data Baby_TcResult a
+data Bag a
+data Class
+data GlobalSwitch
type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-}
+data Expr a b
type NF_TcM a = (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
type TcM a = (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
-data TcResult a {-# GHC_PRAGMA TcSucceeded a Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) | TcFailed Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) #-}
-data UnifyErrContext
- {-# GHC_PRAGMA PredCtxt (Expr Name (InPat Name)) | AppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | TooManyArgsCtxt (Expr Name (InPat Name)) | FunAppCtxt (Expr Name (InPat Name)) (Labda Id) (Expr Name (InPat Name)) UniType UniType Int | OpAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionLAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionRAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | CaseCtxt (Expr Name (InPat Name)) [Match Name (InPat Name)] | BranchCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | ListCtxt [Expr Name (InPat Name)] | PatCtxt (InPat Name) | CaseBranchesCtxt [Match Name (InPat Name)] | FilterCtxt (Expr Name (InPat Name)) | GeneratorCtxt (InPat Name) (Expr Name (InPat Name)) | GRHSsBranchCtxt [GRHS Name (InPat Name)] | GRHSsGuardCtxt (Expr Name (InPat Name)) | PatMonoBindsCtxt (InPat Name) (GRHSsAndBinds Name (InPat Name)) | FunMonoBindsCtxt Name [Match Name (InPat Name)] | MatchCtxt UniType UniType | ArithSeqCtxt (Expr Name (InPat Name)) | CCallCtxt [Char] [Expr Name (InPat Name)] | AmbigDictCtxt [Inst] | SigCtxt Id UniType | MethodSigCtxt Name UniType | ExprSigCtxt (Expr Name (InPat Name)) UniType | ValSpecSigCtxt Name UniType SrcLoc | ValSpecSpecIdCtxt Name UniType Name SrcLoc | BindSigCtxt [Id] | SuperClassSigCtxt | CaseBranchCtxt (Match Name (InPat Name)) | Rank2ArgCtxt (Expr Id TypecheckedPat) UniType #-}
+data TcResult a
+data UnifyErrContext
type TypecheckedExpr = Expr Id TypecheckedPat
-data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-}
-data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data TypecheckedPat
+data Id
+data IdInfo
+data Inst
+data Labda a
+data MaybeErr a b
+data Name
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
+data PrettyRep
+data ProtoName
type GlobalNameFun = ProtoName -> Labda Name
type GlobalNameFuns = (ProtoName -> Labda Name, ProtoName -> Labda Name)
type Rn4M a = (GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))
type SUniqSM a = SplitUniqSupply -> a
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
+data SplitUniqSupply
+data SrcLoc
+data Subst
+data TyCon
+data TyVar
+data TyVarTemplate
type SigmaType = UniType
type TauType = UniType
type ThetaType = [(Class, UniType)]
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
-data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-}
+data UniType
+data Unique
+data UniqueSupply
addSrcLocB_Tc :: SrcLoc -> ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
- {-# GHC_PRAGMA _A_ 6 _U_ 212220 _N_ _S_ "LSLLLA" {_A_ 5 _U_ 21222 _N_ _N_ _F_ _IF_ARGS_ 1 5 XXXXX 5 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: SplitUniqSupply) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u2 [ u3, u4, u5, u1 ] _N_} _F_ _IF_ARGS_ 1 6 XXXXXX 5 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: SplitUniqSupply) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: SrcLoc) -> _APP_ u2 [ u3, u4, u5, u1 ] _N_ #-}
addSrcLocTc :: SrcLoc -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
- {-# GHC_PRAGMA _A_ 8 _U_ 21222220 _N_ _S_ "LSLLLLLA" {_A_ 7 _U_ 2122222 _N_ _N_ _F_ _IF_ARGS_ 1 7 XXXXXXX 7 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: [UniType]) (u5 :: Subst) (u6 :: SplitUniqSupply) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u2 [ u3, u4, u5, u6, u7, u1 ] _N_} _F_ _IF_ARGS_ 1 8 XXXXXXXX 7 _/\_ u0 -> \ (u1 :: SrcLoc) (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: [UniType]) (u5 :: Subst) (u6 :: SplitUniqSupply) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SrcLoc) -> _APP_ u2 [ u3, u4, u5, u6, u7, u1 ] _N_ #-}
-applySubstToId :: Subst -> Id -> (Subst, Id)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(LSU(LLU(S)LLLLLLL)S)" {_A_ 5 _U_ 22212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-applySubstToInst :: Subst -> Inst -> (Subst, Inst)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
applyTcSubstToId :: Id -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 1002020 _N_ _S_ "U(LSU(LLU(S)LLLLLLL)S)AALALA" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
applyTcSubstToInst :: Inst -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 1002020 _N_ _S_ "SAALALA" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 XXXXXXX 8 \ (u0 :: Inst) (u1 :: GlobalSwitch -> Bool) (u2 :: [UniType]) (u3 :: Subst) (u4 :: SplitUniqSupply) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: SrcLoc) -> case _APP_ _ORIG_ Inst applySubstToInst [ u3, u0 ] of { _ALG_ _TUP_2 (u7 :: Subst) (u8 :: Inst) -> _!_ _TUP_3 [Inst, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u8, u7, u5]; _NO_DEFLT_ } _N_ #-}
applyTcSubstToInsts :: [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Inst], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: [Inst]) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ TcMonad mapNF_Tc { Inst } { Inst } [ _ORIG_ TcMonad applyTcSubstToInst, u0 ] _N_ #-}
applyTcSubstToTy :: UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 2002020 _N_ _S_ "SAALALA" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 XXXXXXX 8 \ (u0 :: UniType) (u1 :: GlobalSwitch -> Bool) (u2 :: [UniType]) (u3 :: Subst) (u4 :: SplitUniqSupply) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: SrcLoc) -> case _APP_ _ORIG_ Subst applySubstToTy [ u3, u0 ] of { _ALG_ _TUP_2 (u7 :: Subst) (u8 :: UniType) -> _!_ _TUP_3 [UniType, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u8, u7, u5]; _NO_DEFLT_ } _N_ #-}
applyTcSubstToTyVar :: TyVar -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 2002020 _N_ _S_ "LAALALA" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 XXXXXXX 8 \ (u0 :: TyVar) (u1 :: GlobalSwitch -> Bool) (u2 :: [UniType]) (u3 :: Subst) (u4 :: SplitUniqSupply) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: SrcLoc) -> case _APP_ _ORIG_ Subst applySubstToTyVar [ u3, u0 ] of { _ALG_ _TUP_2 (u7 :: Subst) (u8 :: UniType) -> _!_ _TUP_3 [UniType, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u8, u7, u5]; _NO_DEFLT_ } _N_ #-}
applyTcSubstToTyVars :: [TyVar] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: [TyVar]) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ TcMonad mapNF_Tc { TyVar } { UniType } [ _ORIG_ TcMonad applyTcSubstToTyVar, u0 ] _N_ #-}
applyTcSubstToTys :: [UniType] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 1222222 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: [UniType]) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ TcMonad mapNF_Tc { UniType } { UniType } [ _ORIG_ TcMonad applyTcSubstToTy, u0 ] _N_ #-}
babyTcMtoNF_TcM :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 1202222 _N_ _S_ "SLALLLL" {_A_ 6 _U_ 122222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
babyTcMtoTcM :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
- {-# GHC_PRAGMA _A_ 7 _U_ 1202222 _N_ _S_ "SLALLLL" {_A_ 6 _U_ 122222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
checkB_Tc :: Bool -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult ()
- {-# GHC_PRAGMA _A_ 6 _U_ 120020 _N_ _S_ "EL" _N_ _N_ #-}
checkMaybeErrTc :: MaybeErr b a -> (a -> PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b
- {-# GHC_PRAGMA _A_ 2 _U_ 11222222 _N_ _S_ "SL" _N_ _N_ #-}
checkMaybeTc :: Labda a -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
- {-# GHC_PRAGMA _A_ 8 _U_ 12002020 _N_ _S_ "SL" _F_ _IF_ARGS_ 1 8 CXXXXXXX 10 _/\_ u0 -> \ (u1 :: Labda u0) (u2 :: PprStyle -> Int -> Bool -> PrettyRep) (u3 :: GlobalSwitch -> Bool) (u4 :: [UniType]) (u5 :: Subst) (u6 :: SplitUniqSupply) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SrcLoc) -> case u1 of { _ALG_ _ORIG_ Maybes Ni (u9 :: u0) -> _!_ _ORIG_ TcMonad TcSucceeded [u0] [u9, u5, u7]; _ORIG_ Maybes Hamna -> _APP_ _TYAPP_ _TYAPP_ _TYAPP_ _TYAPP_ _TYAPP_ _WRKR_ _ORIG_ TcMonad failTc { (GlobalSwitch -> Bool) } { [UniType] } { SplitUniqSupply } { SrcLoc } { u0 } [ u2, u5, u7 ]; _NO_DEFLT_ } _N_ #-}
checkMaybesTc :: [Labda a] -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [a]
- {-# GHC_PRAGMA _A_ 2 _U_ 12222222 _N_ _S_ "SL" _N_ _N_ #-}
checkTc :: Bool -> (PprStyle -> Int -> Bool -> PrettyRep) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
- {-# GHC_PRAGMA _A_ 8 _U_ 12002020 _N_ _S_ "EL" _N_ _N_ #-}
extendSubstTc :: TyVar -> UniType -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
- {-# GHC_PRAGMA _A_ 9 _U_ 222221222 _N_ _N_ _N_ _N_ #-}
failB_Tc :: (PprStyle -> Int -> Bool -> PrettyRep) -> a -> b -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> c -> Baby_TcResult d
- {-# GHC_PRAGMA _A_ 5 _U_ 20020 _N_ _S_ "LAALA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 4 5 XXXXX 6 _/\_ u0 u1 u2 u3 -> \ (u4 :: PprStyle -> Int -> Bool -> PrettyRep) (u5 :: u0) (u6 :: u1) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: u2) -> let {(u9 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) = _APP_ _TYAPP_ _ORIG_ Bag snocBag { (PprStyle -> Int -> Bool -> PrettyRep) } [ u7, u4 ]} in _!_ _ORIG_ TcMonad BabyTcFailed [u3] [u9] _N_ #-}
failTc :: (PprStyle -> Int -> Bool -> PrettyRep) -> a -> b -> Subst -> c -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> d -> TcResult e
- {-# GHC_PRAGMA _A_ 7 _U_ 2002020 _N_ _S_ "LAALALA" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 5 7 XXXXXXX 7 _/\_ u0 u1 u2 u3 u4 -> \ (u5 :: PprStyle -> Int -> Bool -> PrettyRep) (u6 :: u0) (u7 :: u1) (u8 :: Subst) (u9 :: u2) (ua :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (ub :: u3) -> let {(uc :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) = _APP_ _TYAPP_ _ORIG_ Bag snocBag { (PprStyle -> Int -> Bool -> PrettyRep) } [ ua, u5 ]} in _!_ _ORIG_ TcMonad TcFailed [u4] [u8, uc] _N_ #-}
fixB_Tc :: (a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
- {-# GHC_PRAGMA _A_ 5 _U_ 22222 _N_ _S_ "SLLLL" _N_ _N_ #-}
fixNF_Tc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 2222222 _N_ _S_ "SLLLLLL" _N_ _N_ #-}
fixTc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
- {-# GHC_PRAGMA _A_ 7 _U_ 2222222 _N_ _S_ "SLLLLLL" _N_ _N_ #-}
foldlTc :: (b -> a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> b -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b
- {-# GHC_PRAGMA _A_ 3 _U_ 221222222 _N_ _S_ "LLS" _N_ _N_ #-}
getDefaultingTys :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 6 _U_ 022020 _N_ _S_ "ALLALA" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: [UniType]) (u1 :: Subst) (u2 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _TUP_3 [[UniType], Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u0, u1, u2] _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 4 \ (u0 :: GlobalSwitch -> Bool) (u1 :: [UniType]) (u2 :: Subst) (u3 :: SplitUniqSupply) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SrcLoc) -> _!_ _TUP_3 [[UniType], Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u1, u2, u4] _N_ #-}
-getSUnique :: SplitUniqSupply -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> case u1 of { _ALG_ I# (u4 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u4]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
-getSUniques :: Int -> SplitUniqSupply -> [Unique]
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)L" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getSrcLocB_Tc :: a -> b -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> c -> Baby_TcResult c
- {-# GHC_PRAGMA _A_ 4 _U_ 0022 _N_ _S_ "AALL" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 3 2 XX 3 _/\_ u0 u1 u2 -> \ (u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u4 :: u2) -> _!_ _ORIG_ TcMonad BabyTcSucceeded [u2] [u4, u3] _N_} _F_ _IF_ARGS_ 3 4 XXXX 3 _/\_ u0 u1 u2 -> \ (u3 :: u0) (u4 :: u1) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: u2) -> _!_ _ORIG_ TcMonad BabyTcSucceeded [u2] [u6, u5] _N_ #-}
getSrcLocTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (SrcLoc, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 6 _U_ 002022 _N_ _S_ "AALALL" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: Subst) (u1 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u2 :: SrcLoc) -> _!_ _TUP_3 [SrcLoc, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u2, u0, u1] _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 4 \ (u0 :: GlobalSwitch -> Bool) (u1 :: [UniType]) (u2 :: Subst) (u3 :: SplitUniqSupply) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SrcLoc) -> _!_ _TUP_3 [SrcLoc, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u5, u2, u4] _N_ #-}
getSwitchCheckerB_Tc :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult (GlobalSwitch -> Bool)
- {-# GHC_PRAGMA _A_ 4 _U_ 2020 _N_ _S_ "LALA" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: GlobalSwitch -> Bool) (u1 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _ORIG_ TcMonad BabyTcSucceeded [(GlobalSwitch -> Bool)] [u0, u1] _N_} _F_ _IF_ARGS_ 0 4 XXXX 3 \ (u0 :: GlobalSwitch -> Bool) (u1 :: SplitUniqSupply) (u2 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u3 :: SrcLoc) -> _!_ _ORIG_ TcMonad BabyTcSucceeded [(GlobalSwitch -> Bool)] [u0, u2] _N_ #-}
getSwitchCheckerTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (GlobalSwitch -> Bool, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 6 _U_ 202020 _N_ _S_ "LALALA" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: GlobalSwitch -> Bool) (u1 :: Subst) (u2 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _TUP_3 [(GlobalSwitch -> Bool), Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u0, u1, u2] _N_} _F_ _IF_ARGS_ 0 6 XXXXXX 4 \ (u0 :: GlobalSwitch -> Bool) (u1 :: [UniType]) (u2 :: Subst) (u3 :: SplitUniqSupply) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SrcLoc) -> _!_ _TUP_3 [(GlobalSwitch -> Bool), Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u0, u2, u4] _N_ #-}
getTyVarUniqueTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Unique, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 6 _U_ 001020 _N_ _S_ "AALALA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getTyVarUniquesTc :: Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Unique], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 1001020 _N_ _S_ "LAALALA" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getUniqueB_Tc :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult Unique
- {-# GHC_PRAGMA _A_ 4 _U_ 0120 _N_ _S_ "ALLA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 4 XCXX 8 \ (u0 :: GlobalSwitch -> Bool) (u1 :: SplitUniqSupply) (u2 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u3 :: SrcLoc) -> let {(u8 :: Unique) = case u1 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u4 :: Int) (u5 :: SplitUniqSupply) (u6 :: SplitUniqSupply) -> case u4 of { _ALG_ I# (u7 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u7]; _NO_DEFLT_ }; _NO_DEFLT_ }} in _!_ _ORIG_ TcMonad BabyTcSucceeded [Unique] [u8, u2] _N_ #-}
getUniqueTc :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Unique, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 6 _U_ 002120 _N_ _S_ "AALLLA" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 6 XXXCXX 9 \ (u0 :: GlobalSwitch -> Bool) (u1 :: [UniType]) (u2 :: Subst) (u3 :: SplitUniqSupply) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SrcLoc) -> let {(ua :: Unique) = case u3 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u6 :: Int) (u7 :: SplitUniqSupply) (u8 :: SplitUniqSupply) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u9]; _NO_DEFLT_ }; _NO_DEFLT_ }} in _!_ _TUP_3 [Unique, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [ua, u2, u4] _N_ #-}
getUniquesB_Tc :: Int -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [Unique]
- {-# GHC_PRAGMA _A_ 5 _U_ 10220 _N_ _S_ "LALLA" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 5 CXXXX 8 \ (u0 :: Int) (u1 :: GlobalSwitch -> Bool) (u2 :: SplitUniqSupply) (u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u4 :: SrcLoc) -> let {(u6 :: [Unique]) = case u0 of { _ALG_ I# (u5 :: Int#) -> _APP_ _WRKR_ _ORIG_ SplitUniq getSUniques [ u5, u2 ]; _NO_DEFLT_ }} in _!_ _ORIG_ TcMonad BabyTcSucceeded [[Unique]] [u6, u3] _N_ #-}
getUniquesTc :: Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Unique], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 1002220 _N_ _S_ "LAALLLA" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 7 CXXXXXX 9 \ (u0 :: Int) (u1 :: GlobalSwitch -> Bool) (u2 :: [UniType]) (u3 :: Subst) (u4 :: SplitUniqSupply) (u5 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u6 :: SrcLoc) -> let {(u8 :: [Unique]) = case u0 of { _ALG_ I# (u7 :: Int#) -> _APP_ _WRKR_ _ORIG_ SplitUniq getSUniques [ u7, u4 ]; _NO_DEFLT_ }} in _!_ _TUP_3 [[Unique], Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u8, u3, u5] _N_ #-}
initTc :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> MaybeErr a (Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
listNF_Tc :: [(GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([a], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 1222122 _N_ _S_ "SLLLLLL" _N_ _N_ #-}
listTc :: [(GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [a]
- {-# GHC_PRAGMA _A_ 7 _U_ 1222122 _N_ _S_ "SLLLLLL" _N_ _N_ #-}
lookupInst_Tc :: Inst -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (Expr Id TypecheckedPat, [Inst])
- {-# GHC_PRAGMA _A_ 7 _U_ 2002220 _N_ _S_ "SAALLLA" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupNoBindInst_Tc :: Inst -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [Inst]
- {-# GHC_PRAGMA _A_ 7 _U_ 2002120 _N_ _S_ "SAALLLA" {_A_ 4 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mapAndUnzipTc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (b, c)) -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([b], [c])
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
mapB_Tc :: (a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b) -> [a] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult [b]
- {-# GHC_PRAGMA _A_ 2 _U_ 212222 _N_ _S_ "LS" _N_ _N_ #-}
mapNF_Tc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (b, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([b], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
mapTc :: (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> [a] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [b]
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
noFailTc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 1222222 _N_ _S_ "SLLLLLL" _N_ _N_ #-}
pruneSubstTc :: [TyVar] -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
- {-# GHC_PRAGMA _A_ 8 _U_ 01222222 _N_ _S_ "ASLLLLLL" {_A_ 7 _U_ 1222222 _N_ _N_ _F_ _IF_ARGS_ 1 7 XXXXXXX 7 _/\_ u0 -> \ (u1 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u2 :: GlobalSwitch -> Bool) (u3 :: [UniType]) (u4 :: Subst) (u5 :: SplitUniqSupply) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SrcLoc) -> _APP_ u1 [ u2, u3, u4, u5, u6, u7 ] _N_} _F_ _IF_ARGS_ 1 8 XXXXXXXX 7 _/\_ u0 -> \ (u1 :: [TyVar]) (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: [UniType]) (u5 :: Subst) (u6 :: SplitUniqSupply) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SrcLoc) -> _APP_ u2 [ u3, u4, u5, u6, u7, u8 ] _N_ #-}
recoverIgnoreErrorsB_Tc :: e -> (b -> c -> Bag a -> d -> Baby_TcResult e) -> b -> c -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> d -> Baby_TcResult e
- {-# GHC_PRAGMA _A_ 6 _U_ 112222 _N_ _N_ _N_ _N_ #-}
recoverQuietlyTc :: a -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 21221222 _N_ _N_ _N_ _N_ #-}
recoverTc :: a -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 21221222 _N_ _S_ "LSLLLLLL" _N_ _N_ #-}
returnB_Tc :: a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
- {-# GHC_PRAGMA _A_ 5 _U_ 20020 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: GlobalSwitch -> Bool) (u3 :: SplitUniqSupply) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SrcLoc) -> _!_ _ORIG_ TcMonad BabyTcSucceeded [u0] [u1, u4] _N_ #-}
returnNF_Tc :: a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 2002020 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: GlobalSwitch -> Bool) (u3 :: [UniType]) (u4 :: Subst) (u5 :: SplitUniqSupply) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SrcLoc) -> _!_ _TUP_3 [u0, Subst, (Bag (PprStyle -> Int -> Bool -> PrettyRep))] [u1, u4, u6] _N_ #-}
returnTc :: a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
- {-# GHC_PRAGMA _A_ 7 _U_ 2002020 _N_ _N_ _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: GlobalSwitch -> Bool) (u3 :: [UniType]) (u4 :: Subst) (u5 :: SplitUniqSupply) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SrcLoc) -> _!_ _ORIG_ TcMonad TcSucceeded [u0] [u1, u4, u6] _N_ #-}
rn4MtoTcM :: (ProtoName -> Labda Name, ProtoName -> Labda Name) -> ((GlobalSwitch -> Bool) -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> FiniteMap _PackedString Name -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SplitUniqSupply -> SrcLoc -> (a, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((a, Bag (PprStyle -> Int -> Bool -> PrettyRep)), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 21202220 _N_ _S_ "LLLALLLA" {_A_ 6 _U_ 212222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
setDefaultingTys :: [UniType] -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a
- {-# GHC_PRAGMA _A_ 8 _U_ 21202222 _N_ _S_ "LSLALLLL" {_A_ 7 _U_ 2122222 _N_ _N_ _F_ _IF_ARGS_ 1 7 XXXXXXX 7 _/\_ u0 -> \ (u1 :: [UniType]) (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: Subst) (u5 :: SplitUniqSupply) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SrcLoc) -> _APP_ u2 [ u3, u1, u4, u5, u6, u7 ] _N_} _F_ _IF_ARGS_ 1 8 XXXXXXXX 7 _/\_ u0 -> \ (u1 :: [UniType]) (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: GlobalSwitch -> Bool) (u4 :: [UniType]) (u5 :: Subst) (u6 :: SplitUniqSupply) (u7 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u8 :: SrcLoc) -> _APP_ u2 [ u3, u1, u5, u6, u7, u8 ] _N_ #-}
-splitUniqSupply :: SplitUniqSupply -> (SplitUniqSupply, SplitUniqSupply)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _ALWAYS_ \ (u0 :: SplitUniqSupply) -> case u0 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u1 :: Int) (u2 :: SplitUniqSupply) (u3 :: SplitUniqSupply) -> _!_ _TUP_2 [SplitUniqSupply, SplitUniqSupply] [u2, u3]; _NO_DEFLT_ } _N_ #-}
-applySubstToThetaTy :: Subst -> [(Class, UniType)] -> (Subst, [(Class, UniType)])
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
-applySubstToTy :: Subst -> UniType -> (Subst, UniType)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
-applySubstToTyVar :: Subst -> TyVar -> (Subst, UniType)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
-mkUniqueGrimily :: Int# -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_ #-}
thenB_Tc :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> (a -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b
- {-# GHC_PRAGMA _A_ 6 _U_ 112122 _N_ _S_ "SLLU(ALL)LL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult u0) (u3 :: u0 -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult u1) (u4 :: GlobalSwitch -> Bool) (u5 :: SplitUniqSupply) (u6 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u7 :: SrcLoc) -> case u5 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (u8 :: Int) (u9 :: SplitUniqSupply) (ua :: SplitUniqSupply) -> case _APP_ u2 [ u4, u9, u6, u7 ] of { _ALG_ _ORIG_ TcMonad BabyTcFailed (ub :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _ORIG_ TcMonad BabyTcFailed [u1] [ub]; _ORIG_ TcMonad BabyTcSucceeded (uc :: u0) (ud :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ uc, u4, ua, ud, u7 ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
thenB_Tc_ :: ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a) -> ((GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult b
- {-# GHC_PRAGMA _A_ 6 _U_ 112122 _N_ _S_ "SLLU(ALL)LL" _N_ _N_ #-}
+thenLazilyNF_Tc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b
thenNF_Tc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (a, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) -> (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> b
- {-# GHC_PRAGMA _A_ 8 _U_ 11222122 _N_ _S_ "SSLLLU(ALL)LL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (u0, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))) (u3 :: u0 -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> u1) (u4 :: GlobalSwitch -> Bool) (u5 :: [UniType]) (u6 :: Subst) (u7 :: SplitUniqSupply) (u8 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u9 :: SrcLoc) -> case u7 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ u4, u5, u6, ub, u8, u9 ] of { _ALG_ _TUP_3 (ud :: u0) (ue :: Subst) (uf :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ ud, u4, u5, ue, uc, uf, u9 ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
thenTc :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> (a -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b
- {-# GHC_PRAGMA _A_ 8 _U_ 11222122 _N_ _S_ "SLLLLU(ALL)LL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: u0 -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u1) (u4 :: GlobalSwitch -> Bool) (u5 :: [UniType]) (u6 :: Subst) (u7 :: SplitUniqSupply) (u8 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u9 :: SrcLoc) -> case u7 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ u4, u5, u6, ub, u8, u9 ] of { _ALG_ _ORIG_ TcMonad TcFailed (ud :: Subst) (ue :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _ORIG_ TcMonad TcFailed [u1] [ud, ue]; _ORIG_ TcMonad TcSucceeded (uf :: u0) (ug :: Subst) (uh :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ uf, u4, u5, ug, uc, uh, u9 ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
thenTc_ :: ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult a) -> ((GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult b
- {-# GHC_PRAGMA _A_ 8 _U_ 11222122 _N_ _S_ "SLLLLU(ALL)LL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u0) (u3 :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult u1) (u4 :: GlobalSwitch -> Bool) (u5 :: [UniType]) (u6 :: Subst) (u7 :: SplitUniqSupply) (u8 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u9 :: SrcLoc) -> case u7 of { _ALG_ _ORIG_ SplitUniq MkSplitUniqSupply (ua :: Int) (ub :: SplitUniqSupply) (uc :: SplitUniqSupply) -> case _APP_ u2 [ u4, u5, u6, ub, u8, u9 ] of { _ALG_ _ORIG_ TcMonad TcFailed (ud :: Subst) (ue :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _!_ _ORIG_ TcMonad TcFailed [u1] [ud, ue]; _ORIG_ TcMonad TcSucceeded (uf :: u0) (ug :: Subst) (uh :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> _APP_ u3 [ u4, u5, ug, uc, uh, u9 ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
uniqSMtoBabyTcM :: (SplitUniqSupply -> a) -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult a
- {-# GHC_PRAGMA _A_ 5 _U_ 10220 _N_ _S_ "LALLA" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 1 3 XXX 6 _/\_ u0 -> \ (u1 :: SplitUniqSupply -> u0) (u2 :: SplitUniqSupply) (u3 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) -> let {(u4 :: u0) = _APP_ u1 [ u2 ]} in _!_ _ORIG_ TcMonad BabyTcSucceeded [u0] [u4, u3] _N_} _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: SplitUniqSupply -> u0) (u2 :: GlobalSwitch -> Bool) (u3 :: SplitUniqSupply) (u4 :: Bag (PprStyle -> Int -> Bool -> PrettyRep)) (u5 :: SrcLoc) -> let {(u6 :: u0) = _APP_ u1 [ u3 ]} in _!_ _ORIG_ TcMonad BabyTcSucceeded [u0] [u6, u4] _N_ #-}
recoverTc, recoverQuietlyTc,
NF_TcM(..),
- thenNF_Tc, returnNF_Tc, listNF_Tc, mapNF_Tc,
+ thenNF_Tc, thenLazilyNF_Tc, returnNF_Tc, listNF_Tc, mapNF_Tc,
fixNF_Tc, noFailTc,
Baby_TcM(..), Baby_TcResult{-abstract-},
import Unique
import Util
-infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`
+infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenLazilyNF_Tc`
\end{code}
%************************************************************************
#ifdef __GLASGOW_HASKELL__
{-# INLINE thenNF_Tc #-}
+{-# INLINE thenLazilyNF_Tc #-}
{-# INLINE returnNF_Tc #-}
#endif
-thenNF_Tc :: NF_TcM a -> (a -> InTcM b) -> InTcM b
+thenNF_Tc, thenLazilyNF_Tc :: NF_TcM a -> (a -> InTcM b) -> InTcM b
+-- ...Lazily... is purely a performance thing (WDP 95/09)
\end{code}
In particular, @thenNF_Tc@ has all of these types:
-> cont result sw_chkr dtys subst2 s2 errs2 src_loc
}
+thenLazilyNF_Tc expr cont sw_chkr dtys subst us errs src_loc
+ = let
+ (s1, s2) = splitUniqSupply us
+ in
+ case (expr sw_chkr dtys subst s1 errs src_loc) of {
+ (result, subst2, errs2)
+ -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
+ }
+
returnNF_Tc :: a -> NF_TcM a
returnNF_Tc result sw_chkr dtys subst us errs src_loc
= (result, subst, errs)
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface TcMonadFns where
import Bag(Bag)
-import CharSeq(CSeq)
import Class(Class, ClassOp)
import CmdLineOpts(GlobalSwitch)
import ErrUtils(Error(..))
import HsBinds(Bind, Binds, MonoBinds, Sig)
import HsExpr(ArithSeqInfo, Expr)
import HsLit(Literal)
-import HsMatches(GRHS, GRHSsAndBinds, Match)
+import HsMatches(GRHSsAndBinds, Match)
import HsPat(InPat, TypecheckedPat)
-import Id(Id, IdDetails)
+import Id(Id)
import IdInfo(IdInfo, SpecEnv, SpecInfo)
import Inst(Inst, InstOrigin, OverloadedLit)
import InstEnv(InstTemplate)
import Maybes(Labda)
import Name(Name)
import NameTypes(FullName, ShortName)
-import PreludeGlaST(_MutableArray)
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
+import Pretty(PprStyle, Pretty(..), PrettyRep)
import SplitUniq(SplitUniqSupply)
import SrcLoc(SrcLoc)
import Subst(Subst)
import TyVar(TyVar, TyVarTemplate)
import UniType(UniType)
import Unique(Unique, UniqueSupply)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
+data Bag a
+data Class
type Error = PprStyle -> Int -> Bool -> PrettyRep
-data UnifyErrContext
- {-# GHC_PRAGMA PredCtxt (Expr Name (InPat Name)) | AppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | TooManyArgsCtxt (Expr Name (InPat Name)) | FunAppCtxt (Expr Name (InPat Name)) (Labda Id) (Expr Name (InPat Name)) UniType UniType Int | OpAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionLAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | SectionRAppCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | CaseCtxt (Expr Name (InPat Name)) [Match Name (InPat Name)] | BranchCtxt (Expr Name (InPat Name)) (Expr Name (InPat Name)) | ListCtxt [Expr Name (InPat Name)] | PatCtxt (InPat Name) | CaseBranchesCtxt [Match Name (InPat Name)] | FilterCtxt (Expr Name (InPat Name)) | GeneratorCtxt (InPat Name) (Expr Name (InPat Name)) | GRHSsBranchCtxt [GRHS Name (InPat Name)] | GRHSsGuardCtxt (Expr Name (InPat Name)) | PatMonoBindsCtxt (InPat Name) (GRHSsAndBinds Name (InPat Name)) | FunMonoBindsCtxt Name [Match Name (InPat Name)] | MatchCtxt UniType UniType | ArithSeqCtxt (Expr Name (InPat Name)) | CCallCtxt [Char] [Expr Name (InPat Name)] | AmbigDictCtxt [Inst] | SigCtxt Id UniType | MethodSigCtxt Name UniType | ExprSigCtxt (Expr Name (InPat Name)) UniType | ValSpecSigCtxt Name UniType SrcLoc | ValSpecSpecIdCtxt Name UniType Name SrcLoc | BindSigCtxt [Id] | SuperClassSigCtxt | CaseBranchCtxt (Match Name (InPat Name)) | Rank2ArgCtxt (Expr Id TypecheckedPat) UniType #-}
-data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-}
-data MonoBinds a b {-# GHC_PRAGMA EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc #-}
-data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data SpecInfo {-# GHC_PRAGMA SpecInfo [Labda UniType] Int Id #-}
-data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
-data InstOrigin {-# GHC_PRAGMA OccurrenceOf Id SrcLoc | InstanceDeclOrigin SrcLoc | LiteralOrigin Literal SrcLoc | ArithSeqOrigin (ArithSeqInfo Name (InPat Name)) SrcLoc | SignatureOrigin | ClassDeclOrigin SrcLoc | DerivingOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class Bool TyCon SrcLoc | InstanceSpecOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class UniType SrcLoc | DefaultDeclOrigin SrcLoc | ValSpecOrigin Name SrcLoc | CCallOrigin SrcLoc [Char] (Labda (Expr Name (InPat Name))) | LitLitOrigin SrcLoc [Char] | UnknownOrigin #-}
-data OverloadedLit {-# GHC_PRAGMA OverloadedIntegral Integer Id Id | OverloadedFractional (Ratio Integer) Id #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data UnifyErrContext
+data Binds a b
+data MonoBinds a b
+data TypecheckedPat
+data Id
+data SpecInfo
+data Inst
+data InstOrigin
+data OverloadedLit
+data Labda a
+data Name
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data Subst {-# GHC_PRAGMA MkSubst (_MutableArray _RealWorld Int (Labda UniType)) [(Int, Bag (Int, Labda UniType))] (_State _RealWorld) Int #-}
-data TcResult a {-# GHC_PRAGMA TcSucceeded a Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) | TcFailed Subst (Bag (PprStyle -> Int -> Bool -> PrettyRep)) #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-}
+data PrettyRep
+data SrcLoc
+data Subst
+data TcResult a
+data TyVar
+data UniType
+data UniqueSupply
applyTcSubstAndCollectTyVars :: [TyVar] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([TyVar], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 1222122 _N_ _S_ "S" _N_ _N_ #-}
applyTcSubstAndExpectTyVars :: [TyVar] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([TyVar], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 1222122 _N_ _S_ "S" _N_ _N_ #-}
copyTyVars :: [TyVarTemplate] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (([(TyVarTemplate, UniType)], [TyVar], [UniType]), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 2002120 _N_ _N_ _N_ _N_ #-}
mkIdsWithGivenTys :: [Name] -> [UniType] -> [IdInfo] -> [(Name, Id)]
- {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "SSL" _N_ _N_ #-}
mkIdsWithOpenTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([(Name, Id)], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 2002120 _N_ _N_ _N_ _N_ #-}
mkIdsWithPolyTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([(Name, Id)], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 2002120 _N_ _N_ _N_ _N_ #-}
newClassOpLocals :: [(TyVarTemplate, UniType)] -> [ClassOp] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Id], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 22002122 _N_ _S_ "LLAALU(AAS)LL" {_A_ 6 _U_ 222122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
newDict :: InstOrigin -> Class -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 9 _U_ 222002120 _N_ _S_ "LLLAALU(ALA)LA" {_A_ 6 _U_ 222212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
newDicts :: InstOrigin -> [(Class, UniType)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Inst], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 22002120 _N_ _S_ "LLAALU(ALA)LA" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
newLocalWithGivenTy :: Name -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 8 _U_ 22002120 _N_ _S_ "LLAALU(ALA)LA" {_A_ 5 _U_ 22212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
newLocalsWithOpenTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Id], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 2002120 _N_ _N_ _N_ _N_ #-}
newLocalsWithPolyTyVarTys :: [Name] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([Id], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 1 _U_ 2002120 _N_ _N_ _N_ _N_ #-}
newMethod :: InstOrigin -> Id -> [UniType] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 9 _U_ 222002120 _N_ _S_ "LLLAALU(ALA)LA" {_A_ 6 _U_ 222212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
newOpenTyVarTy :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 6 _U_ 002120 _N_ _S_ "AALU(AAA)LA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
newOverloadedLit :: InstOrigin -> OverloadedLit -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Inst, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 9 _U_ 222002120 _N_ _S_ "LLLAALU(ALA)LA" {_A_ 6 _U_ 222212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
newPolyTyVarTy :: (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (UniType, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 6 _U_ 002120 _N_ _S_ "AALU(AAA)LA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
newPolyTyVarTys :: Int -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ([UniType], Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 7 _U_ 2002120 _N_ _S_ "LAALU(AAA)LA" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
newSpecId :: Id -> [Labda UniType] -> UniType -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 9 _U_ 222002120 _N_ _S_ "LLLAALU(ALA)LA" {_A_ 6 _U_ 222212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
newSpecPragmaId :: Name -> UniType -> Labda SpecInfo -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> (Id, Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 9 _U_ 222002120 _N_ _S_ "LLLAALU(ALA)LA" {_A_ 6 _U_ 222212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
newOpenTyVarTys :: Int -> NF_TcM [UniType]
newOpenTyVarTys n
- = getTyVarUniquesTc n `thenNF_Tc` \ new_uniqs ->
+ = getTyVarUniquesTc n `thenLazilyNF_Tc` \ new_uniqs ->
returnNF_Tc [mkTyVarTy (mkOpenSysTyVar u) | u <- new_uniqs]
newPolyTyVarTys :: Int -> NF_TcM [UniType]
newPolyTyVarTys n
- = getTyVarUniquesTc n `thenNF_Tc` \ new_uniqs ->
+ = getTyVarUniquesTc n `thenLazilyNF_Tc` \ new_uniqs ->
returnNF_Tc [mkTyVarTy (mkPolySysTyVar u) | u <- new_uniqs]
newOpenTyVarTy, newPolyTyVarTy :: NF_TcM UniType
newOpenTyVarTy
- = getTyVarUniqueTc `thenNF_Tc` \ new_uniq ->
+ = getTyVarUniqueTc `thenLazilyNF_Tc` \ new_uniq ->
returnNF_Tc (mkTyVarTy (mkOpenSysTyVar new_uniq))
newPolyTyVarTy
- = getTyVarUniqueTc `thenNF_Tc` \ new_uniq ->
+ = getTyVarUniqueTc `thenLazilyNF_Tc` \ new_uniq ->
returnNF_Tc (mkTyVarTy (mkPolySysTyVar new_uniq))
\end{code}
import TcMonad(TcResult)
import UniType(UniType)
tcMonoBinds :: E -> MonoBinds Name (InPat Name) -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (MonoBinds Id TypecheckedPat, LIE)
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
import UniType(UniType)
import UniqFM(UniqFM)
tcInstanceType :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> Bool -> SrcLoc -> MonoType Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult UniType
- {-# GHC_PRAGMA _A_ 6 _U_ 2221212122 _N_ _S_ "LLLLLS" _N_ _N_ #-}
tcMonoType :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> MonoType Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult UniType
- {-# GHC_PRAGMA _A_ 4 _U_ 22212222 _N_ _S_ "LLLS" _N_ _N_ #-}
import TcMonad(TcResult)
import UniType(UniType)
tcPat :: E -> InPat Name -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult (TypecheckedPat, LIE, UniType)
- {-# GHC_PRAGMA _A_ 2 _U_ 22222222 _N_ _S_ "LS" _N_ _N_ #-}
import UniType(UniType)
import UniqFM(UniqFM)
tcPolyType :: UniqFM Class -> UniqFM TyCon -> UniqFM UniType -> PolyType Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult UniType
- {-# GHC_PRAGMA _A_ 4 _U_ 22212222 _N_ _S_ "LLLS" _N_ _N_ #-}
import UniType(UniType)
import UniqFM(UniqFM)
tcClassOpPragmas :: E -> UniType -> Id -> Id -> SpecEnv -> ClassOpPragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult (IdInfo, IdInfo)
- {-# GHC_PRAGMA _A_ 6 _U_ 2022212222 _N_ _S_ "LALLLS" {_A_ 5 _U_ 222212222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
tcDataPragmas :: UniqFM TyCon -> UniqFM UniType -> TyCon -> [TyVarTemplate] -> DataPragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult ([ConDecl Name], [SpecInfo])
- {-# GHC_PRAGMA _A_ 5 _U_ 200112222 _N_ _S_ "LAALU(LS)" {_A_ 4 _U_ 21212122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
tcDictFunPragmas :: E -> UniType -> Id -> InstancePragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult IdInfo
- {-# GHC_PRAGMA _A_ 4 _U_ 22222222 _N_ _S_ "LLLS" _N_ _N_ #-}
tcGenPragmas :: E -> Labda UniType -> Id -> GenPragmas Name -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult IdInfo
- {-# GHC_PRAGMA _A_ 4 _U_ 22212222 _N_ _S_ "LLLS" _N_ _N_ #-}
tcTypePragmas :: TypePragmas -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "E" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: TypePragmas) -> case u0 of { _ALG_ _ORIG_ HsPragmas NoTypePragmas -> _!_ False [] []; _ORIG_ HsPragmas AbstractTySynonym -> _!_ True [] []; _NO_DEFLT_ } _N_ #-}
import TcMonad(TcResult)
import UniType(UniType)
tcQuals :: E -> [Qual Name (InPat Name)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Qual Id TypecheckedPat], LIE)
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
import TyVar(TyVar)
import UniType(UniType)
bindInstsOfLocalFuns :: LIE -> [Id] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> ((LIE, MonoBinds Id TypecheckedPat), Subst, Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 2 _U_ 12222222 _N_ _S_ "U(S)L" {_A_ 2 _U_ 22222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
tcSimplify :: Bool -> [TyVar] -> [TyVar] -> [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], [(Inst, Expr Id TypecheckedPat)], [Inst])
- {-# GHC_PRAGMA _A_ 4 _U_ 1111222122 _N_ _S_ "LSSS" _N_ _N_ #-}
tcSimplifyAndCheck :: Bool -> [TyVar] -> [TyVar] -> [Inst] -> [Inst] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], [(Inst, Expr Id TypecheckedPat)])
- {-# GHC_PRAGMA _A_ 6 _U_ 111112222122 _N_ _S_ "LSSSSL" _N_ _N_ #-}
tcSimplifyCheckThetas :: InstOrigin -> [(Class, UniType)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
tcSimplifyRank2 :: [TyVar] -> [Inst] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ([Inst], [(Inst, Expr Id TypecheckedPat)])
- {-# GHC_PRAGMA _A_ 3 _U_ 212222122 _N_ _S_ "LSL" _N_ _N_ #-}
tcSimplifyThetas :: (Class -> UniType -> InstOrigin) -> [(Class, UniType)] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [(Class, UniType)]
- {-# GHC_PRAGMA _A_ 2 _U_ 21222222 _N_ _S_ "LS" _N_ _N_ #-}
tcSimplifyTop :: [Inst] -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult [(Inst, Expr Id TypecheckedPat)]
- {-# GHC_PRAGMA _A_ 1 _U_ 1222122 _N_ _S_ "S" _N_ _N_ #-}
import UniType(UniType)
import UniqFM(UniqFM)
tcTyDecls :: E -> (Name -> Bool) -> (Name -> [DataTypeSig Name]) -> [TyDecl Name] -> (GlobalSwitch -> Bool) -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> Baby_TcResult (UniqFM TyCon, [(Name, Id)], FiniteMap TyCon [[Labda UniType]])
- {-# GHC_PRAGMA _A_ 4 _U_ 22212222 _N_ _S_ "LLLS" _N_ _N_ #-}
import AbsSyn(Module)
import Bag(Bag)
import CE(CE(..))
-import CharSeq(CSeq)
import Class(Class)
import CmdLineOpts(GlobalSwitch)
import E(E)
import ErrUtils(Error(..))
import FiniteMap(FiniteMap)
-import HsBinds(Bind, Binds, MonoBinds, Sig)
+import HsBinds(Bind, Binds, Sig)
import HsDecls(ClassDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
import HsExpr(ArithSeqInfo, Expr, Qual)
import HsImpExp(IE, ImportedInterface)
import HsMatches(Match)
import HsPat(InPat, RenamedPat(..), TypecheckedPat)
import HsTypes(PolyType)
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
-import Inst(Inst, InstOrigin, OverloadedLit)
+import Id(Id)
+import Inst(Inst)
import Maybes(Labda, MaybeErr)
import Name(Name)
import NameTypes(FullName, ShortName)
import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
+import Pretty(PprStyle, Pretty(..), PrettyRep)
import ProtoName(ProtoName)
import SplitUniq(SplitUniqSupply)
import SrcLoc(SrcLoc)
import TcInstDcls(InstInfo)
import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import TyVar(TyVar)
import UniType(UniType)
import UniqFM(UniqFM)
import Unique(Unique)
-data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
+data Module a b
+data Bag a
type CE = UniqFM Class
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data E {-# GHC_PRAGMA MkE (UniqFM TyCon) (UniqFM Id) (UniqFM Id) (UniqFM Class) #-}
+data GlobalSwitch
+data E
type Error = PprStyle -> Int -> Bool -> PrettyRep
-data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-}
-data FixityDecl a {-# GHC_PRAGMA InfixL a Int | InfixR a Int | InfixN a Int #-}
-data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-}
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
+data Binds a b
+data FixityDecl a
+data Expr a b
+data InPat a
type RenamedPat = InPat Name
-data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data TypecheckedPat
+data Id
+data Inst
+data Labda a
+data MaybeErr a b
+data Name
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data InstInfo {-# GHC_PRAGMA InstInfo Class [TyVarTemplate] UniType [(Class, UniType)] [(Class, UniType)] Id [Id] (MonoBinds Name (InPat Name)) Bool _PackedString SrcLoc [Sig Name] #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data PrettyRep
+data ProtoName
+data SplitUniqSupply
+data InstInfo
+data UniqFM a
typecheckModule :: (GlobalSwitch -> Bool) -> SplitUniqSupply -> (ProtoName -> Labda Name, ProtoName -> Labda Name) -> Module Name (InPat Name) -> MaybeErr ((Binds Id TypecheckedPat, Binds Id TypecheckedPat, Binds Id TypecheckedPat, [(Inst, Expr Id TypecheckedPat)]), ([FixityDecl Name], [Id], UniqFM Class, UniqFM TyCon, Bag InstInfo), FiniteMap TyCon [[Labda UniType]], E, PprStyle -> Int -> Bool -> PrettyRep) (Bag (PprStyle -> Int -> Bool -> PrettyRep))
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _S_ "LLLU(LAALSLLLLLLLL)" _N_ _N_ #-}
import TcMonad(TcResult)
import UniType(UniType)
unifyTauTy :: UniType -> UniType -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
- {-# GHC_PRAGMA _A_ 3 _U_ 222222222 _N_ _S_ "SSL" _N_ _N_ #-}
unifyTauTyList :: [UniType] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
- {-# GHC_PRAGMA _A_ 2 _U_ 12222222 _N_ _S_ "SL" _N_ _N_ #-}
unifyTauTyLists :: [UniType] -> [UniType] -> UnifyErrContext -> (GlobalSwitch -> Bool) -> [UniType] -> Subst -> SplitUniqSupply -> Bag (PprStyle -> Int -> Bool -> PrettyRep) -> SrcLoc -> TcResult ()
- {-# GHC_PRAGMA _A_ 3 _U_ 112222222 _N_ _S_ "SSL" _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface AbsUniType where
import Bag(Bag)
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo)
-import CharSeq(CSeq)
import Class(Class, ClassOp, cmpClass, derivableClassKeys, getClassBigSig, getClassInstEnv, getClassKey, getClassOpId, getClassOpLocalType, getClassOpString, getClassOpTag, getClassOps, getClassSig, getConstMethodId, getDefaultMethodId, getSuperDictSelId, isNumericClass, isStandardClass, isSuperClassOf, mkClass, mkClassOp)
import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreAtom, CoreExpr)
-import Id(DataCon(..), Id, IdDetails)
+import Id(DataCon(..), Id)
import IdEnv(IdEnv(..))
-import IdInfo(IdInfo)
-import InstEnv(ClassInstEnv(..), InstTemplate, InstTy, MatchEnv(..))
-import MagicUFs(MagicUnfoldingFun)
-import Maybes(Labda, assocMaybe)
+import InstEnv(ClassInstEnv(..), InstTemplate, MatchEnv(..))
+import Maybes(Labda)
import Name(Name)
-import NameTypes(FullName, Provenance, ShortName)
+import NameTypes(FullName, ShortName)
import Outputable(ExportFlag, NamedThing, Outputable)
import PreludePS(_PackedString)
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep)
+import Pretty(PprStyle, Pretty(..), PrettyRep)
import PrimKind(PrimKind)
-import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance)
-import SrcLoc(SrcLoc)
+import SimplEnv(UnfoldingDetails)
import TyCon(Arity(..), TyCon, cmpTyCon, derivedFor, eqTyCon, getTyConArity, getTyConDataCons, getTyConDerivings, getTyConFamilySize, getTyConKind, getTyConTyVarTemplates, isBigTupleTyCon, isBoxedTyCon, isDataTyCon, isEnumerationTyCon, isLocalGenTyCon, isLocalSpecTyCon, isPrimTyCon, isSynTyCon, isTupleTyCon, isVisibleSynTyCon, maybeCharLikeTyCon, maybeDoubleLikeTyCon, maybeFloatLikeTyCon, maybeIntLikeTyCon, maybeSingleConstructorTyCon, mkDataTyCon, mkPrimTyCon, mkSpecTyCon, mkSynonymTyCon, mkTupleTyCon)
import TyVar(TyVar, TyVarTemplate, alphaTyVars, alpha_tv, alpha_tyvar, beta_tv, beta_tyvar, cloneTyVar, cloneTyVarFromTemplate, cmpTyVar, delta_tv, delta_tyvar, epsilon_tv, epsilon_tyvar, eqTyVar, gamma_tv, gamma_tyvar, instantiateTyVarTemplates, ltTyVar, mkOpenSysTyVar, mkPolySysTyVar, mkSysTyVarTemplate, mkTemplateTyVars, mkUserTyVar, mkUserTyVarTemplate)
import TyVarEnv(TyVarEnv(..), TypeEnv(..))
import UniType(InstTyEnv(..), RhoType(..), SigmaType(..), TauType(..), ThetaType(..), UniType, alpha, alpha_ty, beta, beta_ty, cmpUniType, delta, delta_ty, epsilon, epsilon_ty, gamma, gamma_ty, instantiateTauTy, instantiateThetaTy, instantiateTy, mkDictTy, mkForallTy, mkRhoTy, mkSigmaTy, mkTyVarTemplateTy, mkTyVarTy, quantifyTy)
import UniqFM(UniqFM)
import Unique(Unique)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
-data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
+data Bag a
+data Class
+data ClassOp
+data GlobalSwitch
type DataCon = Id
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+data Id
type IdEnv a = UniqFM a
type ClassInstEnv = [(UniType, InstTemplate)]
-data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-}
+data InstTemplate
type MatchEnv a b = [(a, b)]
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-}
-data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-}
-data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
+data Labda a
+data Name
+data FullName
+data ShortName
+data ExportFlag
+data PprStyle
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data UnfoldingDetails {-# GHC_PRAGMA NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance #-}
+data PrettyRep
+data PrimKind
+data UnfoldingDetails
type Arity = Int
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
+data TyCon
+data TyVar
+data TyVarTemplate
type TyVarEnv a = UniqFM a
type TypeEnv = UniqFM UniType
type InstTyEnv = [(TyVarTemplate, UniType)]
type SigmaType = UniType
type TauType = UniType
type ThetaType = [(Class, UniType)]
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data UniType
+data UniqFM a
+data Unique
cmpClass :: Class -> Class -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
derivableClassKeys :: [Unique]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
getClassBigSig :: Class -> (TyVarTemplate, [Class], [Id], [ClassOp], [Id], [Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AALLLLLLAA)" _N_ _N_ #-}
getClassInstEnv :: Class -> [(UniType, InstTemplate)]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAASA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [(UniType, InstTemplate)]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> u9; _NO_DEFLT_ } _N_ #-}
getClassKey :: Class -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> u1; _NO_DEFLT_ } _N_ #-}
getClassOpId :: Class -> ClassOp -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AAAAAASAAA)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: [Id]) (u1 :: Int#) -> case _#_ minusInt# [] [u1, 1#] of { _PRIM_ (u2 :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u0, u2 ] } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Class) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (uc :: _PackedString) (ud :: Int) (ue :: UniType) -> case ud of { _ALG_ I# (uf :: Int#) -> case _#_ minusInt# [] [uf, 1#] of { _PRIM_ (ug :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u8, ug ] }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getClassOpLocalType :: ClassOp -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u1 :: _PackedString) (u2 :: Int) (u3 :: UniType) -> u3; _NO_DEFLT_ } _N_ #-}
getClassOpString :: ClassOp -> _PackedString
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(SAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: _PackedString) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u1 :: _PackedString) (u2 :: Int) (u3 :: UniType) -> u1; _NO_DEFLT_ } _N_ #-}
getClassOpTag :: ClassOp -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AU(P)A)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u1 :: _PackedString) (u2 :: Int) (u3 :: UniType) -> u2; _NO_DEFLT_ } _N_ #-}
getClassOps :: Class -> [ClassOp]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAASAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [ClassOp]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> u6; _NO_DEFLT_ } _N_ #-}
getClassSig :: Class -> (TyVarTemplate, [Class], [ClassOp])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AALLALAAAA)" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: TyVarTemplate) (u1 :: [Class]) (u2 :: [ClassOp]) -> _!_ _TUP_3 [TyVarTemplate, [Class], [ClassOp]] [u0, u1, u2] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> _!_ _TUP_3 [TyVarTemplate, [Class], [ClassOp]] [u3, u4, u6]; _NO_DEFLT_ } _N_ #-}
getConstMethodId :: Class -> ClassOp -> UniType -> Id
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(AAAAALSAAA)U(LU(P)L)L" {_A_ 4 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getDefaultMethodId :: Class -> ClassOp -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AAAAAAASAA)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: [Id]) (u1 :: Int#) -> case _#_ minusInt# [] [u1, 1#] of { _PRIM_ (u2 :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u0, u2 ] } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Class) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (uc :: _PackedString) (ud :: Int) (ue :: UniType) -> case ud of { _ALG_ I# (uf :: Int#) -> case _#_ minusInt# [] [uf, 1#] of { _PRIM_ (ug :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u9, ug ] }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getSuperDictSelId :: Class -> Class -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAASLAAAAA)L" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isNumericClass :: Class -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isStandardClass :: Class -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isSuperClassOf :: Class -> Class -> Labda [Class]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(AAAAAAAAAS)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Class) (u1 :: [(Class, [Class])]) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ Maybes assocMaybe [ (Class), _N_ ] { [Class] } [ u1, u0 ] _N_} _F_ _IF_ARGS_ 0 2 XC 4 \ (u0 :: Class) (u1 :: Class) -> case u1 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ Maybes assocMaybe [ (Class), _N_ ] { [Class] } [ ub, u0 ]; _NO_DEFLT_ } _N_ #-}
mkClass :: Name -> TyVarTemplate -> [Class] -> [Id] -> [ClassOp] -> [Id] -> [Id] -> [(UniType, InstTemplate)] -> Class
- {-# GHC_PRAGMA _A_ 8 _U_ 12222222 _N_ _N_ _N_ _N_ #-}
mkClassOp :: _PackedString -> Int -> UniType -> ClassOp
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: _PackedString) (u1 :: Int) (u2 :: UniType) -> _!_ _ORIG_ Class MkClassOp [] [u0, u1, u2] _N_ #-}
-assocMaybe :: Eq a => [(a, b)] -> a -> Labda b
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "LSL" _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ [Char], _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ TyVarTemplate, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Name, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Class, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ } #-}
cmpTyCon :: TyCon -> TyCon -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
derivedFor :: Class -> TyCon -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _F_ _IF_ARGS_ 0 2 XC 9 \ (u0 :: Class) (u1 :: TyCon) -> case u1 of { _ALG_ _ORIG_ TyCon DataTyCon (u2 :: Unique) (u3 :: FullName) (u4 :: Int) (u5 :: [TyVarTemplate]) (u6 :: [Id]) (u7 :: [Class]) (u8 :: Bool) -> _APP_ _WRKR_ _SPEC_ _ORIG_ Util isIn [ (Class) ] [ u0, u7 ]; (u9 :: TyCon) -> _!_ False [] [] } _N_ #-}
eqTyCon :: TyCon -> TyCon -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-}
getTyConArity :: TyCon -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getTyConDataCons :: TyCon -> [Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getTyConDerivings :: TyCon -> [Class]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: TyCon) -> case u0 of { _ALG_ _ORIG_ TyCon DataTyCon (u1 :: Unique) (u2 :: FullName) (u3 :: Int) (u4 :: [TyVarTemplate]) (u5 :: [Id]) (u6 :: [Class]) (u7 :: Bool) -> u6; _ORIG_ TyCon SpecTyCon (u8 :: TyCon) (u9 :: [Labda UniType]) -> _APP_ _TYAPP_ _ORIG_ Util panic { [Class] } [ _NOREP_S_ "getTyConDerivings:SpecTyCon" ]; (ua :: TyCon) -> _!_ _NIL_ [Class] [] } _N_ #-}
getTyConFamilySize :: TyCon -> Labda Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getTyConKind :: TyCon -> [PrimKind] -> PrimKind
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 8 \ (u0 :: TyCon) (u1 :: [PrimKind]) -> case u0 of { _ALG_ _ORIG_ TyCon PrimTyCon (u2 :: Unique) (u3 :: FullName) (u4 :: Int) (u5 :: [PrimKind] -> PrimKind) -> _APP_ u5 [ u1 ]; (u6 :: TyCon) -> _!_ _ORIG_ PrimKind PtrKind [] [] } _N_ #-}
getTyConTyVarTemplates :: TyCon -> [TyVarTemplate]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isBigTupleTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isBoxedTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isDataTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isEnumerationTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isLocalGenTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
isLocalSpecTyCon :: Bool -> TyCon -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "LS" _N_ _N_ #-}
isPrimTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isSynTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: TyCon) -> case u0 of { _ALG_ _ORIG_ TyCon SynonymTyCon (u1 :: Unique) (u2 :: FullName) (u3 :: Int) (u4 :: [TyVarTemplate]) (u5 :: UniType) (u6 :: Bool) -> _!_ True [] []; _ORIG_ TyCon SpecTyCon (u7 :: TyCon) (u8 :: [Labda UniType]) -> _APP_ _TYAPP_ _ORIG_ Util panic { Bool } [ _NOREP_S_ "isSynTyCon: SpecTyCon" ]; (u9 :: TyCon) -> _!_ False [] [] } _N_ #-}
isTupleTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isVisibleSynTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyCon) -> case u0 of { _ALG_ _ORIG_ TyCon SynonymTyCon (u1 :: Unique) (u2 :: FullName) (u3 :: Int) (u4 :: [TyVarTemplate]) (u5 :: UniType) (u6 :: Bool) -> u6; (u7 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Bool } [ _NOREP_S_ "isVisibleSynTyCon" ] } _N_ #-}
maybeCharLikeTyCon :: TyCon -> Labda Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
maybeDoubleLikeTyCon :: TyCon -> Labda Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
maybeFloatLikeTyCon :: TyCon -> Labda Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
maybeIntLikeTyCon :: TyCon -> Labda Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
maybeSingleConstructorTyCon :: TyCon -> Labda Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkDataTyCon :: Unique -> FullName -> Int -> [TyVarTemplate] -> [Id] -> [Class] -> Bool -> TyCon
- {-# GHC_PRAGMA _A_ 7 _U_ 2222222 _N_ _N_ _F_ _IF_ARGS_ 0 7 XXXXXXX 8 \ (u0 :: Unique) (u1 :: FullName) (u2 :: Int) (u3 :: [TyVarTemplate]) (u4 :: [Id]) (u5 :: [Class]) (u6 :: Bool) -> _!_ _ORIG_ TyCon DataTyCon [] [u0, u1, u2, u3, u4, u5, u6] _N_ #-}
mkPrimTyCon :: Unique -> FullName -> Int -> ([PrimKind] -> PrimKind) -> TyCon
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: FullName) (u2 :: Int) (u3 :: [PrimKind] -> PrimKind) -> _!_ _ORIG_ TyCon PrimTyCon [] [u0, u1, u2, u3] _N_ #-}
mkSpecTyCon :: TyCon -> [Labda UniType] -> TyCon
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: TyCon) (u1 :: [Labda UniType]) -> _!_ _ORIG_ TyCon SpecTyCon [] [u0, u1] _N_ #-}
mkSynonymTyCon :: Unique -> FullName -> Int -> [TyVarTemplate] -> UniType -> Bool -> TyCon
- {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _N_ _F_ _IF_ARGS_ 0 6 XXXXXX 7 \ (u0 :: Unique) (u1 :: FullName) (u2 :: Int) (u3 :: [TyVarTemplate]) (u4 :: UniType) (u5 :: Bool) -> _!_ _ORIG_ TyCon SynonymTyCon [] [u0, u1, u2, u3, u4, u5] _N_ #-}
mkTupleTyCon :: Int -> TyCon
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ TyCon TupleTyCon [] [u0] _N_ #-}
alphaTyVars :: [TyVarTemplate]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
alpha_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
alpha_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
beta_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
beta_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
cloneTyVar :: TyVar -> Unique -> TyVar
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
cloneTyVarFromTemplate :: TyVarTemplate -> Unique -> TyVar
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: TyVarTemplate) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u2 :: Unique) (u3 :: _PackedString) -> _!_ _ORIG_ TyVar PolySysTyVar [] [u1]; _ORIG_ TyVar UserTyVarTemplate (u4 :: Unique) (u5 :: ShortName) -> _!_ _ORIG_ TyVar UserTyVar [] [u1, u5]; _NO_DEFLT_ } _N_ #-}
cmpTyVar :: TyVar -> TyVar -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
delta_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
delta_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
epsilon_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
epsilon_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
eqTyVar :: TyVar -> TyVar -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-}
gamma_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
gamma_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
instantiateTyVarTemplates :: [TyVarTemplate] -> [Unique] -> ([(TyVarTemplate, UniType)], [TyVar], [UniType])
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _N_ _N_ _N_ #-}
ltTyVar :: TyVar -> TyVar -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
mkOpenSysTyVar :: Unique -> TyVar
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Unique) -> _!_ _ORIG_ TyVar OpenSysTyVar [] [u0] _N_ #-}
mkPolySysTyVar :: Unique -> TyVar
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Unique) -> _!_ _ORIG_ TyVar PolySysTyVar [] [u0] _N_ #-}
mkSysTyVarTemplate :: Unique -> _PackedString -> TyVarTemplate
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: _PackedString) -> _!_ _ORIG_ TyVar SysTyVarTemplate [] [u0, u1] _N_ #-}
mkTemplateTyVars :: [TyVar] -> [TyVarTemplate]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkUserTyVar :: Unique -> ShortName -> TyVar
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: ShortName) -> _!_ _ORIG_ TyVar UserTyVar [] [u0, u1] _N_ #-}
mkUserTyVarTemplate :: Unique -> ShortName -> TyVarTemplate
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: ShortName) -> _!_ _ORIG_ TyVar UserTyVarTemplate [] [u0, u1] _N_ #-}
applyNonSynTyCon :: TyCon -> [UniType] -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: TyCon) (u1 :: [UniType]) -> _!_ _ORIG_ UniType UniData [] [u0, u1] _N_ #-}
applySynTyCon :: TyCon -> [UniType] -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
applyTy :: UniType -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
applyTyCon :: TyCon -> [UniType] -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
applyTypeEnvToThetaTy :: UniqFM UniType -> [(a, UniType)] -> [(a, UniType)]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
applyTypeEnvToTy :: UniqFM UniType -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
cmpUniTypeMaybeList :: [Labda UniType] -> [Labda UniType] -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
expandVisibleTySyn :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
extractTyVarTemplatesFromTy :: UniType -> [TyVarTemplate]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
extractTyVarsFromTy :: UniType -> [TyVar]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
extractTyVarsFromTys :: [UniType] -> [TyVar]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
funResultTy :: UniType -> Int -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getMentionedTyCons :: TyCon -> [TyCon]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getMentionedTyConsAndClassesFromClass :: Class -> (Bag TyCon, Bag Class)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "U(LLLLLSLLLL)" _N_ _N_ #-}
getMentionedTyConsAndClassesFromTyCon :: TyCon -> (Bag TyCon, Bag Class)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getMentionedTyConsAndClassesFromUniType :: UniType -> (Bag TyCon, Bag Class)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getTauType :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 4 \ (u0 :: UniType) -> case _APP_ _ORIG_ UniTyFuns splitType [ u0 ] of { _ALG_ _TUP_3 (u1 :: [TyVarTemplate]) (u2 :: [(Class, UniType)]) (u3 :: UniType) -> u3; _NO_DEFLT_ } _N_ #-}
getTyVar :: [Char] -> UniType -> TyVar
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
getTyVarMaybe :: UniType -> Labda TyVar
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getTyVarTemplateMaybe :: UniType -> Labda TyVarTemplate
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getTypeString :: UniType -> [_PackedString]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getUniDataSpecTyCon :: UniType -> (TyCon, [UniType], [Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getUniDataSpecTyCon_maybe :: UniType -> Labda (TyCon, [UniType], [Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getUniDataTyCon :: UniType -> (TyCon, [UniType], [Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getUniDataTyCon_maybe :: UniType -> Labda (TyCon, [UniType], [Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getUniTyDescription :: UniType -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
glueTyArgs :: [UniType] -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
instanceIsExported :: Class -> UniType -> Bool -> Bool
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AU(AASLAA)AAAAAAAA)SL" {_A_ 4 _U_ 2121 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isDictTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isForAllTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isFunType :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
isGroundOrTyVarTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
isGroundTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isLeakFreeType :: [TyCon] -> UniType -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
isPrimType :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isTauTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isTyVarTemplateTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isTyVarTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isUnboxedDataType :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
kindFromType :: UniType -> PrimKind
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mapOverTyVars :: (TyVar -> UniType) -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
matchTy :: UniType -> UniType -> Labda [(TyVarTemplate, UniType)]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
maybeBoxedPrimType :: UniType -> Labda (Id, UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
maybePurelyLocalClass :: Class -> Labda [Int -> Bool -> PrettyRep]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "U(LLLLLSLLLL)" _N_ _N_ #-}
maybePurelyLocalTyCon :: TyCon -> Labda [Int -> Bool -> PrettyRep]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
maybePurelyLocalType :: UniType -> Labda [Int -> Bool -> PrettyRep]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
maybeUnpackFunTy :: UniType -> Labda (UniType, UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
mkSuperDictSelType :: Class -> Class -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "U(LLLLLLLLLL)L" _N_ _N_ #-}
pprClassOp :: PprStyle -> ClassOp -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
pprIfaceClass :: (GlobalSwitch -> Bool) -> (Id -> Id) -> UniqFM UnfoldingDetails -> Class -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222122 _N_ _S_ "LLLU(ALLLLLLLAA)" _N_ _N_ #-}
pprMaybeTy :: PprStyle -> Labda UniType -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "SS" _N_ _N_ #-}
pprParendUniType :: PprStyle -> UniType -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-}
pprTyCon :: PprStyle -> TyCon -> [[Labda UniType]] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "SSL" _N_ _N_ #-}
pprUniType :: PprStyle -> UniType -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-}
returnsRealWorld :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
showTyCon :: PprStyle -> TyCon -> [Char]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
showTypeCategory :: UniType -> Char
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
specMaybeTysSuffix :: [Labda UniType] -> _PackedString
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
specialiseTy :: UniType -> [Labda UniType] -> Int -> UniType
- {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "SLL" _N_ _N_ #-}
splitDictType :: UniType -> (Class, UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
splitForalls :: UniType -> ([TyVarTemplate], UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
splitTyArgs :: UniType -> ([UniType], UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
splitType :: UniType -> ([TyVarTemplate], [(Class, UniType)], UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
splitTypeWithDictsAsArgs :: UniType -> ([TyVarTemplate], [UniType], UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
typeMaybeString :: Labda UniType -> [_PackedString]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
unDictifyTy :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
alpha :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar alpha_tv] _N_ #-}
alpha_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar alpha_tyvar] _N_ #-}
beta :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar beta_tv] _N_ #-}
beta_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar beta_tyvar] _N_ #-}
cmpUniType :: Bool -> UniType -> UniType -> Int#
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
delta :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar delta_tv] _N_ #-}
delta_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar delta_tyvar] _N_ #-}
epsilon :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar epsilon_tv] _N_ #-}
epsilon_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar epsilon_tyvar] _N_ #-}
gamma :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar gamma_tv] _N_ #-}
gamma_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar gamma_tyvar] _N_ #-}
instantiateTauTy :: [(TyVarTemplate, UniType)] -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniType instantiateTy _N_ #-}
instantiateThetaTy :: [(TyVarTemplate, UniType)] -> [(Class, UniType)] -> [(Class, UniType)]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
instantiateTy :: [(TyVarTemplate, UniType)] -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ #-}
mkDictTy :: Class -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Class) (u1 :: UniType) -> _!_ _ORIG_ UniType UniDict [] [u0, u1] _N_ #-}
mkForallTy :: [TyVarTemplate] -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
mkRhoTy :: [(Class, UniType)] -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
mkSigmaTy :: [TyVarTemplate] -> [(Class, UniType)] -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SLL" _N_ _N_ #-}
mkTyVarTemplateTy :: TyVarTemplate -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVarTemplate) -> _!_ _ORIG_ UniType UniTyVarTemplate [] [u0] _N_ #-}
mkTyVarTy :: TyVar -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _!_ _ORIG_ UniType UniTyVar [] [u0] _N_ #-}
quantifyTy :: [TyVar] -> UniType -> ([TyVarTemplate], UniType)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
instance Eq Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Class -> Class -> Bool), (Class -> Class -> Bool)] [_CONSTM_ Eq (==) (Class), _CONSTM_ Eq (/=) (Class)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ eqInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Eq (/=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Eq ClassOp
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool)] [_CONSTM_ Eq (==) (ClassOp), _CONSTM_ Eq (/=) (ClassOp)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Eq TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool)] [_CONSTM_ Eq (==) (TyCon), _CONSTM_ Eq (/=) (TyCon)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool)] [_CONSTM_ Eq (==) (TyVar), _CONSTM_ Eq (/=) (TyVar)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq TyVarTemplate
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool)] [_CONSTM_ Eq (==) (TyVarTemplate), _CONSTM_ Eq (/=) (TyVarTemplate)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq UniType
- {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UniType -> UniType -> Bool), (UniType -> UniType -> Bool)] [_CONSTM_ Eq (==) (UniType), _CONSTM_ Eq (/=) (UniType)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Eq Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Unique -> Unique -> Bool), (Unique -> Unique -> Bool)] [_CONSTM_ Eq (==) (Unique), _CONSTM_ Eq (/=) (Unique)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Ord Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Class}}, (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Class), (Class -> Class -> Class), (Class -> Class -> _CMP_TAG)] [_DFUN_ Eq (Class), _CONSTM_ Ord (<) (Class), _CONSTM_ Ord (<=) (Class), _CONSTM_ Ord (>=) (Class), _CONSTM_ Ord (>) (Class), _CONSTM_ Ord max (Class), _CONSTM_ Ord min (Class), _CONSTM_ Ord _tagCmp (Class)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ ltInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ leInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord ClassOp
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq ClassOp}}, (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> _CMP_TAG)] [_DFUN_ Eq (ClassOp), _CONSTM_ Ord (<) (ClassOp), _CONSTM_ Ord (<=) (ClassOp), _CONSTM_ Ord (>=) (ClassOp), _CONSTM_ Ord (>) (ClassOp), _CONSTM_ Ord max (ClassOp), _CONSTM_ Ord min (ClassOp), _CONSTM_ Ord _tagCmp (ClassOp)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ ltInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ leInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ geInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ geInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ gtInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ gtInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Ord TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyCon}}, (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> _CMP_TAG)] [_DFUN_ Eq (TyCon), _CONSTM_ Ord (<) (TyCon), _CONSTM_ Ord (<=) (TyCon), _CONSTM_ Ord (>=) (TyCon), _CONSTM_ Ord (>) (TyCon), _CONSTM_ Ord max (TyCon), _CONSTM_ Ord min (TyCon), _CONSTM_ Ord _tagCmp (TyCon)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVar}}, (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> _CMP_TAG)] [_DFUN_ Eq (TyVar), _CONSTM_ Ord (<) (TyVar), _CONSTM_ Ord (<=) (TyVar), _CONSTM_ Ord (>=) (TyVar), _CONSTM_ Ord (>) (TyVar), _CONSTM_ Ord max (TyVar), _CONSTM_ Ord min (TyVar), _CONSTM_ Ord _tagCmp (TyVar)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord TyVarTemplate
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVarTemplate}}, (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> _CMP_TAG)] [_DFUN_ Eq (TyVarTemplate), _CONSTM_ Ord (<) (TyVarTemplate), _CONSTM_ Ord (<=) (TyVarTemplate), _CONSTM_ Ord (>=) (TyVarTemplate), _CONSTM_ Ord (>) (TyVarTemplate), _CONSTM_ Ord max (TyVarTemplate), _CONSTM_ Ord min (TyVarTemplate), _CONSTM_ Ord _tagCmp (TyVarTemplate)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Unique}}, (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Bool), (Unique -> Unique -> Unique), (Unique -> Unique -> Unique), (Unique -> Unique -> _CMP_TAG)] [_DFUN_ Eq (Unique), _CONSTM_ Ord (<) (Unique), _CONSTM_ Ord (<=) (Unique), _CONSTM_ Ord (>=) (Unique), _CONSTM_ Ord (>) (Unique), _CONSTM_ Ord max (Unique), _CONSTM_ Ord min (Unique), _CONSTM_ Ord _tagCmp (Unique)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ ltInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ leInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ leInt# [] [u2, u3] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Class -> ExportFlag), (Class -> Bool), (Class -> (_PackedString, _PackedString)), (Class -> _PackedString), (Class -> [_PackedString]), (Class -> SrcLoc), (Class -> Unique), (Class -> Bool), (Class -> UniType), (Class -> Bool)] [_CONSTM_ NamedThing getExportFlag (Class), _CONSTM_ NamedThing isLocallyDefined (Class), _CONSTM_ NamedThing getOrigName (Class), _CONSTM_ NamedThing getOccurrenceName (Class), _CONSTM_ NamedThing getInformingModules (Class), _CONSTM_ NamedThing getSrcLoc (Class), _CONSTM_ NamedThing getTheUnique (Class), _CONSTM_ NamedThing hasType (Class), _CONSTM_ NamedThing getType (Class), _CONSTM_ NamedThing fromPreludeCore (Class)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(LLAAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [ub, uc]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(ALSAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAAAS)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ug; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Unique) } [ _NOREP_S_ "NamedThing.Class.getTheUnique", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Bool) } [ _NOREP_S_ "NamedThing.Class.hasType", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> UniType) } [ _NOREP_S_ "NamedThing.Class.getType", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance NamedThing FullName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(FullName -> ExportFlag), (FullName -> Bool), (FullName -> (_PackedString, _PackedString)), (FullName -> _PackedString), (FullName -> [_PackedString]), (FullName -> SrcLoc), (FullName -> Unique), (FullName -> Bool), (FullName -> UniType), (FullName -> Bool)] [_CONSTM_ NamedThing getExportFlag (FullName), _CONSTM_ NamedThing isLocallyDefined (FullName), _CONSTM_ NamedThing getOrigName (FullName), _CONSTM_ NamedThing getOccurrenceName (FullName), _CONSTM_ NamedThing getInformingModules (FullName), _CONSTM_ NamedThing getSrcLoc (FullName), _CONSTM_ NamedThing getTheUnique (FullName), _CONSTM_ NamedThing hasType (FullName), _CONSTM_ NamedThing getType (FullName), _CONSTM_ NamedThing fromPreludeCore (FullName)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AAAEAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u4; _NO_DEFLT_ } _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 11 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ThisModule -> _!_ True [] []; _ORIG_ NameTypes InventedInThisModule -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LLAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [u1, u2]; _NO_DEFLT_ } _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(ALSAAA)" {_A_ 2 _U_ 11 _N_ _N_ _F_ _IF_ARGS_ 0 2 XC 10 \ (u0 :: _PackedString) (u1 :: Provenance) -> case u1 of { _ALG_ _ORIG_ NameTypes OtherPrelude (u2 :: _PackedString) -> u2; _ORIG_ NameTypes OtherModule (u3 :: _PackedString) (u4 :: [_PackedString]) -> u3; (u5 :: Provenance) -> u0 } _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: FullName) -> case u0 of { _ALG_ _ORIG_ NameTypes FullName (u1 :: _PackedString) (u2 :: _PackedString) (u3 :: Provenance) (u4 :: ExportFlag) (u5 :: Bool) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: FullName) -> _APP_ _TYAPP_ patError# { (FullName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AASAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: Provenance) -> case u0 of { _ALG_ _ORIG_ NameTypes ExportedByPreludeCore -> _!_ True [] []; _ORIG_ NameTypes HereInPreludeCore -> _!_ True [] []; (u1 :: Provenance) -> _!_ False [] [] } _N_} _N_ _N_ #-}
instance NamedThing ShortName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(ShortName -> ExportFlag), (ShortName -> Bool), (ShortName -> (_PackedString, _PackedString)), (ShortName -> _PackedString), (ShortName -> [_PackedString]), (ShortName -> SrcLoc), (ShortName -> Unique), (ShortName -> Bool), (ShortName -> UniType), (ShortName -> Bool)] [_CONSTM_ NamedThing getExportFlag (ShortName), _CONSTM_ NamedThing isLocallyDefined (ShortName), _CONSTM_ NamedThing getOrigName (ShortName), _CONSTM_ NamedThing getOccurrenceName (ShortName), _CONSTM_ NamedThing getInformingModules (ShortName), _CONSTM_ NamedThing getSrcLoc (ShortName), _CONSTM_ NamedThing getTheUnique (ShortName), _CONSTM_ NamedThing hasType (ShortName), _CONSTM_ NamedThing getType (ShortName), _CONSTM_ NamedThing fromPreludeCore (ShortName)] _N_
- getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ _ORIG_ Outputable NotExported [] [] _N_,
- isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ShortName) -> _!_ True [] [] _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(LA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(SA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: _PackedString) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u1; _NO_DEFLT_ } _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u0 ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> u2; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: ShortName) -> _APP_ _TYAPP_ patError# { (ShortName -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AA)" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> _!_ False [] []; _NO_DEFLT_ } _N_ #-}
instance NamedThing TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyCon -> ExportFlag), (TyCon -> Bool), (TyCon -> (_PackedString, _PackedString)), (TyCon -> _PackedString), (TyCon -> [_PackedString]), (TyCon -> SrcLoc), (TyCon -> Unique), (TyCon -> Bool), (TyCon -> UniType), (TyCon -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyCon), _CONSTM_ NamedThing isLocallyDefined (TyCon), _CONSTM_ NamedThing getOrigName (TyCon), _CONSTM_ NamedThing getOccurrenceName (TyCon), _CONSTM_ NamedThing getInformingModules (TyCon), _CONSTM_ NamedThing getSrcLoc (TyCon), _CONSTM_ NamedThing getTheUnique (TyCon), _CONSTM_ NamedThing hasType (TyCon), _CONSTM_ NamedThing getType (TyCon), _CONSTM_ NamedThing fromPreludeCore (TyCon)] _N_
- getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getTheUnique = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Unique } [ _NOREP_S_ "NamedThing.TyCon.getTheUnique" ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> Bool) } [ _NOREP_S_ "NamedThing.TyCon.hasType", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> UniType) } [ _NOREP_S_ "NamedThing.TyCon.getType", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
instance NamedThing TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVar -> ExportFlag), (TyVar -> Bool), (TyVar -> (_PackedString, _PackedString)), (TyVar -> _PackedString), (TyVar -> [_PackedString]), (TyVar -> SrcLoc), (TyVar -> Unique), (TyVar -> Bool), (TyVar -> UniType), (TyVar -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVar), _CONSTM_ NamedThing isLocallyDefined (TyVar), _CONSTM_ NamedThing getOrigName (TyVar), _CONSTM_ NamedThing getOccurrenceName (TyVar), _CONSTM_ NamedThing getInformingModules (TyVar), _CONSTM_ NamedThing getSrcLoc (TyVar), _CONSTM_ NamedThing getTheUnique (TyVar), _CONSTM_ NamedThing hasType (TyVar), _CONSTM_ NamedThing getType (TyVar), _CONSTM_ NamedThing fromPreludeCore (TyVar)] _N_
- getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ _ORIG_ Outputable NotExported [] [] _N_,
- isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ True [] [] _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVar" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar UserTyVar (u1 :: Unique) (u2 :: ShortName) -> case u2 of { _ALG_ _ORIG_ NameTypes ShortName (u3 :: _PackedString) (u4 :: SrcLoc) -> u4; _NO_DEFLT_ }; (u5 :: TyVar) -> _ORIG_ SrcLoc mkUnknownSrcLoc } _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar PolySysTyVar (u1 :: Unique) -> u1; _ORIG_ TyVar PrimSysTyVar (u2 :: Unique) -> u2; _ORIG_ TyVar OpenSysTyVar (u3 :: Unique) -> u3; _ORIG_ TyVar UserTyVar (u4 :: Unique) (u5 :: ShortName) -> u4; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ False [] [] _N_ #-}
instance NamedThing TyVarTemplate
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVarTemplate -> ExportFlag), (TyVarTemplate -> Bool), (TyVarTemplate -> (_PackedString, _PackedString)), (TyVarTemplate -> _PackedString), (TyVarTemplate -> [_PackedString]), (TyVarTemplate -> SrcLoc), (TyVarTemplate -> Unique), (TyVarTemplate -> Bool), (TyVarTemplate -> UniType), (TyVarTemplate -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVarTemplate), _CONSTM_ NamedThing isLocallyDefined (TyVarTemplate), _CONSTM_ NamedThing getOrigName (TyVarTemplate), _CONSTM_ NamedThing getOccurrenceName (TyVarTemplate), _CONSTM_ NamedThing getInformingModules (TyVarTemplate), _CONSTM_ NamedThing getSrcLoc (TyVarTemplate), _CONSTM_ NamedThing getTheUnique (TyVarTemplate), _CONSTM_ NamedThing hasType (TyVarTemplate), _CONSTM_ NamedThing getType (TyVarTemplate), _CONSTM_ NamedThing fromPreludeCore (TyVarTemplate)] _N_
- getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ _ORIG_ Outputable NotExported [] [] _N_,
- isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ True [] [] _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVarTemplate" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> _ORIG_ SrcLoc mkUnknownSrcLoc; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> case u4 of { _ALG_ _ORIG_ NameTypes ShortName (u5 :: _PackedString) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> u1; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> u3; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ False [] [] _N_ #-}
instance Outputable Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Class) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(AU(LLLLAA)AAAAAAAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable ClassOp
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable FullName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (FullName) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LLLLAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable ShortName
- {-# GHC_PRAGMA _M_ NameTypes {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (ShortName) _N_
- ppr = _A_ 4 _U_ 0120 _N_ _S_ "AU(LA)LA" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyCon) _N_
- ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVar) _N_
- ppr = _A_ 2 _U_ 1122 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable TyVarTemplate
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVarTemplate) _N_
- ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable UniType
- {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ #-}
instance Text Unique
- {-# GHC_PRAGMA _M_ Unique {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Unique, [Char])]), (Int -> Unique -> [Char] -> [Char]), ([Char] -> [([Unique], [Char])]), ([Unique] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Unique), _CONSTM_ Text showsPrec (Unique), _CONSTM_ Text readList (Unique), _CONSTM_ Text showList (Unique)] _N_
- readsPrec = _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ _ORIG_ Util panic { ([Char] -> [(Unique, [Char])]) } [ _NOREP_S_ "no readsPrec for Unique", u1 ] _N_,
- showsPrec = _A_ 3 _U_ 010 _N_ _S_ "AU(P)A" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXX 5 \ (u0 :: Int) (u1 :: Unique) (u2 :: [Char]) -> let {(u3 :: _PackedString) = _APP_ _ORIG_ Unique showUnique [ u1 ]} in _APP_ _ORIG_ PreludePS _unpackPS [ u3 ] _N_,
- readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
- showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Class where
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
-import InstEnv(InstTemplate, InstTy)
+import Id(Id)
+import InstEnv(InstTemplate)
import Maybes(Labda)
import Name(Name)
-import NameTypes(FullName, Provenance, ShortName)
-import Outputable(ExportFlag, NamedThing, Outputable)
+import NameTypes(FullName, ShortName)
+import Outputable(NamedThing, Outputable)
import PreludePS(_PackedString)
-import SrcLoc(SrcLoc)
import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
+import TyVar(TyVarTemplate)
import UniType(UniType)
import Unique(Unique)
data Class = MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])]
data ClassOp = MkClassOp _PackedString Int UniType
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Id
+data InstTemplate
+data Labda a
+data Name
+data FullName
+data TyVarTemplate
+data UniType
+data Unique
cmpClass :: Class -> Class -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
derivableClassKeys :: [Unique]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
getClassBigSig :: Class -> (TyVarTemplate, [Class], [Id], [ClassOp], [Id], [Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AALLLLLLAA)" _N_ _N_ #-}
getClassInstEnv :: Class -> [(UniType, InstTemplate)]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAAAAASA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [(UniType, InstTemplate)]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> u9; _NO_DEFLT_ } _N_ #-}
getClassKey :: Class -> Unique
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(U(P)AAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ _ORIG_ Unique MkUnique [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> u1; _NO_DEFLT_ } _N_ #-}
getClassOpId :: Class -> ClassOp -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AAAAAASAAA)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: [Id]) (u1 :: Int#) -> case _#_ minusInt# [] [u1, 1#] of { _PRIM_ (u2 :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u0, u2 ] } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Class) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (uc :: _PackedString) (ud :: Int) (ue :: UniType) -> case ud of { _ALG_ I# (uf :: Int#) -> case _#_ minusInt# [] [uf, 1#] of { _PRIM_ (ug :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u8, ug ] }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getClassOpLocalType :: ClassOp -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAS)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u1 :: _PackedString) (u2 :: Int) (u3 :: UniType) -> u3; _NO_DEFLT_ } _N_ #-}
getClassOpString :: ClassOp -> _PackedString
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(SAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: _PackedString) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u1 :: _PackedString) (u2 :: Int) (u3 :: UniType) -> u1; _NO_DEFLT_ } _N_ #-}
getClassOpTag :: ClassOp -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AU(P)A)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u1 :: _PackedString) (u2 :: Int) (u3 :: UniType) -> u2; _NO_DEFLT_ } _N_ #-}
getClassOps :: Class -> [ClassOp]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAAAASAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: [ClassOp]) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> u6; _NO_DEFLT_ } _N_ #-}
getClassSig :: Class -> (TyVarTemplate, [Class], [ClassOp])
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AALLALAAAA)" {_A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: TyVarTemplate) (u1 :: [Class]) (u2 :: [ClassOp]) -> _!_ _TUP_3 [TyVarTemplate, [Class], [ClassOp]] [u0, u1, u2] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> _!_ _TUP_3 [TyVarTemplate, [Class], [ClassOp]] [u3, u4, u6]; _NO_DEFLT_ } _N_ #-}
getConstMethodId :: Class -> ClassOp -> UniType -> Id
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(AAAAALSAAA)U(LU(P)L)L" {_A_ 4 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getDefaultMethodId :: Class -> ClassOp -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AAAAAAASAA)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: [Id]) (u1 :: Int#) -> case _#_ minusInt# [] [u1, 1#] of { _PRIM_ (u2 :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u0, u2 ] } _N_} _F_ _IF_ARGS_ 0 2 CC 7 \ (u0 :: Class) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (uc :: _PackedString) (ud :: Int) (ue :: UniType) -> case ud of { _ALG_ I# (uf :: Int#) -> case _#_ minusInt# [] [uf, 1#] of { _PRIM_ (ug :: Int#) -> _APP_ _TYAPP_ _WRKR_ _SPEC_ _ORIG_ PreludeList (!!) [ (Int), _N_ ] { Id } [ u9, ug ] }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
getSuperDictSelId :: Class -> Class -> Id
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAASLAAAAA)L" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isNumericClass :: Class -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isStandardClass :: Class -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(LAAAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isSuperClassOf :: Class -> Class -> Labda [Class]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(AAAAAAAAAS)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Class) (u1 :: [(Class, [Class])]) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ Maybes assocMaybe [ (Class), _N_ ] { [Class] } [ u1, u0 ] _N_} _F_ _IF_ARGS_ 0 2 XC 4 \ (u0 :: Class) (u1 :: Class) -> case u1 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ Maybes assocMaybe [ (Class), _N_ ] { [Class] } [ ub, u0 ]; _NO_DEFLT_ } _N_ #-}
mkClass :: Name -> TyVarTemplate -> [Class] -> [Id] -> [ClassOp] -> [Id] -> [Id] -> [(UniType, InstTemplate)] -> Class
- {-# GHC_PRAGMA _A_ 8 _U_ 12222222 _N_ _N_ _N_ _N_ #-}
mkClassOp :: _PackedString -> Int -> UniType -> ClassOp
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _N_ _F_ _IF_ARGS_ 0 3 XXX 4 \ (u0 :: _PackedString) (u1 :: Int) (u2 :: UniType) -> _!_ _ORIG_ Class MkClassOp [] [u0, u1, u2] _N_ #-}
instance Eq Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(Class -> Class -> Bool), (Class -> Class -> Bool)] [_CONSTM_ Eq (==) (Class), _CONSTM_ Eq (/=) (Class)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ eqInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ eqInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Eq (/=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Eq ClassOp
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool)] [_CONSTM_ Eq (==) (ClassOp), _CONSTM_ Eq (/=) (ClassOp)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ eqInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ eqInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
instance Ord Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq Class}}, (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Bool), (Class -> Class -> Class), (Class -> Class -> Class), (Class -> Class -> _CMP_TAG)] [_DFUN_ Eq (Class), _CONSTM_ Ord (<) (Class), _CONSTM_ Ord (<=) (Class), _CONSTM_ Ord (>=) (Class), _CONSTM_ Ord (>) (Class), _CONSTM_ Ord max (Class), _CONSTM_ Ord min (Class), _CONSTM_ Ord _tagCmp (Class)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ ltInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ Unique MkUnique (um :: Int#) -> case uc of { _ALG_ _ORIG_ Unique MkUnique (un :: Int#) -> _#_ leInt# [] [um, un]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ ltInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>=) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _#_ leInt# [] [u0, u1] of { _ALG_ True -> _!_ False [] []; False -> _!_ True [] []; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: Class) (u1 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u2 :: Unique) (u3 :: FullName) (u4 :: TyVarTemplate) (u5 :: [Class]) (u6 :: [Id]) (u7 :: [ClassOp]) (u8 :: [Id]) (u9 :: [Id]) (ua :: [(UniType, InstTemplate)]) (ub :: [(Class, [Class])]) -> case u1 of { _ALG_ _ORIG_ Class MkClass (uc :: Unique) (ud :: FullName) (ue :: TyVarTemplate) (uf :: [Class]) (ug :: [Id]) (uh :: [ClassOp]) (ui :: [Id]) (uj :: [Id]) (uk :: [(UniType, InstTemplate)]) (ul :: [(Class, [Class])]) -> _APP_ _CONSTM_ Ord (>) (Unique) [ u2, uc ]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAAAAAAAA)U(U(P)AAAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Ord ClassOp
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq ClassOp}}, (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> Bool), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> ClassOp), (ClassOp -> ClassOp -> _CMP_TAG)] [_DFUN_ Eq (ClassOp), _CONSTM_ Ord (<) (ClassOp), _CONSTM_ Ord (<=) (ClassOp), _CONSTM_ Ord (>=) (ClassOp), _CONSTM_ Ord (>) (ClassOp), _CONSTM_ Ord max (ClassOp), _CONSTM_ Ord min (ClassOp), _CONSTM_ Ord _tagCmp (ClassOp)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ ltInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ ltInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ leInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ leInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ geInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ geInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "U(AU(P)A)U(AU(P)A)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int#) (u1 :: Int#) -> _#_ gtInt# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: ClassOp) (u1 :: ClassOp) -> case u0 of { _ALG_ _ORIG_ Class MkClassOp (u2 :: _PackedString) (u3 :: Int) (u4 :: UniType) -> case u1 of { _ALG_ _ORIG_ Class MkClassOp (u5 :: _PackedString) (u6 :: Int) (u7 :: UniType) -> case u3 of { _ALG_ I# (u8 :: Int#) -> case u6 of { _ALG_ I# (u9 :: Int#) -> _#_ gtInt# [] [u8, u9]; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance NamedThing Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(Class -> ExportFlag), (Class -> Bool), (Class -> (_PackedString, _PackedString)), (Class -> _PackedString), (Class -> [_PackedString]), (Class -> SrcLoc), (Class -> Unique), (Class -> Bool), (Class -> UniType), (Class -> Bool)] [_CONSTM_ NamedThing getExportFlag (Class), _CONSTM_ NamedThing isLocallyDefined (Class), _CONSTM_ NamedThing getOrigName (Class), _CONSTM_ NamedThing getOccurrenceName (Class), _CONSTM_ NamedThing getInformingModules (Class), _CONSTM_ NamedThing getSrcLoc (Class), _CONSTM_ NamedThing getTheUnique (Class), _CONSTM_ NamedThing hasType (Class), _CONSTM_ NamedThing getType (Class), _CONSTM_ NamedThing fromPreludeCore (Class)] _N_
- getExportFlag = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: ExportFlag) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- isLocallyDefined = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(LLAAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: _PackedString) (u1 :: _PackedString) -> _!_ _TUP_2 [_PackedString, _PackedString] [u0, u1] _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> _!_ _TUP_2 [_PackedString, _PackedString] [ub, uc]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "U(AU(ALSAAA)AAAAAAAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- getInformingModules = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAAAS)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: SrcLoc) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 3 \ (u0 :: Class) -> case u0 of { _ALG_ _ORIG_ Class MkClass (u1 :: Unique) (u2 :: FullName) (u3 :: TyVarTemplate) (u4 :: [Class]) (u5 :: [Id]) (u6 :: [ClassOp]) (u7 :: [Id]) (u8 :: [Id]) (u9 :: [(UniType, InstTemplate)]) (ua :: [(Class, [Class])]) -> case u2 of { _ALG_ _ORIG_ NameTypes FullName (ub :: _PackedString) (uc :: _PackedString) (ud :: Provenance) (ue :: ExportFlag) (uf :: Bool) (ug :: SrcLoc) -> ug; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Unique) } [ _NOREP_S_ "NamedThing.Class.getTheUnique", u0 ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> Bool) } [ _NOREP_S_ "NamedThing.Class.hasType", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Class) -> _APP_ _TYAPP_ _ORIG_ Util panic { (Class -> UniType) } [ _NOREP_S_ "NamedThing.Class.getType", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 1 _N_ _S_ "U(AU(AASAAA)AAAAAAAA)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable Class
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Class) _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(AU(LLLLAA)AAAAAAAA)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable ClassOp
- {-# GHC_PRAGMA _M_ Class {-dfun-} _A_ 2 _N_ _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_
- ppr = _A_ 2 _U_ 2122 _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface TyCon where
import Class(Class, ClassOp)
-import Id(DataCon(..), Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(DataCon(..), Id)
import InstEnv(InstTemplate)
import Maybes(Labda)
-import NameTypes(FullName, Provenance, ShortName)
-import Outputable(ExportFlag, NamedThing, Outputable)
-import PreludePS(_PackedString)
+import NameTypes(FullName)
+import Outputable(NamedThing, Outputable)
import PrimKind(PrimKind)
-import SrcLoc(SrcLoc)
import TyVar(TyVar, TyVarTemplate)
import UniType(UniType)
import Unique(Unique)
type Arity = Int
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
+data Class
type DataCon = Id
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
+data Id
+data Labda a
+data FullName
+data PrimKind
data TyCon = SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType]
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data TyVarTemplate
+data UniType
+data Unique
cmpTyCon :: TyCon -> TyCon -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
derivedFor :: Class -> TyCon -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _F_ _IF_ARGS_ 0 2 XC 9 \ (u0 :: Class) (u1 :: TyCon) -> case u1 of { _ALG_ _ORIG_ TyCon DataTyCon (u2 :: Unique) (u3 :: FullName) (u4 :: Int) (u5 :: [TyVarTemplate]) (u6 :: [Id]) (u7 :: [Class]) (u8 :: Bool) -> _APP_ _WRKR_ _SPEC_ _ORIG_ Util isIn [ (Class) ] [ u0, u7 ]; (u9 :: TyCon) -> _!_ False [] [] } _N_ #-}
eqTyCon :: TyCon -> TyCon -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-}
getTyConArity :: TyCon -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getTyConDataCons :: TyCon -> [Id]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getTyConDerivings :: TyCon -> [Class]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: TyCon) -> case u0 of { _ALG_ _ORIG_ TyCon DataTyCon (u1 :: Unique) (u2 :: FullName) (u3 :: Int) (u4 :: [TyVarTemplate]) (u5 :: [Id]) (u6 :: [Class]) (u7 :: Bool) -> u6; _ORIG_ TyCon SpecTyCon (u8 :: TyCon) (u9 :: [Labda UniType]) -> _APP_ _TYAPP_ _ORIG_ Util panic { [Class] } [ _NOREP_S_ "getTyConDerivings:SpecTyCon" ]; (ua :: TyCon) -> _!_ _NIL_ [Class] [] } _N_ #-}
getTyConFamilySize :: TyCon -> Labda Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getTyConKind :: TyCon -> [PrimKind] -> PrimKind
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 8 \ (u0 :: TyCon) (u1 :: [PrimKind]) -> case u0 of { _ALG_ _ORIG_ TyCon PrimTyCon (u2 :: Unique) (u3 :: FullName) (u4 :: Int) (u5 :: [PrimKind] -> PrimKind) -> _APP_ u5 [ u1 ]; (u6 :: TyCon) -> _!_ _ORIG_ PrimKind PtrKind [] [] } _N_ #-}
getTyConTyVarTemplates :: TyCon -> [TyVarTemplate]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isBigTupleTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isBoxedTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isDataTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isEnumerationTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isLocalGenTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
isLocalSpecTyCon :: Bool -> TyCon -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "LS" _N_ _N_ #-}
isPrimTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isSynTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: TyCon) -> case u0 of { _ALG_ _ORIG_ TyCon SynonymTyCon (u1 :: Unique) (u2 :: FullName) (u3 :: Int) (u4 :: [TyVarTemplate]) (u5 :: UniType) (u6 :: Bool) -> _!_ True [] []; _ORIG_ TyCon SpecTyCon (u7 :: TyCon) (u8 :: [Labda UniType]) -> _APP_ _TYAPP_ _ORIG_ Util panic { Bool } [ _NOREP_S_ "isSynTyCon: SpecTyCon" ]; (u9 :: TyCon) -> _!_ False [] [] } _N_ #-}
isTupleTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isVisibleSynTyCon :: TyCon -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyCon) -> case u0 of { _ALG_ _ORIG_ TyCon SynonymTyCon (u1 :: Unique) (u2 :: FullName) (u3 :: Int) (u4 :: [TyVarTemplate]) (u5 :: UniType) (u6 :: Bool) -> u6; (u7 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Bool } [ _NOREP_S_ "isVisibleSynTyCon" ] } _N_ #-}
maybeCharLikeTyCon :: TyCon -> Labda Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
maybeDoubleLikeTyCon :: TyCon -> Labda Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
maybeFloatLikeTyCon :: TyCon -> Labda Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
maybeIntLikeTyCon :: TyCon -> Labda Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
maybeSingleConstructorTyCon :: TyCon -> Labda Id
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkDataTyCon :: Unique -> FullName -> Int -> [TyVarTemplate] -> [Id] -> [Class] -> Bool -> TyCon
- {-# GHC_PRAGMA _A_ 7 _U_ 2222222 _N_ _N_ _F_ _IF_ARGS_ 0 7 XXXXXXX 8 \ (u0 :: Unique) (u1 :: FullName) (u2 :: Int) (u3 :: [TyVarTemplate]) (u4 :: [Id]) (u5 :: [Class]) (u6 :: Bool) -> _!_ _ORIG_ TyCon DataTyCon [] [u0, u1, u2, u3, u4, u5, u6] _N_ #-}
mkPrimTyCon :: Unique -> FullName -> Int -> ([PrimKind] -> PrimKind) -> TyCon
- {-# GHC_PRAGMA _A_ 4 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 4 XXXX 5 \ (u0 :: Unique) (u1 :: FullName) (u2 :: Int) (u3 :: [PrimKind] -> PrimKind) -> _!_ _ORIG_ TyCon PrimTyCon [] [u0, u1, u2, u3] _N_ #-}
mkSpecTyCon :: TyCon -> [Labda UniType] -> TyCon
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: TyCon) (u1 :: [Labda UniType]) -> _!_ _ORIG_ TyCon SpecTyCon [] [u0, u1] _N_ #-}
mkSynonymTyCon :: Unique -> FullName -> Int -> [TyVarTemplate] -> UniType -> Bool -> TyCon
- {-# GHC_PRAGMA _A_ 6 _U_ 222222 _N_ _N_ _F_ _IF_ARGS_ 0 6 XXXXXX 7 \ (u0 :: Unique) (u1 :: FullName) (u2 :: Int) (u3 :: [TyVarTemplate]) (u4 :: UniType) (u5 :: Bool) -> _!_ _ORIG_ TyCon SynonymTyCon [] [u0, u1, u2, u3, u4, u5] _N_ #-}
mkTupleTyCon :: Int -> TyCon
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ TyCon TupleTyCon [] [u0] _N_ #-}
instance Eq TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool)] [_CONSTM_ Eq (==) (TyCon), _CONSTM_ Eq (/=) (TyCon)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyCon) (u1 :: TyCon) -> case _APP_ _ORIG_ TyCon cmpTyCon [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Ord TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyCon}}, (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> Bool), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> TyCon), (TyCon -> TyCon -> _CMP_TAG)] [_DFUN_ Eq (TyCon), _CONSTM_ Ord (<) (TyCon), _CONSTM_ Ord (<=) (TyCon), _CONSTM_ Ord (>=) (TyCon), _CONSTM_ Ord (>) (TyCon), _CONSTM_ Ord max (TyCon), _CONSTM_ Ord min (TyCon), _CONSTM_ Ord _tagCmp (TyCon)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance NamedThing TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyCon -> ExportFlag), (TyCon -> Bool), (TyCon -> (_PackedString, _PackedString)), (TyCon -> _PackedString), (TyCon -> [_PackedString]), (TyCon -> SrcLoc), (TyCon -> Unique), (TyCon -> Bool), (TyCon -> UniType), (TyCon -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyCon), _CONSTM_ NamedThing isLocallyDefined (TyCon), _CONSTM_ NamedThing getOrigName (TyCon), _CONSTM_ NamedThing getOccurrenceName (TyCon), _CONSTM_ NamedThing getInformingModules (TyCon), _CONSTM_ NamedThing getSrcLoc (TyCon), _CONSTM_ NamedThing getTheUnique (TyCon), _CONSTM_ NamedThing hasType (TyCon), _CONSTM_ NamedThing getType (TyCon), _CONSTM_ NamedThing fromPreludeCore (TyCon)] _N_
- getExportFlag = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- isLocallyDefined = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getSrcLoc = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getTheUnique = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { Unique } [ _NOREP_S_ "NamedThing.TyCon.getTheUnique" ] _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> Bool) } [ _NOREP_S_ "NamedThing.TyCon.hasType", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyCon) -> _APP_ _TYAPP_ _ORIG_ Util panic { (TyCon -> UniType) } [ _NOREP_S_ "NamedThing.TyCon.getType", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
instance Outputable TyCon
- {-# GHC_PRAGMA _M_ TyCon {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyCon) _N_
- ppr = _A_ 2 _U_ 2222 _N_ _S_ "SS" _N_ _N_ #-}
maybeSingleConstructorTyCon (DataTyCon _ _ _ _ [c] _ _) = Just c
maybeSingleConstructorTyCon (DataTyCon _ _ _ _ _ _ _) = Nothing
maybeSingleConstructorTyCon (PrimTyCon _ _ _ _) = Nothing
-maybeSingleConstructorTyCon (SpecTyCon tc tys) = panic "maybeSingleConstructorTyCon:SpecTyCon"
+maybeSingleConstructorTyCon tycon@(SpecTyCon tc tys) = pprPanic "maybeSingleConstructorTyCon:SpecTyCon:" (ppr PprDebug tycon)
-- requires DataCons of TyCon
\end{code}
import NameTypes(ShortName)
import Outputable(NamedThing, Outputable)
import PreludePS(_PackedString)
-import SrcLoc(SrcLoc)
import UniType(UniType)
import Unique(Unique)
-data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-}
+data ShortName
data TyVar = PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
+data TyVarTemplate
alphaTyVars :: [TyVarTemplate]
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
alpha_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
alpha_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
beta_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
beta_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
cloneTyVar :: TyVar -> Unique -> TyVar
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
cloneTyVarFromTemplate :: TyVarTemplate -> Unique -> TyVar
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 7 \ (u0 :: TyVarTemplate) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u2 :: Unique) (u3 :: _PackedString) -> _!_ _ORIG_ TyVar PolySysTyVar [] [u1]; _ORIG_ TyVar UserTyVarTemplate (u4 :: Unique) (u5 :: ShortName) -> _!_ _ORIG_ TyVar UserTyVar [] [u1, u5]; _NO_DEFLT_ } _N_ #-}
cmpTyVar :: TyVar -> TyVar -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
delta_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
delta_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
epsilon_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
epsilon_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
eqTyVar :: TyVar -> TyVar -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-}
gamma_tv :: TyVarTemplate
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
gamma_tyvar :: TyVar
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
instantiateTyVarTemplates :: [TyVarTemplate] -> [Unique] -> ([(TyVarTemplate, UniType)], [TyVar], [UniType])
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _N_ _N_ _N_ #-}
ltTyVar :: TyVar -> TyVar -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
mkOpenSysTyVar :: Unique -> TyVar
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Unique) -> _!_ _ORIG_ TyVar OpenSysTyVar [] [u0] _N_ #-}
mkPolySysTyVar :: Unique -> TyVar
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Unique) -> _!_ _ORIG_ TyVar PolySysTyVar [] [u0] _N_ #-}
mkSysTyVarTemplate :: Unique -> _PackedString -> TyVarTemplate
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: _PackedString) -> _!_ _ORIG_ TyVar SysTyVarTemplate [] [u0, u1] _N_ #-}
mkTemplateTyVars :: [TyVar] -> [TyVarTemplate]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mkUserTyVar :: Unique -> ShortName -> TyVar
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: ShortName) -> _!_ _ORIG_ TyVar UserTyVar [] [u0, u1] _N_ #-}
mkUserTyVarTemplate :: Unique -> ShortName -> TyVarTemplate
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Unique) (u1 :: ShortName) -> _!_ _ORIG_ TyVar UserTyVarTemplate [] [u0, u1] _N_ #-}
instance Eq TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool)] [_CONSTM_ Eq (==) (TyVar), _CONSTM_ Eq (/=) (TyVar)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: TyVar) (u1 :: TyVar) -> case _APP_ _ORIG_ TyVar cmpTyVar [ u0, u1 ] of { _PRIM_ 0# -> _!_ False [] []; (u2 :: Int#) -> _!_ True [] [] } _N_ #-}
instance Eq TyVarTemplate
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool)] [_CONSTM_ Eq (==) (TyVarTemplate), _CONSTM_ Eq (/=) (TyVarTemplate)] _N_
- (==) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVar}}, (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> Bool), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> TyVar), (TyVar -> TyVar -> _CMP_TAG)] [_DFUN_ Eq (TyVar), _CONSTM_ Ord (<) (TyVar), _CONSTM_ Ord (<=) (TyVar), _CONSTM_ Ord (>=) (TyVar), _CONSTM_ Ord (>) (TyVar), _CONSTM_ Ord max (TyVar), _CONSTM_ Ord min (TyVar), _CONSTM_ Ord _tagCmp (TyVar)] _N_
- (<) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Ord TyVarTemplate
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 9 _!_ _TUP_8 [{{Eq TyVarTemplate}}, (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> Bool), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> TyVarTemplate), (TyVarTemplate -> TyVarTemplate -> _CMP_TAG)] [_DFUN_ Eq (TyVarTemplate), _CONSTM_ Ord (<) (TyVarTemplate), _CONSTM_ Ord (<=) (TyVarTemplate), _CONSTM_ Ord (>=) (TyVarTemplate), _CONSTM_ Ord (>) (TyVarTemplate), _CONSTM_ Ord max (TyVarTemplate), _CONSTM_ Ord min (TyVarTemplate), _CONSTM_ Ord _tagCmp (TyVarTemplate)] _N_
- (<) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (<=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>=) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- (>) = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_,
- max = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- min = _A_ 2 _U_ 22 _N_ _N_ _N_ _N_,
- _tagCmp = _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
instance NamedThing TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVar -> ExportFlag), (TyVar -> Bool), (TyVar -> (_PackedString, _PackedString)), (TyVar -> _PackedString), (TyVar -> [_PackedString]), (TyVar -> SrcLoc), (TyVar -> Unique), (TyVar -> Bool), (TyVar -> UniType), (TyVar -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVar), _CONSTM_ NamedThing isLocallyDefined (TyVar), _CONSTM_ NamedThing getOrigName (TyVar), _CONSTM_ NamedThing getOccurrenceName (TyVar), _CONSTM_ NamedThing getInformingModules (TyVar), _CONSTM_ NamedThing getSrcLoc (TyVar), _CONSTM_ NamedThing getTheUnique (TyVar), _CONSTM_ NamedThing hasType (TyVar), _CONSTM_ NamedThing getType (TyVar), _CONSTM_ NamedThing fromPreludeCore (TyVar)] _N_
- getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ _ORIG_ Outputable NotExported [] [] _N_,
- isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ True [] [] _N_,
- getOrigName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVar" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 7 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar UserTyVar (u1 :: Unique) (u2 :: ShortName) -> case u2 of { _ALG_ _ORIG_ NameTypes ShortName (u3 :: _PackedString) (u4 :: SrcLoc) -> u4; _NO_DEFLT_ }; (u5 :: TyVar) -> _ORIG_ SrcLoc mkUnknownSrcLoc } _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 8 \ (u0 :: TyVar) -> case u0 of { _ALG_ _ORIG_ TyVar PolySysTyVar (u1 :: Unique) -> u1; _ORIG_ TyVar PrimSysTyVar (u2 :: Unique) -> u2; _ORIG_ TyVar OpenSysTyVar (u3 :: Unique) -> u3; _ORIG_ TyVar UserTyVar (u4 :: Unique) (u5 :: ShortName) -> u4; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ patError# { (TyVar -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVar) -> _!_ False [] [] _N_ #-}
instance NamedThing TyVarTemplate
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 11 _!_ _TUP_10 [(TyVarTemplate -> ExportFlag), (TyVarTemplate -> Bool), (TyVarTemplate -> (_PackedString, _PackedString)), (TyVarTemplate -> _PackedString), (TyVarTemplate -> [_PackedString]), (TyVarTemplate -> SrcLoc), (TyVarTemplate -> Unique), (TyVarTemplate -> Bool), (TyVarTemplate -> UniType), (TyVarTemplate -> Bool)] [_CONSTM_ NamedThing getExportFlag (TyVarTemplate), _CONSTM_ NamedThing isLocallyDefined (TyVarTemplate), _CONSTM_ NamedThing getOrigName (TyVarTemplate), _CONSTM_ NamedThing getOccurrenceName (TyVarTemplate), _CONSTM_ NamedThing getInformingModules (TyVarTemplate), _CONSTM_ NamedThing getSrcLoc (TyVarTemplate), _CONSTM_ NamedThing getTheUnique (TyVarTemplate), _CONSTM_ NamedThing hasType (TyVarTemplate), _CONSTM_ NamedThing getType (TyVarTemplate), _CONSTM_ NamedThing fromPreludeCore (TyVarTemplate)] _N_
- getExportFlag = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ Outputable NotExported [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ _ORIG_ Outputable NotExported [] [] _N_,
- isLocallyDefined = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ True [] [] _N_,
- getOrigName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
- getOccurrenceName = _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_,
- getInformingModules = _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ _ORIG_ Util panic { [_PackedString] } [ _NOREP_S_ "getInformingModule:TyVarTemplate" ] _N_,
- getSrcLoc = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> _ORIG_ SrcLoc mkUnknownSrcLoc; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> case u4 of { _ALG_ _ORIG_ NameTypes ShortName (u5 :: _PackedString) (u6 :: SrcLoc) -> u6; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
- getTheUnique = _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 4 \ (u0 :: TyVarTemplate) -> case u0 of { _ALG_ _ORIG_ TyVar SysTyVarTemplate (u1 :: Unique) (u2 :: _PackedString) -> u1; _ORIG_ TyVar UserTyVarTemplate (u3 :: Unique) (u4 :: ShortName) -> u3; _NO_DEFLT_ } _N_,
- hasType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u0 ] _N_,
- getType = _A_ 1 _U_ 2 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVarTemplate) -> _APP_ _TYAPP_ patError# { (TyVarTemplate -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u0 ] _N_,
- fromPreludeCore = _A_ 1 _U_ 0 _N_ _S_ "A" {_A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ False [] [] _N_} _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: TyVarTemplate) -> _!_ False [] [] _N_ #-}
instance Outputable TyVar
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVar) _N_
- ppr = _A_ 2 _U_ 1122 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable TyVarTemplate
- {-# GHC_PRAGMA _M_ TyVar {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (TyVarTemplate) _N_
- ppr = _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface UniTyFuns where
import Bag(Bag)
-import BasicLit(BasicLit)
-import BinderInfo(BinderInfo)
import CharSeq(CSeq)
import Class(Class, ClassOp)
import CmdLineOpts(GlobalSwitch)
-import CoreSyn(CoreAtom, CoreExpr)
import Id(Id)
import IdEnv(IdEnv(..))
import InstEnv(InstTemplate)
-import MagicUFs(MagicUnfoldingFun)
import Maybes(Labda)
import NameTypes(FullName, ShortName)
import PreludePS(_PackedString)
import Pretty(Delay, PprStyle, PrettyRep)
import PrimKind(PrimKind)
-import SimplEnv(FormSummary, UnfoldingDetails, UnfoldingGuidance)
-import SplitUniq(SplitUniqSupply)
+import SimplEnv(UnfoldingDetails)
import TyCon(TyCon)
import TyVar(TyVar, TyVarTemplate)
import TyVarEnv(TyVarEnv(..), TypeEnv(..))
import UniType(UniType)
import UniqFM(UniqFM)
import Unique(Unique, UniqueSupply)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
+data Bag a
+data Class
type IdEnv a = UniqFM a
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data UnfoldingDetails {-# GHC_PRAGMA NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
+data Labda a
+data PprStyle
+data PrettyRep
+data PrimKind
+data UnfoldingDetails
+data TyCon
+data TyVar
+data TyVarTemplate
type TyVarEnv a = UniqFM a
type TypeEnv = UniqFM UniType
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-}
+data UniType
+data UniqFM a
+data UniqueSupply
applyNonSynTyCon :: TyCon -> [UniType] -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: TyCon) (u1 :: [UniType]) -> _!_ _ORIG_ UniType UniData [] [u0, u1] _N_ #-}
applySynTyCon :: TyCon -> [UniType] -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
applyTy :: UniType -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
applyTyCon :: TyCon -> [UniType] -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
applyTypeEnvToThetaTy :: UniqFM UniType -> [(a, UniType)] -> [(a, UniType)]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
applyTypeEnvToTy :: UniqFM UniType -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
cmpUniTypeMaybeList :: [Labda UniType] -> [Labda UniType] -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _N_ _N_ #-}
expandVisibleTySyn :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
extractTyVarTemplatesFromTy :: UniType -> [TyVarTemplate]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
extractTyVarsFromTy :: UniType -> [TyVar]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
extractTyVarsFromTys :: [UniType] -> [TyVar]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
funResultTy :: UniType -> Int -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getMentionedTyCons :: TyCon -> [TyCon]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getMentionedTyConsAndClassesFromClass :: Class -> (Bag TyCon, Bag Class)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "U(LLLLLSLLLL)" _N_ _N_ #-}
getMentionedTyConsAndClassesFromTyCon :: TyCon -> (Bag TyCon, Bag Class)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getMentionedTyConsAndClassesFromUniType :: UniType -> (Bag TyCon, Bag Class)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getTauType :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 4 \ (u0 :: UniType) -> case _APP_ _ORIG_ UniTyFuns splitType [ u0 ] of { _ALG_ _TUP_3 (u1 :: [TyVarTemplate]) (u2 :: [(Class, UniType)]) (u3 :: UniType) -> u3; _NO_DEFLT_ } _N_ #-}
getTyVar :: [Char] -> UniType -> TyVar
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
getTyVarMaybe :: UniType -> Labda TyVar
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getTyVarTemplateMaybe :: UniType -> Labda TyVarTemplate
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
getTypeString :: UniType -> [_PackedString]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getUniDataSpecTyCon :: UniType -> (TyCon, [UniType], [Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getUniDataSpecTyCon_maybe :: UniType -> Labda (TyCon, [UniType], [Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getUniDataTyCon :: UniType -> (TyCon, [UniType], [Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getUniDataTyCon_maybe :: UniType -> Labda (TyCon, [UniType], [Id])
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
getUniTyDescription :: UniType -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
glueTyArgs :: [UniType] -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
instanceIsExported :: Class -> UniType -> Bool -> Bool
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AU(AASLAA)AAAAAAAA)SL" {_A_ 4 _U_ 2121 _N_ _N_ _N_ _N_} _N_ _N_ #-}
isDictTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isForAllTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isFunType :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
isGroundOrTyVarTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
isGroundTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isLeakFreeType :: [TyCon] -> UniType -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
isPrimType :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isTauTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isTyVarTemplateTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isTyVarTy :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isUnboxedDataType :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
kindFromType :: UniType -> PrimKind
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mapOverTyVars :: (TyVar -> UniType) -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
matchTy :: UniType -> UniType -> Labda [(TyVarTemplate, UniType)]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
maybeBoxedPrimType :: UniType -> Labda (Id, UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
maybePurelyLocalClass :: Class -> Labda [Int -> Bool -> PrettyRep]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "U(LLLLLSLLLL)" _N_ _N_ #-}
maybePurelyLocalTyCon :: TyCon -> Labda [Int -> Bool -> PrettyRep]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
maybePurelyLocalType :: UniType -> Labda [Int -> Bool -> PrettyRep]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
maybeUnpackFunTy :: UniType -> Labda (UniType, UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
mkSuperDictSelType :: Class -> Class -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "U(LLLLLLLLLL)L" _N_ _N_ #-}
pprClassOp :: PprStyle -> ClassOp -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "SU(LAL)" {_A_ 3 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
pprIfaceClass :: (GlobalSwitch -> Bool) -> (Id -> Id) -> UniqFM UnfoldingDetails -> Class -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 222122 _N_ _S_ "LLLU(ALLLLLLLAA)" _N_ _N_ #-}
pprMaybeTy :: PprStyle -> Labda UniType -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "SS" _N_ _N_ #-}
pprParendUniType :: PprStyle -> UniType -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-}
pprTyCon :: PprStyle -> TyCon -> [[Labda UniType]] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "SSL" _N_ _N_ #-}
pprUniType :: PprStyle -> UniType -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-}
returnsRealWorld :: UniType -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
showTyCon :: PprStyle -> TyCon -> [Char]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
showTypeCategory :: UniType -> Char
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
specMaybeTysSuffix :: [Labda UniType] -> _PackedString
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
specialiseTy :: UniType -> [Labda UniType] -> Int -> UniType
- {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "SLL" _N_ _N_ #-}
splitDictType :: UniType -> (Class, UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
splitForalls :: UniType -> ([TyVarTemplate], UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
splitTyArgs :: UniType -> ([UniType], UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
splitType :: UniType -> ([TyVarTemplate], [(Class, UniType)], UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
splitTypeWithDictsAsArgs :: UniType -> ([TyVarTemplate], [UniType], UniType)
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
typeMaybeString :: Labda UniType -> [_PackedString]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
unDictifyTy :: UniType -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface UniType where
-import Class(Class, ClassOp)
-import Id(Id)
-import InstEnv(InstTemplate)
+import Class(Class)
import Maybes(Labda)
-import NameTypes(FullName, ShortName)
+import NameTypes(ShortName)
import Outputable(Outputable)
-import PreludePS(_PackedString)
-import PrimKind(PrimKind)
import TyCon(TyCon)
import TyVar(TyVar, TyVarTemplate)
import Unique(Unique)
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
+data Class
type InstTyEnv = [(TyVarTemplate, UniType)]
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
+data Labda a
type RhoType = UniType
type SigmaType = UniType
type TauType = UniType
type ThetaType = [(Class, UniType)]
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
+data TyCon
+data TyVar
+data TyVarTemplate
data UniType = UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType
alpha :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar alpha_tv] _N_ #-}
alpha_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar alpha_tyvar] _N_ #-}
beta :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar beta_tv] _N_ #-}
beta_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar beta_tyvar] _N_ #-}
cmpUniType :: Bool -> UniType -> UniType -> Int#
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
delta :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar delta_tv] _N_ #-}
delta_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar delta_tyvar] _N_ #-}
epsilon :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar epsilon_tv] _N_ #-}
epsilon_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar epsilon_tyvar] _N_ #-}
gamma :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVarTemplate [] [_ORIG_ TyVar gamma_tv] _N_ #-}
gamma_ty :: UniType
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _!_ _ORIG_ UniType UniTyVar [] [_ORIG_ TyVar gamma_tyvar] _N_ #-}
instantiateTauTy :: [(TyVarTemplate, UniType)] -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniType instantiateTy _N_ #-}
instantiateThetaTy :: [(TyVarTemplate, UniType)] -> [(Class, UniType)] -> [(Class, UniType)]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
instantiateTy :: [(TyVarTemplate, UniType)] -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ #-}
mkDictTy :: Class -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Class) (u1 :: UniType) -> _!_ _ORIG_ UniType UniDict [] [u0, u1] _N_ #-}
mkForallTy :: [TyVarTemplate] -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
mkRhoTy :: [(Class, UniType)] -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
mkSigmaTy :: [TyVarTemplate] -> [(Class, UniType)] -> UniType -> UniType
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SLL" _N_ _N_ #-}
mkTyVarTemplateTy :: TyVarTemplate -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVarTemplate) -> _!_ _ORIG_ UniType UniTyVarTemplate [] [u0] _N_ #-}
mkTyVarTy :: TyVar -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: TyVar) -> _!_ _ORIG_ UniType UniTyVar [] [u0] _N_ #-}
quantifyTy :: [TyVar] -> UniType -> ([TyVarTemplate], UniType)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
instance Eq UniType
- {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(UniType -> UniType -> Bool), (UniType -> UniType -> Bool)] [_CONSTM_ Eq (==) (UniType), _CONSTM_ Eq (/=) (UniType)] _N_
- (==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
- (/=) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Outputable UniType
- {-# GHC_PRAGMA _M_ UniType {-dfun-} _A_ 2 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_
- ppr = _A_ 2 _U_ 2222 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniTyFuns pprUniType _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Bag where
import Outputable(Outputable)
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
+data Bag a
bagToList :: Bag a -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
emptyBag :: Bag a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ Bag EmptyBag [u0] [] _N_ #-}
filterBag :: (a -> Bool) -> Bag a -> Bag a
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
isEmptyBag :: Bag a -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
listToBag :: [a] -> Bag a
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
partitionBag :: (a -> Bool) -> Bag a -> (Bag a, Bag a)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
snocBag :: Bag a -> a -> Bag a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
unionBags :: Bag a -> Bag a -> Bag a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 1 2 CC 13 _/\_ u0 -> \ (u1 :: Bag u0) (u2 :: Bag u0) -> case u1 of { _ALG_ _ORIG_ Bag EmptyBag -> u2; (u3 :: Bag u0) -> case u2 of { _ALG_ _ORIG_ Bag EmptyBag -> u3; (u4 :: Bag u0) -> _!_ _ORIG_ Bag TwoBags [u0] [u1, u2] } } _N_ #-}
unionManyBags :: [Bag a] -> Bag a
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 5 _/\_ u0 -> \ (u1 :: [Bag u0]) -> case u1 of { _ALG_ (:) (u2 :: Bag u0) (u3 :: [Bag u0]) -> _!_ _ORIG_ Bag ListOfBags [u0] [u1]; _NIL_ -> _!_ _ORIG_ Bag EmptyBag [u0] []; _NO_DEFLT_ } _N_ #-}
unitBag :: a -> Bag a
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: u0) -> _!_ _ORIG_ Bag UnitBag [u0] [u1] _N_ #-}
instance Outputable a => Outputable (Bag a)
- {-# GHC_PRAGMA _M_ Bag {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface BitSet where
-data BitSet {-# GHC_PRAGMA MkBS Word# #-}
+data BitSet
emptyBS :: BitSet
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 case _#_ int2Word# [] [0#] of { _PRIM_ (u0 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u0] } _N_ #-}
listBS :: BitSet -> [Int]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
minusBS :: BitSet -> BitSet -> BitSet
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Word#) (u1 :: Word#) -> case _#_ not# [] [u1] of { _PRIM_ (u2 :: Word#) -> case _#_ and# [] [u0, u2] of { _PRIM_ (u3 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u3] } } _N_} _F_ _IF_ARGS_ 0 2 CC 6 \ (u0 :: BitSet) (u1 :: BitSet) -> case u0 of { _ALG_ _ORIG_ BitSet MkBS (u2 :: Word#) -> case u1 of { _ALG_ _ORIG_ BitSet MkBS (u3 :: Word#) -> case _#_ not# [] [u3] of { _PRIM_ (u4 :: Word#) -> case _#_ and# [] [u2, u4] of { _PRIM_ (u5 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u5] } }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
mkBS :: [Int] -> BitSet
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
singletonBS :: Int -> BitSet
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 4 \ (u0 :: Int#) -> case _#_ int2Word# [] [1#] of { _PRIM_ (u1 :: Word#) -> case _#_ shiftL# [] [u1, u0] of { _PRIM_ (u2 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u2] } } _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Int) -> case u0 of { _ALG_ I# (u1 :: Int#) -> case _#_ int2Word# [] [1#] of { _PRIM_ (u2 :: Word#) -> case _#_ shiftL# [] [u2, u1] of { _PRIM_ (u3 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u3] } }; _NO_DEFLT_ } _N_ #-}
unionBS :: BitSet -> BitSet -> BitSet
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Word#) (u1 :: Word#) -> case _#_ or# [] [u0, u1] of { _PRIM_ (u2 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u2] } _N_} _F_ _IF_ARGS_ 0 2 CC 5 \ (u0 :: BitSet) (u1 :: BitSet) -> case u0 of { _ALG_ _ORIG_ BitSet MkBS (u2 :: Word#) -> case u1 of { _ALG_ _ORIG_ BitSet MkBS (u3 :: Word#) -> case _#_ or# [] [u2, u3] of { _PRIM_ (u4 :: Word#) -> _!_ _ORIG_ BitSet MkBS [] [u4] }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
interface CharSeq where
import PreludePS(_PackedString)
import Stdio(_FILE)
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
+data CSeq
cAppend :: CSeq -> CSeq -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: CSeq) (u1 :: CSeq) -> _!_ _ORIG_ CharSeq CAppend [] [u0, u1] _N_ #-}
cAppendFile :: _FILE -> CSeq -> _State _RealWorld -> ((), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(P)SL" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
cCh :: Char -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Char) -> _!_ _ORIG_ CharSeq CCh [] [u0] _N_ #-}
cIndent :: Int -> CSeq -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: Int) (u1 :: CSeq) -> _!_ _ORIG_ CharSeq CIndent [] [u0, u1] _N_ #-}
cInt :: Int -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ CharSeq CInt [] [u0] _N_ #-}
cNL :: CSeq
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CharSeq CNewline [] [] _N_ #-}
cNil :: CSeq
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CharSeq CNil [] [] _N_ #-}
cPStr :: _PackedString -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: _PackedString) -> _!_ _ORIG_ CharSeq CPStr [] [u0] _N_ #-}
cShow :: CSeq -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
cStr :: [Char] -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Char]) -> _!_ _ORIG_ CharSeq CStr [] [u0] _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Digraph where
import Maybes(MaybeErr)
-data MaybeErr a b {-# GHC_PRAGMA Succeeded a | Failed b #-}
+data MaybeErr a b
dfs :: (a -> a -> Bool) -> (a -> [a]) -> ([a], [a]) -> [a] -> ([a], [a])
- {-# GHC_PRAGMA _A_ 4 _U_ 2211 _N_ _S_ "LLU(LL)S" {_A_ 5 _U_ 22221 _N_ _N_ _N_ _N_} _N_ _N_ #-}
stronglyConnComp :: (a -> a -> Bool) -> [(a, a)] -> [a] -> [[a]]
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
topologicalSort :: (a -> a -> Bool) -> [(a, a)] -> [a] -> MaybeErr [a] [[a]]
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
interface FiniteMap where
import Maybes(Labda)
import Outputable(Outputable)
-data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
+data FiniteMap a b
type FiniteSet a = FiniteMap a ()
-data Labda a {-# GHC_PRAGMA Hamna | Ni a #-}
+data Labda a
addListToFM :: Ord a => FiniteMap a b -> [(a, b)] -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ }, [ (_PackedString, _PackedString), _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ } #-}
addListToFM_C :: Ord a => (b -> b -> b) -> FiniteMap a b -> [(a, b)] -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 4 _U_ 2211 _N_ _S_ "LLLS" _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ }, [ (_PackedString, _PackedString), _N_ ] 1 { _A_ 3 _U_ 211 _N_ _S_ "LLS" _N_ _N_ } #-}
addToFM :: Ord a => FiniteMap a b -> a -> b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 1122 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 3 _U_ 122 _N_ _S_ "SLL" _N_ _N_ } #-}
delListFromFM :: Ord a => FiniteMap a b -> [a] -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _N_ } #-}
elemFM :: Ord a => a -> FiniteMap a b -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _SPECIALISE_ [ _PackedString, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ } #-}
elementOf :: Ord a => a -> FiniteMap a () -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap elemFM { u0 } { () } _N_ #-}
eltsFM :: FiniteMap a b -> [b]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
emptyFM :: FiniteMap a b
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 2 0 X 1 _/\_ u0 u1 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, u1] [] _N_ #-}
emptySet :: FiniteMap a ()
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, ()] [] _N_ #-}
fmToList :: FiniteMap a b -> [(a, b)]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isEmptyFM :: FiniteMap a b -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isEmptySet :: FiniteMap a () -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap isEmptyFM { u0 } { () } _N_ #-}
keysFM :: FiniteMap b a -> [b]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
listToFM :: Ord a => [(a, b)] -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 21 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ (_PackedString, _PackedString), _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-}
lookupFM :: Ord a => FiniteMap a b -> a -> Labda b
- {-# GHC_PRAGMA _A_ 1 _U_ 112 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ (_PackedString, _PackedString), _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ } #-}
lookupWithDefaultFM :: Ord a => FiniteMap a b -> b -> a -> b
- {-# GHC_PRAGMA _A_ 1 _U_ 1112 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 112 _N_ _S_ "SLL" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 3 _U_ 112 _N_ _S_ "SLL" _N_ _N_ } #-}
minusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SL" _N_ _N_ } #-}
minusSet :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap minusFM { u0 } { () } _N_ #-}
mkSet :: Ord a => [a] -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 21 _N_ _N_ _N_ _N_ #-}
plusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SS" _N_ _N_ } #-}
plusFM_C :: Ord a => (b -> b -> b) -> FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 2221 _N_ _N_ _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 221 _N_ _S_ "LSS" _N_ _N_ }, [ CLabel, _N_ ] 1 { _A_ 3 _U_ 221 _N_ _S_ "LSS" _N_ _N_ } #-}
setToList :: FiniteMap a () -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_ #-}
singletonFM :: a -> b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
union :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap plusFM { u0 } { () } _N_ #-}
instance Outputable a => Outputable (FiniteMap a b)
- {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 3 _U_ 2 _N_ _S_ "LLS" _N_ _N_ #-}
ppr sty key, ppSP, ppInt (IF_GHC(I# sz, sz)), ppSP,
pprX sty fm_r, ppRparen]
#endif
+
+#if !defined(COMPILING_GHC)
+instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where
+ fm_1 == fm_2 = (sizeFM fm_1 == sizeFM fm_2) && -- quick test
+ (fmToList fm_1 == fmToList fm_2)
+
+{- NO: not clear what The Right Thing to do is:
+instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where
+ fm_1 <= fm_2 = (sizeFM fm_1 <= sizeFM fm_2) && -- quick test
+ (fmToList fm_1 <= fmToList fm_2)
+-}
+#endif
\end{code}
%************************************************************************
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface LiftMonad where
bogusLiftMonadThing :: Bool
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ True [] [] _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface ListSetOps where
intersectLists :: Eq a => [a] -> [a] -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 212 _N_ _N_ _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SS" _N_ _N_ } #-}
minusList :: Eq a => [a] -> [a] -> [a]
- {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _SPECIALISE_ [ Int ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Id ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ TyVar ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ } #-}
unionLists :: Eq a => [a] -> [a] -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 212 _N_ _N_ _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SS" _N_ _N_ } #-}
data Labda a = Hamna | Ni a
data MaybeErr a b = Succeeded a | Failed b
allMaybes :: [Labda a] -> Labda [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
assocMaybe :: Eq a => [(a, b)] -> a -> Labda b
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "LSL" _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ [Char], _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ TyVarTemplate, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Name, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Class, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ } #-}
catMaybes :: [Labda a] -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
failMaB :: b -> MaybeErr a b
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 2 1 X 2 _/\_ u0 u1 -> \ (u2 :: u1) -> _!_ _ORIG_ Maybes Failed [u0, u1] [u2] _N_ #-}
failMaybe :: Labda a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ Maybes Hamna [u0] [] _N_ #-}
firstJust :: [Labda a] -> Labda a
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
mapMaybe :: (a -> Labda b) -> [a] -> Labda [b]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
maybeToBool :: Labda a -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 4 _/\_ u0 -> \ (u1 :: Labda u0) -> case u1 of { _ALG_ _ORIG_ Maybes Hamna -> _!_ False [] []; _ORIG_ Maybes Ni (u2 :: u0) -> _!_ True [] []; _NO_DEFLT_ } _N_ #-}
mkLookupFun :: (a -> a -> Bool) -> [(a, b)] -> a -> Labda b
- {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ #-}
returnMaB :: a -> MaybeErr a b
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 2 1 X 2 _/\_ u0 u1 -> \ (u2 :: u0) -> _!_ _ORIG_ Maybes Succeeded [u0, u1] [u2] _N_ #-}
returnMaybe :: a -> Labda a
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: u0) -> _!_ _ORIG_ Maybes Ni [u0] [u1] _N_ #-}
thenMaB :: MaybeErr a c -> (a -> MaybeErr b c) -> MaybeErr b c
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _F_ _IF_ARGS_ 3 2 CX 6 _/\_ u0 u1 u2 -> \ (u3 :: MaybeErr u0 u2) (u4 :: u0 -> MaybeErr u1 u2) -> case u3 of { _ALG_ _ORIG_ Maybes Succeeded (u5 :: u0) -> _APP_ u4 [ u5 ]; _ORIG_ Maybes Failed (u6 :: u2) -> _!_ _ORIG_ Maybes Failed [u1, u2] [u6]; _NO_DEFLT_ } _N_ #-}
thenMaybe :: Labda a -> (a -> Labda b) -> Labda b
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _F_ _IF_ARGS_ 2 2 CX 5 _/\_ u0 u1 -> \ (u2 :: Labda u0) (u3 :: u0 -> Labda u1) -> case u2 of { _ALG_ _ORIG_ Maybes Hamna -> _!_ _ORIG_ Maybes Hamna [u1] []; _ORIG_ Maybes Ni (u4 :: u0) -> _APP_ u3 [ u4 ]; _NO_DEFLT_ } _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Outputable where
import CharSeq(CSeq)
-import Class(Class)
import CmdLineOpts(GlobalSwitch)
import PreludePS(_PackedString)
import Pretty(Delay, PprStyle(..), Pretty(..), PrettyRep)
import SrcLoc(SrcLoc)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
import UniType(UniType)
import Unique(Unique)
class NamedThing a where
getExportFlag :: a -> ExportFlag
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(SAAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> ExportFlag) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-}
isLocallyDefined :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(ASAAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Bool) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-}
getOrigName :: a -> (_PackedString, _PackedString)
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AASAAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> (_PackedString, _PackedString)) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-}
getOccurrenceName :: a -> _PackedString
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAASAAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> _PackedString) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-}
getInformingModules :: a -> [_PackedString]
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAASAAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> [_PackedString]) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-}
getSrcLoc :: a -> SrcLoc
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAASAAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> SrcLoc) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-}
getTheUnique :: a -> Unique
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAASAAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Unique) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-}
hasType :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAASAA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Bool) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-}
getType :: a -> UniType
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAASA)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> UniType) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-}
fromPreludeCore :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "U(AAAAAAAAAS)" {_A_ 1 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: u0 -> Bool) -> u1 _N_} _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-}
class Outputable a where
ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_
- {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-}
data ExportFlag = ExportAll | ExportAbs | NotExported
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
+data GlobalSwitch
data PprStyle = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char])
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data PrettyRep
+data SrcLoc
+data UniType
+data Unique
getLocalName :: NamedThing a => a -> _PackedString
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AASAAAAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 4 _/\_ u0 -> \ (u1 :: u0 -> (_PackedString, _PackedString)) (u2 :: u0) -> case _APP_ u1 [ u2 ] of { _ALG_ _TUP_2 (u3 :: _PackedString) (u4 :: _PackedString) -> u4; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> case u1 of { _ALG_ _TUP_10 (u3 :: u0 -> ExportFlag) (u4 :: u0 -> Bool) (u5 :: u0 -> (_PackedString, _PackedString)) (u6 :: u0 -> _PackedString) (u7 :: u0 -> [_PackedString]) (u8 :: u0 -> SrcLoc) (u9 :: u0 -> Unique) (ua :: u0 -> Bool) (ub :: u0 -> UniType) (uc :: u0 -> Bool) -> case _APP_ u5 [ u2 ] of { _ALG_ _TUP_2 (ud :: _PackedString) (ue :: _PackedString) -> ue; _NO_DEFLT_ }; _NO_DEFLT_ } _SPECIALISE_ [ ShortName ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(LA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 4 \ (u0 :: _PackedString) -> case _APP_ _WRKR_ _CONSTM_ NamedThing getOrigName (ShortName) [ u0 ] of { _ALG_ _TUP_2 (u1 :: _PackedString) (u2 :: _PackedString) -> u2; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: ShortName) -> case u0 of { _ALG_ _ORIG_ NameTypes ShortName (u1 :: _PackedString) (u2 :: SrcLoc) -> case _APP_ _WRKR_ _CONSTM_ NamedThing getOrigName (ShortName) [ u1 ] of { _ALG_ _TUP_2 (u3 :: _PackedString) (u4 :: _PackedString) -> u4; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-}
ifPprDebug :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprDebug -> u1; (u2 :: PprStyle) -> \ (u3 :: Int) (u4 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u3 ] } _N_ #-}
ifPprInterface :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprInterface (u2 :: GlobalSwitch -> Bool) -> u1; (u3 :: PprStyle) -> \ (u4 :: Int) (u5 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u4 ] } _N_ #-}
ifPprShowAll :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprShowAll -> u1; (u2 :: PprStyle) -> \ (u3 :: Int) (u4 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u3 ] } _N_ #-}
ifnotPprForUser :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprForUser -> \ (u2 :: Int) (u3 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u2 ]; (u4 :: PprStyle) -> u1 } _N_ #-}
ifnotPprShowAll :: PprStyle -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 1122 _N_ _S_ "SL" _F_ _IF_ARGS_ 0 2 CX 12 \ (u0 :: PprStyle) (u1 :: Int -> Bool -> PrettyRep) -> case u0 of { _ALG_ _ORIG_ Pretty PprShowAll -> \ (u2 :: Int) (u3 :: Bool) -> _APP_ _WRKR_ _ORIG_ Pretty ppNil [ u2 ]; (u4 :: PprStyle) -> u1 } _N_ #-}
interpp'SP :: Outputable a => PprStyle -> [a] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 12122 _N_ _S_ "LLS" _N_ _SPECIALISE_ [ Id ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ TyVar ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ UniType ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ TyVarTemplate ] 1 { _A_ 2 _U_ 0122 _N_ _S_ "AS" {_A_ 1 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ }, [ ProtoName ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ (Id, Id) ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ } #-}
interppSP :: Outputable a => PprStyle -> [a] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 12122 _N_ _S_ "LLS" _N_ _SPECIALISE_ [ Id ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ }, [ TyVar ] 1 { _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ } #-}
isAconop :: _PackedString -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
isAvarid :: _PackedString -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
isAvarop :: _PackedString -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
isConop :: _PackedString -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
isExported :: NamedThing a => a -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(SAAAAAAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(AAAS)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 1 { _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ }, [ Class ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(AU(AAAEAA)AAAAAAAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: ExportFlag) -> case u0 of { _ALG_ _ORIG_ Outputable NotExported -> _!_ False [] []; (u1 :: ExportFlag) -> _!_ True [] [] } _N_} _N_ _N_ } #-}
isOpLexeme :: NamedThing a => a -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAASAAAAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(LAAS)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 1 { _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ } #-}
ltLexical :: (NamedThing a, NamedThing b) => a -> b -> Bool
- {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "U(ASSAAAAAAA)U(ALSAAAAAAA)LL" {_A_ 5 _U_ 11122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id, Id ] 2 { _A_ 2 _U_ 11 _N_ _S_ "U(LAAS)U(LAAS)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon, TyCon ] 2 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Class, Class ] 2 { _A_ 2 _U_ 11 _N_ _S_ "U(AU(LLSAAA)AAAAAAAA)U(AU(LLLAAA)AAAAAAAA)" {_A_ 4 _U_ 2221 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
pprNonOp :: (NamedThing a, Outputable a) => PprStyle -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 122222 _N_ _S_ "U(AAASAAAAAA)L" {_A_ 4 _U_ 112222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id ] 2 { _A_ 2 _U_ 2122 _N_ _S_ "LU(LLLS)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 2 { _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ } #-}
pprOp :: (NamedThing a, Outputable a) => PprStyle -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 122222 _N_ _S_ "U(AAASAAAAAA)L" {_A_ 4 _U_ 112222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Id ] 2 { _A_ 2 _U_ 2122 _N_ _S_ "LU(LLLS)" {_A_ 5 _U_ 2222222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
instance (Outputable a, Outputable b) => Outputable (a, b)
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _U_ 22 _N_ _S_ "LLLS" _N_ _N_ #-}
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 5 _U_ 222 _N_ _S_ "LLLLU(LLL)" _N_ _N_ #-}
instance Outputable Bool
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 4 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _CONSTM_ Outputable ppr (Bool) _N_
- ppr = _A_ 4 _U_ 0120 _N_ _S_ "AELA" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Outputable a => Outputable [a]
- {-# GHC_PRAGMA _M_ Outputable {-dfun-} _A_ 3 _U_ 2 _N_ _N_ _N_ _N_ #-}
import PreludeRatio(Ratio(..))
import Stdio(_FILE)
import Unpretty(Unpretty(..))
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data Delay a {-# GHC_PRAGMA MkDelay a #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
+data CSeq
+data Delay a
+data GlobalSwitch
data PprStyle = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char])
type Pretty = Int -> Bool -> PrettyRep
data PrettyRep = MkPrettyRep CSeq (Delay Int) Bool Bool
type Unpretty = CSeq
codeStyle :: PprStyle -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 10 \ (u0 :: PprStyle) -> case u0 of { _ALG_ _ORIG_ Pretty PprForC (u1 :: GlobalSwitch -> Bool) -> _!_ True [] []; _ORIG_ Pretty PprForAsm (u2 :: GlobalSwitch -> Bool) (u3 :: Bool) (u4 :: [Char] -> [Char]) -> _!_ True [] []; (u5 :: PprStyle) -> _!_ False [] [] } _N_ #-}
pp'SP :: Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 2 _APP_ _ORIG_ Pretty ppStr [ _NOREP_S_ ", " ] _N_ #-}
ppAbove :: (Int -> Bool -> PrettyRep) -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 1120 _N_ _S_ "SLLA" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
ppAboves :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: [Int -> Bool -> PrettyRep]) -> case u0 of { _ALG_ (:) (u1 :: Int -> Bool -> PrettyRep) (u2 :: [Int -> Bool -> PrettyRep]) -> _APP_ _TYAPP_ _ORIG_ PreludeList foldr1 { (Int -> Bool -> PrettyRep) } [ _ORIG_ Pretty ppAbove, u0 ]; _NIL_ -> _ORIG_ Pretty ppNil; _NO_DEFLT_ } _N_ #-}
ppAppendFile :: _FILE -> Int -> (Int -> Bool -> PrettyRep) -> _State _RealWorld -> ((), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 4 _U_ 1212 _N_ _S_ "U(P)LSL" {_A_ 4 _U_ 2212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
ppBeside :: (Int -> Bool -> PrettyRep) -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 1120 _N_ _S_ "SLLA" {_A_ 3 _U_ 112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
ppBesides :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 C 6 \ (u0 :: [Int -> Bool -> PrettyRep]) -> case u0 of { _ALG_ (:) (u1 :: Int -> Bool -> PrettyRep) (u2 :: [Int -> Bool -> PrettyRep]) -> _APP_ _TYAPP_ _ORIG_ PreludeList foldr1 { (Int -> Bool -> PrettyRep) } [ _ORIG_ Pretty ppBeside, u0 ]; _NIL_ -> _ORIG_ Pretty ppNil; _NO_DEFLT_ } _N_ #-}
ppCat :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 222 _N_ _S_ "S" _N_ _N_ #-}
ppChar :: Char -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 210 _N_ _S_ "LLA" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-}
ppComma :: Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-}
ppDouble :: Double -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-}
ppEquals :: Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-}
ppFloat :: Float -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 210 _N_ _N_ _N_ _N_ #-}
ppHang :: (Int -> Bool -> PrettyRep) -> Int -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 12222 _N_ _S_ "SLLLL" _N_ _N_ #-}
ppInt :: Int -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 110 _N_ _S_ "LLA" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-}
ppInteger :: Integer -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-}
ppInterleave :: (Int -> Bool -> PrettyRep) -> [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
ppIntersperse :: (Int -> Bool -> PrettyRep) -> [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2122 _N_ _S_ "LS" _N_ _N_ #-}
ppLbrack :: Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-}
ppLparen :: Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-}
ppNest :: Int -> (Int -> Bool -> PrettyRep) -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 4 _U_ 2122 _N_ _S_ "LSLE" _N_ _N_ #-}
ppNil :: Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _S_ "LA" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
ppPStr :: _PackedString -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 210 _N_ _S_ "LLA" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-}
ppRational :: Ratio Integer -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-}
ppRbrack :: Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-}
ppRparen :: Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-}
ppSP :: Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-}
ppSemi :: Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _N_ _N_ _N_ #-}
ppSep :: [Int -> Bool -> PrettyRep] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "SLL" _N_ _N_ #-}
ppShow :: Int -> (Int -> Bool -> PrettyRep) -> [Char]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
ppStr :: [Char] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 210 _N_ _S_ "LLA" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-}
prettyToUn :: (Int -> Bool -> PrettyRep) -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface UniqFM where
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Maybes(Labda)
-import NameTypes(ShortName)
import Outputable(NamedThing)
import TyVar(TyVar)
-import UniType(UniType)
-import Unique(Unique, u2i)
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+import Unique(Unique)
+data Id
+data TyVar
+data UniqFM a
+data Unique
addToUFM :: NamedThing a => UniqFM b -> a -> b -> UniqFM b
- {-# GHC_PRAGMA _A_ 4 _U_ 1222 _N_ _S_ "U(AAAAAASAAA)SLL" {_A_ 4 _U_ 1222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 3 _U_ 222 _N_ _S_ "SSL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "SU(U(P)AAA)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
addToUFM_Directly :: UniqFM a -> Unique -> a -> UniqFM a
- {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "SU(P)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
delFromUFM :: NamedThing a => UniqFM b -> a -> UniqFM b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
delListFromUFM :: NamedThing a => UniqFM b -> [a] -> UniqFM b
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ } #-}
eltsUFM :: UniqFM a -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
emptyUFM :: UniqFM a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
filterUFM :: (a -> Bool) -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
intersectUFM :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
isNullUFM :: UniqFM a -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 5 _/\_ u0 -> \ (u1 :: UniqFM u0) -> case u1 of { _ALG_ _ORIG_ UniqFM EmptyUFM -> _!_ True [] []; (u2 :: UniqFM u0) -> _!_ False [] [] } _N_ #-}
listToUFM :: NamedThing a => [(a, b)] -> UniqFM b
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-}
listToUFM_Directly :: [(Unique, a)] -> UniqFM a
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
lookupDirectlyUFM :: UniqFM a -> Unique -> Labda a
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "SU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
lookupUFM :: NamedThing a => UniqFM b -> a -> Labda b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)SL" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 21 _N_ _S_ "SU(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
mapUFM :: (a -> b) -> UniqFM a -> UniqFM b
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
minusUFM :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
plusUFM_C :: (a -> a -> a) -> UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 3 _U_ 222 _N_ _S_ "LSS" _N_ _N_ #-}
singletonDirectlyUFM :: Unique -> a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 4 _/\_ u0 -> \ (u1 :: Unique) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u3, u2]; _NO_DEFLT_ } _N_ #-}
singletonUFM :: NamedThing a => a -> b -> UniqFM b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LL" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 2 3 XXX 6 _/\_ u0 u1 -> \ (u2 :: u0 -> Unique) (u3 :: u0) (u4 :: u1) -> case _APP_ u2 [ u3 ] of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [u5, u4]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 2 3 CXX 7 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: u0) (u4 :: u1) -> case case u2 of { _ALG_ _TUP_10 (u5 :: u0 -> ExportFlag) (u6 :: u0 -> Bool) (u7 :: u0 -> (_PackedString, _PackedString)) (u8 :: u0 -> _PackedString) (u9 :: u0 -> [_PackedString]) (ua :: u0 -> SrcLoc) (ub :: u0 -> Unique) (uc :: u0 -> Bool) (ud :: u0 -> UniType) (ue :: u0 -> Bool) -> _APP_ ub [ u3 ]; _NO_DEFLT_ } of { _ALG_ _ORIG_ Unique MkUnique (uf :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [uf, u4]; _NO_DEFLT_ } _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-}
sizeUFM :: UniqFM a -> Int
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-u2i :: Unique -> Int#
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-}
ufmToList :: UniqFM a -> [(Unique, a)]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface UniqSet where
-import Id(Id, IdDetails)
-import IdInfo(IdInfo)
+import Id(Id)
import Name(Name)
import NameTypes(FullName, ShortName)
import Outputable(NamedThing)
import PreludePS(_PackedString)
import TyCon(TyCon)
import TyVar(TyVar)
-import UniType(UniType)
-import UniqFM(UniqFM, eltsUFM, emptyUFM, intersectUFM, isNullUFM, minusUFM, plusUFM, singletonUFM)
-import Unique(Unique, u2i)
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
+import UniqFM(UniqFM)
+import Unique(Unique)
+data Id
type IdSet = UniqFM Id
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
+data Name
type NameSet = UniqFM Name
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
+data TyVar
type TyVarSet = UniqFM TyVar
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
+data UniqFM a
type UniqSet a = UniqFM a
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
+data Unique
elementOfUniqSet :: NamedThing a => a -> UniqFM a -> Bool
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LS" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ }, [ Id ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)S" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Name ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ } #-}
-eltsUFM :: UniqFM a -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
-emptyUFM :: UniqFM a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
emptyUniqSet :: UniqFM a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ UniqFM EmptyUFM [u0] [] _N_ #-}
-intersectUFM :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
intersectUniqSets :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM intersectUFM _N_ #-}
isEmptyUniqSet :: UniqFM a -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM isNullUFM _N_ #-}
-isNullUFM :: UniqFM a -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 5 _/\_ u0 -> \ (u1 :: UniqFM u0) -> case u1 of { _ALG_ _ORIG_ UniqFM EmptyUFM -> _!_ True [] []; (u2 :: UniqFM u0) -> _!_ False [] [] } _N_ #-}
mapUniqSet :: NamedThing b => (a -> b) -> UniqFM a -> UniqFM b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "LLS" _N_ _SPECIALISE_ [ _N_, TyVar ] 1 { _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ }, [ _N_, Id ] 1 { _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ }, [ _N_, Name ] 1 { _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ } #-}
-minusUFM :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
minusUniqSet :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM minusUFM _N_ #-}
mkUniqSet :: NamedThing a => [a] -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "LS" _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Id ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ }, [ Name ] 1 { _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ } #-}
-plusUFM :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-singletonUFM :: NamedThing a => a -> b -> UniqFM b
- {-# GHC_PRAGMA _A_ 3 _U_ 122 _N_ _S_ "U(AAAAAASAAA)LL" {_A_ 3 _U_ 122 _N_ _N_ _F_ _IF_ARGS_ 2 3 XXX 6 _/\_ u0 u1 -> \ (u2 :: u0 -> Unique) (u3 :: u0) (u4 :: u1) -> case _APP_ u2 [ u3 ] of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [u5, u4]; _NO_DEFLT_ } _N_} _F_ _IF_ARGS_ 2 3 CXX 7 _/\_ u0 u1 -> \ (u2 :: {{NamedThing u0}}) (u3 :: u0) (u4 :: u1) -> case case u2 of { _ALG_ _TUP_10 (u5 :: u0 -> ExportFlag) (u6 :: u0 -> Bool) (u7 :: u0 -> (_PackedString, _PackedString)) (u8 :: u0 -> _PackedString) (u9 :: u0 -> [_PackedString]) (ua :: u0 -> SrcLoc) (ub :: u0 -> Unique) (uc :: u0 -> Bool) (ud :: u0 -> UniType) (ue :: u0 -> Bool) -> _APP_ ub [ u3 ]; _NO_DEFLT_ } of { _ALG_ _ORIG_ Unique MkUnique (uf :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u1] [uf, u4]; _NO_DEFLT_ } _SPECIALISE_ [ Name, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 2 _U_ 12 _N_ _S_ "U(U(P)AAA)L" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: Int#) (u2 :: u0) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u1, u2] _N_} _F_ _IF_ARGS_ 1 2 CX 5 _/\_ u0 -> \ (u1 :: Id) (u2 :: u0) -> case u1 of { _ALG_ _ORIG_ Id Id (u3 :: Unique) (u4 :: UniType) (u5 :: IdInfo) (u6 :: IdDetails) -> case u3 of { _ALG_ _ORIG_ Unique MkUnique (u7 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [u0] [u7, u2]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ } #-}
singletonUniqSet :: NamedThing a => a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(AAAAAASAAA)L" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 1 2 XX 4 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ UniqFM singletonUFM { u0 } { u0 } [ u1, u2, u2 ] _SPECIALISE_ [ TyVar ] 1 { _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: TyVar) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ UniqFM singletonUFM [ (TyVar), _N_ ] { TyVar } [ u0, u0 ] _N_ }, [ Id ] 1 { _A_ 1 _U_ 1 _N_ _S_ "U(U(P)LLL)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u5 :: Int#) -> _!_ _ORIG_ UniqFM LeafUFM [Id] [u5, u0]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ }, [ Name ] 1 { _A_ 1 _U_ 2 _N_ _S_ "S" _F_ _IF_ARGS_ 0 1 X 3 \ (u0 :: Name) -> _APP_ _TYAPP_ _SPEC_ _ORIG_ UniqFM singletonUFM [ (Name), _N_ ] { Name } [ u0, u0 ] _N_ } #-}
-u2i :: Unique -> Int#
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: Int#) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u1 :: Int#) -> u1; _NO_DEFLT_ } _N_ #-}
unionManyUniqSets :: [UniqFM a] -> UniqFM a
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
unionUniqSets :: UniqFM a -> UniqFM a -> UniqFM a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM plusUFM _N_ #-}
uniqSetToList :: UniqFM a -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ UniqFM eltsUFM _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Unpretty where
-import CharSeq(CSeq, cAppendFile, cInt)
+import CharSeq(CSeq)
import CmdLineOpts(GlobalSwitch)
import PreludePS(_PackedString)
import Pretty(PprStyle(..))
import Stdio(_FILE)
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
+data CSeq
+data GlobalSwitch
data PprStyle = PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char])
type Unpretty = CSeq
-cAppendFile :: _FILE -> CSeq -> _State _RealWorld -> ((), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(P)SL" {_A_ 3 _U_ 212 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-cInt :: Int -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ CharSeq CInt [] [u0] _N_ #-}
uppAbove :: CSeq -> CSeq -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
uppAboves :: [CSeq] -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
uppAppendFile :: _FILE -> Int -> CSeq -> _State _RealWorld -> ((), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 4 _U_ 1022 _N_ _S_ "U(P)ASL" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
uppBeside :: CSeq -> CSeq -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: CSeq) (u1 :: CSeq) -> _!_ _ORIG_ CharSeq CAppend [] [u0, u1] _N_ #-}
uppBesides :: [CSeq] -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
uppCat :: [CSeq] -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
uppChar :: Char -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Char) -> _!_ _ORIG_ CharSeq CCh [] [u0] _N_ #-}
uppComma :: CSeq
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
uppEquals :: CSeq
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
uppInt :: Int -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int) -> _!_ _ORIG_ CharSeq CInt [] [u0] _N_ #-}
uppInteger :: Integer -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ #-}
uppInterleave :: CSeq -> [CSeq] -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
uppIntersperse :: CSeq -> [CSeq] -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
uppLbrack :: CSeq
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
uppLparen :: CSeq
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
uppNest :: Int -> CSeq -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 01 _N_ _S_ "AS" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: CSeq) -> u0 _N_} _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Int) (u1 :: CSeq) -> u1 _N_ #-}
uppNil :: CSeq
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CharSeq CNil [] [] _N_ #-}
uppPStr :: _PackedString -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: _PackedString) -> _!_ _ORIG_ CharSeq CPStr [] [u0] _N_ #-}
uppRbrack :: CSeq
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
uppRparen :: CSeq
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
uppSP :: CSeq
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
uppSemi :: CSeq
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
uppSep :: [CSeq] -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ Unpretty uppBesides _N_ #-}
uppShow :: Int -> CSeq -> [Char]
- {-# GHC_PRAGMA _A_ 2 _U_ 02 _N_ _S_ "AS" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ CharSeq cShow _N_} _F_ _IF_ARGS_ 0 2 XX 2 \ (u0 :: Int) (u1 :: CSeq) -> _APP_ _ORIG_ CharSeq cShow [ u1 ] _N_ #-}
uppStr :: [Char] -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Char]) -> _!_ _ORIG_ CharSeq CStr [] [u0] _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Util where
-import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
-import AbsSyn(Module)
-import Bag(Bag, emptyBag, snocBag)
-import BasicLit(BasicLit, kindOfBasicLit, typeOfBasicLit)
-import BinderInfo(BinderInfo, DuplicationDanger, FunOrArg, InsideSCC)
-import CLabelInfo(CLabel)
-import CgBindery(StableLoc, VolatileLoc)
-import CgMonad(EndOfBlockInfo, Sequel, StubFlag)
-import CharSeq(CSeq, cAppend, cCh, cNil, cPStr, cShow, cStr)
-import Class(Class, ClassOp)
-import ClosureInfo(ClosureInfo, LambdaFormInfo, StandardFormInfo)
-import CmdLineOpts(GlobalSwitch, SimplifierSwitch, SwitchResult, switchIsOn)
-import CoreSyn(CoreArg, CoreAtom, CoreBinding, CoreCaseAlternatives, CoreCaseDefault, CoreExpr, pprCoreBinding, pprCoreExpr)
-import CostCentre(CcKind, CostCentre, IsCafCC, IsDupdCC)
-import FiniteMap(FiniteMap, emptyFM)
-import HeapOffs(HeapOffset)
-import HsBinds(Bind, Binds, MonoBinds, Sig)
-import HsCore(UfCostCentre, UfId, UnfoldingCoreAlts, UnfoldingCoreAtom, UnfoldingCoreBinding, UnfoldingCoreDefault, UnfoldingCoreExpr, UnfoldingPrimOp)
-import HsDecls(ClassDecl, ConDecl, DataTypeSig, DefaultDecl, FixityDecl, InstDecl, SpecialisedInstanceSig, TyDecl)
-import HsExpr(ArithSeqInfo, Expr, Qual)
-import HsImpExp(IE, IfaceImportDecl, ImportedInterface, Interface, Renaming)
-import HsLit(Literal)
-import HsMatches(GRHS, GRHSsAndBinds, Match)
-import HsPat(InPat, TypecheckedPat, typeOfPat)
-import HsPragmas(ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas, ImpStrictness, ImpUnfolding, InstancePragmas, TypePragmas)
-import HsTypes(MonoType, PolyType)
-import Id(Id, IdDetails, cmpId, eqId, getIdKind, getIdUniType)
-import IdEnv(IdEnv(..))
-import IdInfo(ArgUsage, ArgUsageInfo, ArityInfo, DeforestInfo, Demand, DemandInfo, FBConsum, FBProd, FBType, FBTypeInfo, IdInfo, OptIdInfo(..), SpecEnv, SpecInfo, StrictnessInfo, UpdateInfo, nullSpecEnv)
-import Inst(Inst, InstOrigin, OverloadedLit)
-import InstEnv(InstTemplate, InstTy)
-import MagicUFs(MagicUnfoldingFun)
+import CharSeq(CSeq)
import Maybes(Labda(..))
-import Name(Name, cmpName, eqName)
-import NameTypes(FullName, Provenance, ShortName)
-import OrdList(OrdList)
-import Outputable(ExportFlag, NamedThing(..), Outputable(..))
import PreludePS(_PackedString)
-import PreludeRatio(Ratio(..))
-import Pretty(Delay, PprStyle, Pretty(..), PrettyRep, ppDouble, ppInt, ppInteger, ppNil, ppRational, ppStr)
-import PrimKind(PrimKind)
-import PrimOps(PrimOp, pprPrimOp, tagOf_PrimOp)
-import ProtoName(ProtoName, cmpByLocalName, cmpProtoName, eqByLocalName, eqProtoName)
-import SMRep(SMRep, SMSpecRepKind, SMUpdateKind)
-import SimplEnv(EnclosingCcDetails, FormSummary, IdVal, SimplEnv, UnfoldConApp, UnfoldEnv, UnfoldItem, UnfoldingDetails, UnfoldingGuidance)
-import SimplMonad(SimplCount, TickType)
-import SplitUniq(SplitUniqSupply)
-import SrcLoc(SrcLoc, mkUnknownSrcLoc)
-import StgSyn(StgAtom, StgBinderInfo, StgBinding, StgCaseAlternatives, StgCaseDefault, StgExpr, StgRhs, UpdateFlag)
-import TyCon(TyCon)
-import TyVar(TyVar, TyVarTemplate)
-import TyVarEnv(TyVarEnv(..))
-import UniTyFuns(kindFromType, pprTyCon, pprUniType)
-import UniType(UniType)
-import UniqFM(UniqFM)
-import Unique(Unique, UniqueSupply, cmpUnique, eqUnique, showUnique)
-class OptIdInfo a where
- noInfo :: a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 1 _U_ 0 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 1 X 2 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) -> _APP_ _TYAPP_ patError# { u0 } [ _NOREP_S_ "%DIdInfo.OptIdInfo.noInfo\"" ] _N_ #-}
- getInfo :: IdInfo -> a
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.getInfo\"", u2 ] _N_ #-}
- addInfo :: IdInfo -> a -> IdInfo
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 3 _U_ 022 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 3 XXX 4 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: IdInfo) (u3 :: u0) -> _APP_ _TYAPP_ patError# { (IdInfo -> u0 -> IdInfo) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.addInfo\"", u2, u3 ] _N_ #-}
- ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 122222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0, IdInfo -> u0, IdInfo -> u0 -> IdInfo, PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep)) -> case u1 of { _ALG_ _TUP_4 (u2 :: u0) (u3 :: IdInfo -> u0) (u4 :: IdInfo -> u0 -> IdInfo) (u5 :: PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 6 _U_ 022222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 6 XXXXXX 7 _/\_ u0 -> \ (u1 :: {{OptIdInfo u0}}) (u2 :: PprStyle) (u3 :: Id -> Id) (u4 :: u0) (u5 :: Int) (u6 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> (Id -> Id) -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DIdInfo.OptIdInfo.ppInfo\"", u2, u3, u4, u5, u6 ] _N_ #-}
-class NamedThing a where
- getExportFlag :: a -> ExportFlag
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u2; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> ExportFlag) } [ _NOREP_S_ "%DOutputable.NamedThing.getExportFlag\"", u2 ] _N_ #-}
- isLocallyDefined :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u3; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.isLocallyDefined\"", u2 ] _N_ #-}
- getOrigName :: a -> (_PackedString, _PackedString)
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u4; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> (_PackedString, _PackedString)) } [ _NOREP_S_ "%DOutputable.NamedThing.getOrigName\"", u2 ] _N_ #-}
- getOccurrenceName :: a -> _PackedString
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u5; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> _PackedString) } [ _NOREP_S_ "%DOutputable.NamedThing.getOccurrenceName\"", u2 ] _N_ #-}
- getInformingModules :: a -> [_PackedString]
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u6; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> [_PackedString]) } [ _NOREP_S_ "%DOutputable.NamedThing.getInformingModules\"", u2 ] _N_ #-}
- getSrcLoc :: a -> SrcLoc
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u7; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> SrcLoc) } [ _NOREP_S_ "%DOutputable.NamedThing.getSrcLoc\"", u2 ] _N_ #-}
- getTheUnique :: a -> Unique
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u8; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Unique) } [ _NOREP_S_ "%DOutputable.NamedThing.getTheUnique\"", u2 ] _N_ #-}
- hasType :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> u9; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.hasType\"", u2 ] _N_ #-}
- getType :: a -> UniType
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ua; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> UniType) } [ _NOREP_S_ "%DOutputable.NamedThing.getType\"", u2 ] _N_ #-}
- fromPreludeCore :: a -> Bool
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 C 2 _/\_ u0 -> \ (u1 :: (u0 -> ExportFlag, u0 -> Bool, u0 -> (_PackedString, _PackedString), u0 -> _PackedString, u0 -> [_PackedString], u0 -> SrcLoc, u0 -> Unique, u0 -> Bool, u0 -> UniType, u0 -> Bool)) -> case u1 of { _ALG_ _TUP_10 (u2 :: u0 -> ExportFlag) (u3 :: u0 -> Bool) (u4 :: u0 -> (_PackedString, _PackedString)) (u5 :: u0 -> _PackedString) (u6 :: u0 -> [_PackedString]) (u7 :: u0 -> SrcLoc) (u8 :: u0 -> Unique) (u9 :: u0 -> Bool) (ua :: u0 -> UniType) (ub :: u0 -> Bool) -> ub; _NO_DEFLT_ } _N_
- {-defm-} _A_ 2 _U_ 02 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 2 XX 3 _/\_ u0 -> \ (u1 :: {{NamedThing u0}}) (u2 :: u0) -> _APP_ _TYAPP_ patError# { (u0 -> Bool) } [ _NOREP_S_ "%DOutputable.NamedThing.fromPreludeCore\"", u2 ] _N_ #-}
-class Outputable a where
- ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA {-meth-} _A_ 1 _U_ 12222 _N_ _S_ "S" _F_ _IF_ARGS_ 1 1 X 1 _/\_ u0 -> \ (u1 :: PprStyle -> u0 -> Int -> Bool -> PrettyRep) -> u1 _N_
- {-defm-} _A_ 5 _U_ 02222 _N_ _S_ _!_ _F_ _IF_ARGS_ 1 5 XXXXX 6 _/\_ u0 -> \ (u1 :: {{Outputable u0}}) (u2 :: PprStyle) (u3 :: u0) (u4 :: Int) (u5 :: Bool) -> _APP_ _TYAPP_ patError# { (PprStyle -> u0 -> Int -> Bool -> PrettyRep) } [ _NOREP_S_ "%DOutputable.Outputable.ppr\"", u2, u3, u4, u5 ] _N_ #-}
-data AbstractC {-# GHC_PRAGMA AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker #-}
-data CAddrMode {-# GHC_PRAGMA CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool #-}
-data CExprMacro {-# GHC_PRAGMA INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG #-}
-data CStmtMacro {-# GHC_PRAGMA ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG #-}
-data MagicId {-# GHC_PRAGMA BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg #-}
-data RegRelative {-# GHC_PRAGMA HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset #-}
-data ReturnInfo {-# GHC_PRAGMA DirectReturn | StaticVectoredReturn Int | DynamicVectoredReturn CAddrMode #-}
-data Module a b {-# GHC_PRAGMA Module _PackedString [IE] [ImportedInterface a b] [FixityDecl a] [TyDecl a] [DataTypeSig a] [ClassDecl a b] [InstDecl a b] [SpecialisedInstanceSig a] [DefaultDecl a] (Binds a b) [Sig a] SrcLoc #-}
-data Bag a {-# GHC_PRAGMA EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) | ListOfBags [Bag a] #-}
-data BasicLit {-# GHC_PRAGMA MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer) #-}
-data BinderInfo {-# GHC_PRAGMA DeadCode | ManyOcc Int | OneOcc FunOrArg DuplicationDanger InsideSCC Int Int #-}
-data DuplicationDanger {-# GHC_PRAGMA DupDanger | NoDupDanger #-}
-data FunOrArg {-# GHC_PRAGMA FunOcc | ArgOcc #-}
-data InsideSCC {-# GHC_PRAGMA InsideSCC | NotInsideSCC #-}
-data CLabel
-data StableLoc {-# GHC_PRAGMA NoStableLoc | VirAStkLoc Int | VirBStkLoc Int | LitLoc BasicLit | StableAmodeLoc CAddrMode #-}
-data VolatileLoc {-# GHC_PRAGMA NoVolatileLoc | TempVarLoc Unique | RegLoc MagicId | VirHpLoc HeapOffset | VirNodeLoc HeapOffset #-}
-data EndOfBlockInfo {-# GHC_PRAGMA EndOfBlockInfo Int Int Sequel #-}
-data Sequel {-# GHC_PRAGMA InRetReg | OnStack Int | UpdateCode CAddrMode | CaseAlts CAddrMode (Labda ([(Int, (AbstractC, CLabel))], Labda (Labda Id, (AbstractC, CLabel)))) #-}
-data StubFlag {-# GHC_PRAGMA Stubbed | NotStubbed #-}
-data CSeq {-# GHC_PRAGMA CNil | CAppend CSeq CSeq | CIndent Int CSeq | CNewline | CStr [Char] | CCh Char | CInt Int | CPStr _PackedString #-}
-data Class {-# GHC_PRAGMA MkClass Unique FullName TyVarTemplate [Class] [Id] [ClassOp] [Id] [Id] [(UniType, InstTemplate)] [(Class, [Class])] #-}
-data ClassOp {-# GHC_PRAGMA MkClassOp _PackedString Int UniType #-}
-data ClosureInfo {-# GHC_PRAGMA MkClosureInfo Id LambdaFormInfo SMRep #-}
-data LambdaFormInfo {-# GHC_PRAGMA LFReEntrant Bool Int Bool | LFCon Id Bool | LFTuple Id Bool | LFThunk Bool Bool Bool StandardFormInfo | LFArgument | LFImported | LFLetNoEscape Int (UniqFM Id) | LFBlackHole | LFIndirection #-}
-data StandardFormInfo {-# GHC_PRAGMA NonStandardThunk | SelectorThunk Id Id Int | VapThunk Id [StgAtom Id] Bool #-}
-data GlobalSwitch
- {-# GHC_PRAGMA ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitUnspecialisedCode | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | AllDemanded | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_dump_core_passes | D_dump_core_passes_info | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats #-}
-data SimplifierSwitch {-# GHC_PRAGMA SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings #-}
-data SwitchResult {-# GHC_PRAGMA SwBool Bool | SwString [Char] | SwInt Int #-}
-data CoreArg a {-# GHC_PRAGMA TypeArg UniType | ValArg (CoreAtom a) #-}
-data CoreAtom a {-# GHC_PRAGMA CoVarAtom a | CoLitAtom BasicLit #-}
-data CoreBinding a b {-# GHC_PRAGMA CoNonRec a (CoreExpr a b) | CoRec [(a, CoreExpr a b)] #-}
-data CoreCaseAlternatives a b {-# GHC_PRAGMA CoAlgAlts [(Id, [a], CoreExpr a b)] (CoreCaseDefault a b) | CoPrimAlts [(BasicLit, CoreExpr a b)] (CoreCaseDefault a b) #-}
-data CoreCaseDefault a b {-# GHC_PRAGMA CoNoDefault | CoBindDefault a (CoreExpr a b) #-}
-data CoreExpr a b {-# GHC_PRAGMA CoVar b | CoLit BasicLit | CoCon Id [UniType] [CoreAtom b] | CoPrim PrimOp [UniType] [CoreAtom b] | CoLam [a] (CoreExpr a b) | CoTyLam TyVar (CoreExpr a b) | CoApp (CoreExpr a b) (CoreAtom b) | CoTyApp (CoreExpr a b) UniType | CoCase (CoreExpr a b) (CoreCaseAlternatives a b) | CoLet (CoreBinding a b) (CoreExpr a b) | CoSCC CostCentre (CoreExpr a b) #-}
-data CcKind {-# GHC_PRAGMA UserCC _PackedString | AutoCC Id | DictCC Id #-}
-data CostCentre {-# GHC_PRAGMA NoCostCentre | NormalCC CcKind _PackedString _PackedString IsDupdCC IsCafCC | CurrentCC | SubsumedCosts | AllCafsCC _PackedString _PackedString | AllDictsCC _PackedString _PackedString IsDupdCC | OverheadCC | PreludeCafsCC | PreludeDictsCC IsDupdCC | DontCareCC #-}
-data IsCafCC {-# GHC_PRAGMA IsCafCC | IsNotCafCC #-}
-data IsDupdCC {-# GHC_PRAGMA AnOriginalCC | ADupdCC #-}
-data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
-data HeapOffset
-data Bind a b {-# GHC_PRAGMA EmptyBind | NonRecBind (MonoBinds a b) | RecBind (MonoBinds a b) #-}
-data Binds a b {-# GHC_PRAGMA EmptyBinds | ThenBinds (Binds a b) (Binds a b) | SingleBind (Bind a b) | BindWith (Bind a b) [Sig a] | AbsBinds [TyVar] [Id] [(Id, Id)] [(Inst, Expr a b)] (Bind a b) #-}
-data MonoBinds a b {-# GHC_PRAGMA EmptyMonoBinds | AndMonoBinds (MonoBinds a b) (MonoBinds a b) | PatMonoBind b (GRHSsAndBinds a b) SrcLoc | VarMonoBind Id (Expr a b) | FunMonoBind a [Match a b] SrcLoc #-}
-data Sig a {-# GHC_PRAGMA Sig a (PolyType a) (GenPragmas a) SrcLoc | ClassOpSig a (PolyType a) (ClassOpPragmas a) SrcLoc | SpecSig a (PolyType a) (Labda a) SrcLoc | InlineSig a UnfoldingGuidance SrcLoc | DeforestSig a SrcLoc | MagicUnfoldingSig a _PackedString SrcLoc #-}
-data UfCostCentre a {-# GHC_PRAGMA UfPreludeDictsCC Bool | UfAllDictsCC _PackedString _PackedString Bool | UfUserCC _PackedString _PackedString _PackedString Bool Bool | UfAutoCC (UfId a) _PackedString _PackedString Bool Bool | UfDictCC (UfId a) _PackedString _PackedString Bool Bool #-}
-data UfId a {-# GHC_PRAGMA BoringUfId a | SuperDictSelUfId a a | ClassOpUfId a a | DictFunUfId a (PolyType a) | ConstMethodUfId a a (PolyType a) | DefaultMethodUfId a a | SpecUfId (UfId a) [Labda (MonoType a)] | WorkerUfId (UfId a) #-}
-data UnfoldingCoreAlts a {-# GHC_PRAGMA UfCoAlgAlts [(a, [(a, PolyType a)], UnfoldingCoreExpr a)] (UnfoldingCoreDefault a) | UfCoPrimAlts [(BasicLit, UnfoldingCoreExpr a)] (UnfoldingCoreDefault a) #-}
-data UnfoldingCoreAtom a {-# GHC_PRAGMA UfCoVarAtom (UfId a) | UfCoLitAtom BasicLit #-}
-data UnfoldingCoreBinding a {-# GHC_PRAGMA UfCoNonRec (a, PolyType a) (UnfoldingCoreExpr a) | UfCoRec [((a, PolyType a), UnfoldingCoreExpr a)] #-}
-data UnfoldingCoreDefault a {-# GHC_PRAGMA UfCoNoDefault | UfCoBindDefault (a, PolyType a) (UnfoldingCoreExpr a) #-}
-data UnfoldingCoreExpr a {-# GHC_PRAGMA UfCoVar (UfId a) | UfCoLit BasicLit | UfCoCon a [PolyType a] [UnfoldingCoreAtom a] | UfCoPrim (UnfoldingPrimOp a) [PolyType a] [UnfoldingCoreAtom a] | UfCoLam [(a, PolyType a)] (UnfoldingCoreExpr a) | UfCoTyLam a (UnfoldingCoreExpr a) | UfCoApp (UnfoldingCoreExpr a) (UnfoldingCoreAtom a) | UfCoTyApp (UnfoldingCoreExpr a) (PolyType a) | UfCoCase (UnfoldingCoreExpr a) (UnfoldingCoreAlts a) | UfCoLet (UnfoldingCoreBinding a) (UnfoldingCoreExpr a) | UfCoSCC (UfCostCentre a) (UnfoldingCoreExpr a) #-}
-data UnfoldingPrimOp a {-# GHC_PRAGMA UfCCallOp _PackedString Bool Bool [PolyType a] (PolyType a) | UfOtherOp PrimOp #-}
-data ClassDecl a b {-# GHC_PRAGMA ClassDecl [(a, a)] a a [Sig a] (MonoBinds a b) (ClassPragmas a) SrcLoc #-}
-data ConDecl a {-# GHC_PRAGMA ConDecl a [MonoType a] SrcLoc #-}
-data DataTypeSig a {-# GHC_PRAGMA AbstractTypeSig a SrcLoc | SpecDataSig a (MonoType a) SrcLoc #-}
-data DefaultDecl a {-# GHC_PRAGMA DefaultDecl [MonoType a] SrcLoc #-}
-data FixityDecl a {-# GHC_PRAGMA InfixL a Int | InfixR a Int | InfixN a Int #-}
-data InstDecl a b {-# GHC_PRAGMA InstDecl [(a, a)] a (MonoType a) (MonoBinds a b) Bool _PackedString _PackedString [Sig a] (InstancePragmas a) SrcLoc #-}
-data SpecialisedInstanceSig a {-# GHC_PRAGMA InstSpecSig a (MonoType a) SrcLoc #-}
-data TyDecl a {-# GHC_PRAGMA TyData [(a, a)] a [a] [ConDecl a] [a] (DataPragmas a) SrcLoc | TySynonym a [a] (MonoType a) TypePragmas SrcLoc #-}
-data ArithSeqInfo a b {-# GHC_PRAGMA From (Expr a b) | FromThen (Expr a b) (Expr a b) | FromTo (Expr a b) (Expr a b) | FromThenTo (Expr a b) (Expr a b) (Expr a b) #-}
-data Expr a b {-# GHC_PRAGMA Var a | Lit Literal | Lam (Match a b) | App (Expr a b) (Expr a b) | OpApp (Expr a b) (Expr a b) (Expr a b) | SectionL (Expr a b) (Expr a b) | SectionR (Expr a b) (Expr a b) | CCall _PackedString [Expr a b] Bool Bool UniType | SCC _PackedString (Expr a b) | Case (Expr a b) [Match a b] | If (Expr a b) (Expr a b) (Expr a b) | Let (Binds a b) (Expr a b) | ListComp (Expr a b) [Qual a b] | ExplicitList [Expr a b] | ExplicitListOut UniType [Expr a b] | ExplicitTuple [Expr a b] | ExprWithTySig (Expr a b) (PolyType a) | ArithSeqIn (ArithSeqInfo a b) | ArithSeqOut (Expr a b) (ArithSeqInfo a b) | TyLam [TyVar] (Expr a b) | TyApp (Expr a b) [UniType] | DictLam [Id] (Expr a b) | DictApp (Expr a b) [Id] | ClassDictLam [Id] [Id] (Expr a b) | Dictionary [Id] [Id] | SingleDict Id #-}
-data Qual a b {-# GHC_PRAGMA GeneratorQual b (Expr a b) | FilterQual (Expr a b) #-}
-data IE {-# GHC_PRAGMA IEVar _PackedString | IEThingAbs _PackedString | IEThingAll _PackedString | IEConWithCons _PackedString [_PackedString] | IEClsWithOps _PackedString [_PackedString] | IEModuleContents _PackedString #-}
-data IfaceImportDecl {-# GHC_PRAGMA IfaceImportDecl _PackedString [IE] [Renaming] SrcLoc #-}
-data ImportedInterface a b {-# GHC_PRAGMA ImportAll (Interface a b) [Renaming] | ImportSome (Interface a b) [IE] [Renaming] | ImportButHide (Interface a b) [IE] [Renaming] #-}
-data Interface a b {-# GHC_PRAGMA MkInterface _PackedString [IfaceImportDecl] [FixityDecl a] [TyDecl a] [ClassDecl a b] [InstDecl a b] [Sig a] SrcLoc #-}
-data Renaming {-# GHC_PRAGMA MkRenaming _PackedString _PackedString #-}
-data Literal {-# GHC_PRAGMA CharLit Char | CharPrimLit Char | StringLit _PackedString | StringPrimLit _PackedString | IntLit Integer | FracLit (Ratio Integer) | LitLitLitIn _PackedString | LitLitLit _PackedString UniType | IntPrimLit Integer | FloatPrimLit (Ratio Integer) | DoublePrimLit (Ratio Integer) #-}
-data GRHS a b {-# GHC_PRAGMA GRHS (Expr a b) (Expr a b) SrcLoc | OtherwiseGRHS (Expr a b) SrcLoc #-}
-data GRHSsAndBinds a b {-# GHC_PRAGMA GRHSsAndBindsIn [GRHS a b] (Binds a b) | GRHSsAndBindsOut [GRHS a b] (Binds a b) UniType #-}
-data Match a b {-# GHC_PRAGMA PatMatch b (Match a b) | GRHSMatch (GRHSsAndBinds a b) #-}
-data InPat a {-# GHC_PRAGMA WildPatIn | VarPatIn a | LitPatIn Literal | LazyPatIn (InPat a) | AsPatIn a (InPat a) | ConPatIn a [InPat a] | ConOpPatIn (InPat a) a (InPat a) | ListPatIn [InPat a] | TuplePatIn [InPat a] | NPlusKPatIn a Literal #-}
-data TypecheckedPat {-# GHC_PRAGMA WildPat UniType | VarPat Id | LazyPat TypecheckedPat | AsPat Id TypecheckedPat | ConPat Id UniType [TypecheckedPat] | ConOpPat TypecheckedPat Id TypecheckedPat UniType | ListPat UniType [TypecheckedPat] | TuplePat [TypecheckedPat] | LitPat Literal UniType | NPat Literal UniType (Expr Id TypecheckedPat) | NPlusKPat Id Literal UniType (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) (Expr Id TypecheckedPat) #-}
-data ClassOpPragmas a {-# GHC_PRAGMA NoClassOpPragmas | ClassOpPragmas (GenPragmas a) (GenPragmas a) #-}
-data ClassPragmas a {-# GHC_PRAGMA NoClassPragmas | SuperDictPragmas [GenPragmas a] #-}
-data DataPragmas a {-# GHC_PRAGMA DataPragmas [ConDecl a] [[Labda (MonoType a)]] #-}
-data GenPragmas a {-# GHC_PRAGMA NoGenPragmas | GenPragmas (Labda Int) (Labda UpdateInfo) DeforestInfo (ImpStrictness a) (ImpUnfolding a) [([Labda (MonoType a)], Int, GenPragmas a)] #-}
-data ImpStrictness a {-# GHC_PRAGMA NoImpStrictness | ImpStrictness Bool [Demand] (GenPragmas a) #-}
-data ImpUnfolding a {-# GHC_PRAGMA NoImpUnfolding | ImpMagicUnfolding _PackedString | ImpUnfolding UnfoldingGuidance (UnfoldingCoreExpr a) #-}
-data InstancePragmas a {-# GHC_PRAGMA NoInstancePragmas | SimpleInstancePragma (GenPragmas a) | ConstantInstancePragma (GenPragmas a) [(a, GenPragmas a)] | SpecialisedInstancePragma (GenPragmas a) [([Labda (MonoType a)], Int, InstancePragmas a)] #-}
-data TypePragmas {-# GHC_PRAGMA NoTypePragmas | AbstractTySynonym #-}
-data MonoType a {-# GHC_PRAGMA MonoTyVar a | MonoTyCon a [MonoType a] | FunMonoTy (MonoType a) (MonoType a) | ListMonoTy (MonoType a) | TupleMonoTy [PolyType a] | MonoTyVarTemplate a | MonoDict a (MonoType a) #-}
-data PolyType a {-# GHC_PRAGMA UnoverloadedTy (MonoType a) | OverloadedTy [(a, a)] (MonoType a) | ForAllTy [a] (MonoType a) #-}
-data Id {-# GHC_PRAGMA Id Unique UniType IdInfo IdDetails #-}
-data IdDetails {-# GHC_PRAGMA LocalId ShortName Bool | SysLocalId ShortName Bool | SpecPragmaId ShortName (Labda SpecInfo) Bool | ImportedId FullName | PreludeId FullName | TopLevId FullName | DataConId FullName Int [TyVarTemplate] [(Class, UniType)] [UniType] TyCon | TupleConId Int | SuperDictSelId Class Class | ClassOpId Class ClassOp | DefaultMethodId Class ClassOp Bool | DictFunId Class UniType Bool | ConstMethodId Class UniType ClassOp Bool | InstId Inst | SpecId Id [Labda UniType] Bool | WorkerId Id #-}
-type IdEnv a = UniqFM a
-data ArgUsage {-# GHC_PRAGMA ArgUsage Int | UnknownArgUsage #-}
-data ArgUsageInfo {-# GHC_PRAGMA NoArgUsageInfo | SomeArgUsageInfo [ArgUsage] #-}
-data ArityInfo {-# GHC_PRAGMA UnknownArity | ArityExactly Int #-}
-data DeforestInfo {-# GHC_PRAGMA Don'tDeforest | DoDeforest #-}
-data Demand {-# GHC_PRAGMA WwLazy Bool | WwStrict | WwUnpack [Demand] | WwPrim | WwEnum #-}
-data DemandInfo {-# GHC_PRAGMA UnknownDemand | DemandedAsPer Demand #-}
-data FBConsum {-# GHC_PRAGMA FBGoodConsum | FBBadConsum #-}
-data FBProd {-# GHC_PRAGMA FBGoodProd | FBBadProd #-}
-data FBType {-# GHC_PRAGMA FBType [FBConsum] FBProd #-}
-data FBTypeInfo {-# GHC_PRAGMA NoFBTypeInfo | SomeFBTypeInfo FBType #-}
-data IdInfo {-# GHC_PRAGMA IdInfo ArityInfo DemandInfo SpecEnv StrictnessInfo UnfoldingDetails UpdateInfo DeforestInfo ArgUsageInfo FBTypeInfo SrcLoc #-}
-data SpecEnv {-# GHC_PRAGMA SpecEnv [SpecInfo] #-}
-data SpecInfo {-# GHC_PRAGMA SpecInfo [Labda UniType] Int Id #-}
-data StrictnessInfo {-# GHC_PRAGMA NoStrictnessInfo | BottomGuaranteed | StrictnessInfo [Demand] (Labda Id) #-}
-data UpdateInfo {-# GHC_PRAGMA NoUpdateInfo | SomeUpdateInfo [Int] #-}
-data Inst {-# GHC_PRAGMA Dict Unique Class UniType InstOrigin | Method Unique Id [UniType] InstOrigin | LitInst Unique OverloadedLit UniType InstOrigin #-}
-data InstOrigin {-# GHC_PRAGMA OccurrenceOf Id SrcLoc | InstanceDeclOrigin SrcLoc | LiteralOrigin Literal SrcLoc | ArithSeqOrigin (ArithSeqInfo Name (InPat Name)) SrcLoc | SignatureOrigin | ClassDeclOrigin SrcLoc | DerivingOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class Bool TyCon SrcLoc | InstanceSpecOrigin (Class -> ([(UniType, InstTemplate)], ClassOp -> SpecEnv)) Class UniType SrcLoc | DefaultDeclOrigin SrcLoc | ValSpecOrigin Name SrcLoc | CCallOrigin SrcLoc [Char] (Labda (Expr Name (InPat Name))) | LitLitOrigin SrcLoc [Char] | UnknownOrigin #-}
-data OverloadedLit {-# GHC_PRAGMA OverloadedIntegral Integer Id Id | OverloadedFractional (Ratio Integer) Id #-}
-data InstTemplate {-# GHC_PRAGMA MkInstTemplate Id [UniType] [InstTy] #-}
-data InstTy {-# GHC_PRAGMA DictTy Class UniType | MethodTy Id [UniType] #-}
-data MagicUnfoldingFun {-# GHC_PRAGMA MUF (SimplEnv -> [CoreArg Id] -> SplitUniqSupply -> SimplCount -> (Labda (CoreExpr Id Id), SimplCount)) #-}
+import Pretty(Delay, Pretty(..), PrettyRep)
data Labda a = Hamna | Ni a
-data Name {-# GHC_PRAGMA Short Unique ShortName | WiredInTyCon TyCon | WiredInVal Id | PreludeVal Unique FullName | PreludeTyCon Unique FullName Int Bool | PreludeClass Unique FullName | OtherTyCon Unique FullName Int Bool [Name] | OtherClass Unique FullName [Name] | OtherTopId Unique FullName | ClassOpName Unique Name _PackedString Int | Unbound _PackedString #-}
-data FullName {-# GHC_PRAGMA FullName _PackedString _PackedString Provenance ExportFlag Bool SrcLoc #-}
-data Provenance {-# GHC_PRAGMA ThisModule | InventedInThisModule | ExportedByPreludeCore | OtherPrelude _PackedString | OtherModule _PackedString [_PackedString] | HereInPreludeCore | OtherInstance _PackedString [_PackedString] #-}
-data ShortName {-# GHC_PRAGMA ShortName _PackedString SrcLoc #-}
-data OrdList a {-# GHC_PRAGMA SeqList (OrdList a) (OrdList a) | ParList (OrdList a) (OrdList a) | OrdObj a | NoObj #-}
-data ExportFlag {-# GHC_PRAGMA ExportAll | ExportAbs | NotExported #-}
-data Delay a {-# GHC_PRAGMA MkDelay a #-}
-data PprStyle {-# GHC_PRAGMA PprForUser | PprDebug | PprShowAll | PprInterface (GlobalSwitch -> Bool) | PprForC (GlobalSwitch -> Bool) | PprUnfolding (GlobalSwitch -> Bool) | PprForAsm (GlobalSwitch -> Bool) Bool ([Char] -> [Char]) #-}
type Pretty = Int -> Bool -> PrettyRep
-data PrettyRep {-# GHC_PRAGMA MkPrettyRep CSeq (Delay Int) Bool Bool #-}
-data PrimKind {-# GHC_PRAGMA PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind #-}
-data PrimOp
- {-# GHC_PRAGMA CharGtOp | CharGeOp | CharEqOp | CharNeOp | CharLtOp | CharLeOp | IntGtOp | IntGeOp | IntEqOp | IntNeOp | IntLtOp | IntLeOp | WordGtOp | WordGeOp | WordEqOp | WordNeOp | WordLtOp | WordLeOp | AddrGtOp | AddrGeOp | AddrEqOp | AddrNeOp | AddrLtOp | AddrLeOp | FloatGtOp | FloatGeOp | FloatEqOp | FloatNeOp | FloatLtOp | FloatLeOp | DoubleGtOp | DoubleGeOp | DoubleEqOp | DoubleNeOp | DoubleLtOp | DoubleLeOp | OrdOp | ChrOp | IntAddOp | IntSubOp | IntMulOp | IntQuotOp | IntDivOp | IntRemOp | IntNegOp | IntAbsOp | AndOp | OrOp | NotOp | SllOp | SraOp | SrlOp | ISllOp | ISraOp | ISrlOp | Int2WordOp | Word2IntOp | Int2AddrOp | Addr2IntOp | FloatAddOp | FloatSubOp | FloatMulOp | FloatDivOp | FloatNegOp | Float2IntOp | Int2FloatOp | FloatExpOp | FloatLogOp | FloatSqrtOp | FloatSinOp | FloatCosOp | FloatTanOp | FloatAsinOp | FloatAcosOp | FloatAtanOp | FloatSinhOp | FloatCoshOp | FloatTanhOp | FloatPowerOp | DoubleAddOp | DoubleSubOp | DoubleMulOp | DoubleDivOp | DoubleNegOp | Double2IntOp | Int2DoubleOp | Double2FloatOp | Float2DoubleOp | DoubleExpOp | DoubleLogOp | DoubleSqrtOp | DoubleSinOp | DoubleCosOp | DoubleTanOp | DoubleAsinOp | DoubleAcosOp | DoubleAtanOp | DoubleSinhOp | DoubleCoshOp | DoubleTanhOp | DoublePowerOp | IntegerAddOp | IntegerSubOp | IntegerMulOp | IntegerQuotRemOp | IntegerDivModOp | IntegerNegOp | IntegerCmpOp | Integer2IntOp | Int2IntegerOp | Word2IntegerOp | Addr2IntegerOp | FloatEncodeOp | FloatDecodeOp | DoubleEncodeOp | DoubleDecodeOp | NewArrayOp | NewByteArrayOp PrimKind | SameMutableArrayOp | SameMutableByteArrayOp | ReadArrayOp | WriteArrayOp | IndexArrayOp | ReadByteArrayOp PrimKind | WriteByteArrayOp PrimKind | IndexByteArrayOp PrimKind | IndexOffAddrOp PrimKind | UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp | NewSynchVarOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp | MakeStablePtrOp | DeRefStablePtrOp | CCallOp _PackedString Bool Bool [UniType] UniType | ErrorIOPrimOp | ReallyUnsafePtrEqualityOp | SeqOp | ParOp | ForkOp | DelayOp | WaitOp #-}
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
-data SMRep {-# GHC_PRAGMA StaticRep Int Int | SpecialisedRep SMSpecRepKind Int Int SMUpdateKind | GenericRep Int Int SMUpdateKind | BigTupleRep Int | DataRep Int | DynamicRep | BlackHoleRep | PhantomRep | MuTupleRep Int #-}
-data SMSpecRepKind {-# GHC_PRAGMA SpecRep | ConstantRep | CharLikeRep | IntLikeRep #-}
-data SMUpdateKind {-# GHC_PRAGMA SMNormalForm | SMSingleEntry | SMUpdatable #-}
-data EnclosingCcDetails {-# GHC_PRAGMA NoEnclosingCcDetails | EnclosingCC CostCentre #-}
-data FormSummary {-# GHC_PRAGMA WhnfForm | BottomForm | OtherForm #-}
-data IdVal {-# GHC_PRAGMA InlineIt (UniqFM IdVal) (UniqFM UniType) (CoreExpr (Id, BinderInfo) Id) | ItsAnAtom (CoreAtom Id) #-}
-data SimplEnv {-# GHC_PRAGMA SimplEnv (SimplifierSwitch -> SwitchResult) EnclosingCcDetails (UniqFM UniType) (UniqFM IdVal) UnfoldEnv #-}
-data UnfoldConApp {-# GHC_PRAGMA UCA Id [UniType] [CoreAtom Id] #-}
-data UnfoldEnv {-# GHC_PRAGMA UFE (UniqFM UnfoldItem) (UniqFM Id) (FiniteMap UnfoldConApp Id) #-}
-data UnfoldItem {-# GHC_PRAGMA UnfoldItem Id UnfoldingDetails EnclosingCcDetails #-}
-data UnfoldingDetails {-# GHC_PRAGMA NoUnfoldingDetails | LiteralForm BasicLit | OtherLiteralForm [BasicLit] | ConstructorForm Id [UniType] [CoreAtom Id] | OtherConstructorForm [Id] | GeneralForm Bool FormSummary (CoreExpr (Id, BinderInfo) Id) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun | IWantToBeINLINEd UnfoldingGuidance #-}
-data UnfoldingGuidance {-# GHC_PRAGMA UnfoldNever | UnfoldAlways | EssentialUnfolding | UnfoldIfGoodArgs Int Int [Bool] Int #-}
-data SimplCount {-# GHC_PRAGMA SimplCount Int# [(TickType, Int)] #-}
-data TickType {-# GHC_PRAGMA UnfoldingDone | FoldrBuild | MagicUnfold | ConReused | CaseFloatFromLet | CaseOfCase | LetFloatFromLet | LetFloatFromCase | KnownBranch | Let2Case | CaseMerge | CaseElim | CaseIdentity | AtomicRhs | EtaExpansion | CaseOfError | FoldrConsNil | Foldr_Nil | FoldrFoldr | Foldr_List | FoldrCons | FoldrInline | TyBetaReduction | BetaReduction #-}
-data SplitUniqSupply {-# GHC_PRAGMA MkSplitUniqSupply Int SplitUniqSupply SplitUniqSupply #-}
-data SrcLoc {-# GHC_PRAGMA SrcLoc _PackedString _PackedString | SrcLoc2 _PackedString Int# #-}
-data StgAtom a {-# GHC_PRAGMA StgVarAtom a | StgLitAtom BasicLit #-}
-data StgBinderInfo {-# GHC_PRAGMA NoStgBinderInfo | StgBinderInfo Bool Bool Bool Bool Bool #-}
-data StgBinding a b {-# GHC_PRAGMA StgNonRec a (StgRhs a b) | StgRec [(a, StgRhs a b)] #-}
-data StgCaseAlternatives a b {-# GHC_PRAGMA StgAlgAlts UniType [(Id, [a], [Bool], StgExpr a b)] (StgCaseDefault a b) | StgPrimAlts UniType [(BasicLit, StgExpr a b)] (StgCaseDefault a b) #-}
-data StgCaseDefault a b {-# GHC_PRAGMA StgNoDefault | StgBindDefault a Bool (StgExpr a b) #-}
-data StgExpr a b {-# GHC_PRAGMA StgApp (StgAtom b) [StgAtom b] (UniqFM b) | StgConApp Id [StgAtom b] (UniqFM b) | StgPrimApp PrimOp [StgAtom b] (UniqFM b) | StgCase (StgExpr a b) (UniqFM b) (UniqFM b) Unique (StgCaseAlternatives a b) | StgLet (StgBinding a b) (StgExpr a b) | StgLetNoEscape (UniqFM b) (UniqFM b) (StgBinding a b) (StgExpr a b) | StgSCC UniType CostCentre (StgExpr a b) #-}
-data StgRhs a b {-# GHC_PRAGMA StgRhsClosure CostCentre StgBinderInfo [b] UpdateFlag [a] (StgExpr a b) | StgRhsCon CostCentre Id [StgAtom b] #-}
-data UpdateFlag {-# GHC_PRAGMA ReEntrant | Updatable | SingleEntry #-}
-data TyCon {-# GHC_PRAGMA SynonymTyCon Unique FullName Int [TyVarTemplate] UniType Bool | DataTyCon Unique FullName Int [TyVarTemplate] [Id] [Class] Bool | TupleTyCon Int | PrimTyCon Unique FullName Int ([PrimKind] -> PrimKind) | SpecTyCon TyCon [Labda UniType] #-}
-data TyVar {-# GHC_PRAGMA PrimSysTyVar Unique | PolySysTyVar Unique | OpenSysTyVar Unique | UserTyVar Unique ShortName #-}
-data TyVarTemplate {-# GHC_PRAGMA SysTyVarTemplate Unique _PackedString | UserTyVarTemplate Unique ShortName #-}
-type TyVarEnv a = UniqFM a
-data UniType {-# GHC_PRAGMA UniTyVar TyVar | UniFun UniType UniType | UniData TyCon [UniType] | UniSyn TyCon [UniType] UniType | UniDict Class UniType | UniTyVarTemplate TyVarTemplate | UniForall TyVarTemplate UniType #-}
-data UniqFM a {-# GHC_PRAGMA EmptyUFM | LeafUFM Int# a | NodeUFM Int# Int# (UniqFM a) (UniqFM a) #-}
-data Unique {-# GHC_PRAGMA MkUnique Int# #-}
-data UniqueSupply {-# GHC_PRAGMA MkUniqueSupply Int# | MkNewSupply SplitUniqSupply #-}
+data PrettyRep
+assertPanic :: [Char] -> Int -> a
assoc :: Eq a => [Char] -> [(a, b)] -> a -> b
- {-# GHC_PRAGMA _A_ 4 _U_ 1212 _N_ _S_ "LLSL" _N_ _SPECIALISE_ [ [Char], _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ UniType, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ _PackedString, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ TyVarTemplate, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ TyVar, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ TyCon, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ PrimKind, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ Name, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ Class, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ }, [ Id, _N_ ] 1 { _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ } #-}
-emptyBag :: Bag a
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ Bag EmptyBag [u0] [] _N_ #-}
-snocBag :: Bag a -> a -> Bag a
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
-kindOfBasicLit :: BasicLit -> PrimKind
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-typeOfBasicLit :: BasicLit -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-cAppend :: CSeq -> CSeq -> CSeq
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 3 \ (u0 :: CSeq) (u1 :: CSeq) -> _!_ _ORIG_ CharSeq CAppend [] [u0, u1] _N_ #-}
-cCh :: Char -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Char) -> _!_ _ORIG_ CharSeq CCh [] [u0] _N_ #-}
-cNil :: CSeq
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _!_ _ORIG_ CharSeq CNil [] [] _N_ #-}
-cPStr :: _PackedString -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: _PackedString) -> _!_ _ORIG_ CharSeq CPStr [] [u0] _N_ #-}
-cShow :: CSeq -> [Char]
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
-cStr :: [Char] -> CSeq
- {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: [Char]) -> _!_ _ORIG_ CharSeq CStr [] [u0] _N_ #-}
-emptyFM :: FiniteMap a b
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 2 0 X 1 _/\_ u0 u1 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, u1] [] _N_ #-}
-cmpId :: Id -> Id -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-eqId :: Id -> Id -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(P)AAA)U(U(P)AAA)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Int#) (u1 :: Int#) -> case _APP_ _WRKR_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_} _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Id) (u1 :: Id) -> case _APP_ _ORIG_ Id cmpId [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-}
-getIdKind :: Id -> PrimKind
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 C 9 \ (u0 :: UniType) -> case u0 of { _ALG_ (u1 :: UniType) -> _APP_ _ORIG_ UniTyFuns kindFromType [ u1 ] } _N_} _F_ _IF_ARGS_ 0 1 C 5 \ (u0 :: Id) -> let {(u5 :: UniType) = case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ }} in _APP_ _ORIG_ UniTyFuns kindFromType [ u5 ] _N_ #-}
-getIdUniType :: Id -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(ASAA)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 1 \ (u0 :: UniType) -> u0 _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: Id) -> case u0 of { _ALG_ _ORIG_ Id Id (u1 :: Unique) (u2 :: UniType) (u3 :: IdInfo) (u4 :: IdDetails) -> u2; _NO_DEFLT_ } _N_ #-}
-cmpName :: Name -> Name -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-eqName :: Name -> Name -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _F_ _IF_ARGS_ 0 2 XX 5 \ (u0 :: Name) (u1 :: Name) -> case _APP_ _ORIG_ Name cmpName [ u0, u1 ] of { _PRIM_ 0# -> _!_ True [] []; (u2 :: Int#) -> _!_ False [] [] } _N_ #-}
-cmpByLocalName :: ProtoName -> ProtoName -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
cmpPString :: _PackedString -> _PackedString -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-cmpProtoName :: ProtoName -> ProtoName -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-eqByLocalName :: ProtoName -> ProtoName -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-eqProtoName :: ProtoName -> ProtoName -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
-cmpUnique :: Unique -> Unique -> Int#
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _ALWAYS_ \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> case _#_ eqInt# [] [u2, u3] of { _ALG_ True -> 0#; False -> case _#_ ltInt# [] [u2, u3] of { _ALG_ True -> -1#; False -> 1#; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
-eqUnique :: Unique -> Unique -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SS" _F_ _ALWAYS_ \ (u0 :: Unique) (u1 :: Unique) -> case u0 of { _ALG_ _ORIG_ Unique MkUnique (u2 :: Int#) -> case u1 of { _ALG_ _ORIG_ Unique MkUnique (u3 :: Int#) -> _#_ eqInt# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_ #-}
equivClasses :: (a -> a -> Int#) -> [a] -> [[a]]
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
hasNoDups :: Eq a => [a] -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _N_ _N_ _SPECIALISE_ [ TyVar ] 1 { _A_ 1 _U_ 1 _N_ _N_ _N_ _N_ } #-}
isIn :: Eq a => [Char] -> a -> [a] -> Bool
- {-# GHC_PRAGMA _A_ 4 _U_ 1021 _N_ _S_ "LALS" {_A_ 3 _U_ 121 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ _PackedString ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyVarTemplate ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyVar ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Name ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Class ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Id ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ BasicLit ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ MagicId ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Unique ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
isSingleton :: [a] -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
isn'tIn :: Eq a => [Char] -> a -> [a] -> Bool
- {-# GHC_PRAGMA _A_ 4 _U_ 1021 _N_ _S_ "LALS" {_A_ 3 _U_ 121 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyVarTemplate ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyVar ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ TyCon ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ Id ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ MagicId ] 1 { _A_ 3 _U_ 021 _N_ _S_ "ALS" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ }, [ (Id, Id) ] 1 { _A_ 0 _U_ 021 _N_ _N_ _N_ _N_ } #-}
-kindFromType :: UniType -> PrimKind
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
lengthExceeds :: [a] -> Int -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SU(P)" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_ #-}
mapAccumB :: (b -> c -> a -> (b, c, d)) -> b -> c -> [a] -> (b, c, [d])
- {-# GHC_PRAGMA _A_ 4 _U_ 2221 _N_ _S_ "LLLS" _N_ _N_ #-}
mapAccumL :: (b -> a -> (b, c)) -> b -> [a] -> (b, [c])
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
mapAccumR :: (b -> a -> (b, c)) -> b -> [a] -> (b, [c])
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
-mkUnknownSrcLoc :: SrcLoc
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
nOfThem :: Int -> a -> [a]
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
naturalMergeSortLe :: (a -> a -> Bool) -> [a] -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _N_ _N_ #-}
-nullSpecEnv :: SpecEnv
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
panic :: [Char] -> a
- {-# GHC_PRAGMA _A_ 0 _U_ 2 _N_ _S_ _!_ _N_ _N_ #-}
-pprCoreBinding :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreBinding a b -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 2222122 _N_ _S_ "LLLLS" _N_ _N_ #-}
-pprCoreExpr :: PprStyle -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> a -> Int -> Bool -> PrettyRep) -> (PprStyle -> b -> Int -> Bool -> PrettyRep) -> CoreExpr a b -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 5 _U_ 2222222 _N_ _S_ "LLLLS" _N_ _N_ #-}
-ppDouble :: Double -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-}
-ppInt :: Int -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 110 _N_ _S_ "LLA" {_A_ 2 _U_ 11 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-ppInteger :: Integer -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-}
-ppNil :: Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 10 _N_ _S_ "LA" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
-ppRational :: Ratio Integer -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 1 _U_ 110 _N_ _N_ _N_ _N_ #-}
-ppStr :: [Char] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 210 _N_ _S_ "LLA" {_A_ 2 _U_ 21 _N_ _N_ _N_ _N_} _N_ _N_ #-}
pprPanic :: [Char] -> (Int -> Bool -> PrettyRep) -> a
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ _!_ _N_ _N_ #-}
-pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-}
pprTrace :: [Char] -> (Int -> Bool -> PrettyRep) -> a -> a
- {-# GHC_PRAGMA _A_ 2 _U_ 112 _N_ _N_ _N_ _N_ #-}
-switchIsOn :: (a -> SwitchResult) -> a -> Bool
- {-# GHC_PRAGMA _A_ 2 _U_ 12 _N_ _S_ "SL" _N_ _N_ #-}
-typeOfPat :: TypecheckedPat -> UniType
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-tagOf_PrimOp :: PrimOp -> Int#
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-pprTyCon :: PprStyle -> TyCon -> [[Labda UniType]] -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 3 _U_ 22222 _N_ _S_ "SSL" _N_ _N_ #-}
-pprUniType :: PprStyle -> UniType -> Int -> Bool -> PrettyRep
- {-# GHC_PRAGMA _A_ 2 _U_ 2222 _N_ _S_ "LS" _N_ _N_ #-}
removeDups :: (a -> a -> Int#) -> [a] -> ([a], [[a]])
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _N_ _N_ #-}
runs :: (a -> a -> Bool) -> [a] -> [[a]]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
-showUnique :: Unique -> _PackedString
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
sortLt :: (a -> a -> Bool) -> [a] -> [a]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
transitiveClosure :: (a -> [a]) -> (a -> a -> Bool) -> [a] -> [a]
- {-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LS" _N_ _N_ #-}
zipEqual :: [a] -> [b] -> [(a, b)]
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "SL" _N_ _N_ #-}
To: partain@dcs.gla.ac.uk
Subject: natural merge sort beats quick sort [ and it is prettier ]
- Here a piece of Haskell code that I'm rather fond of. See it as an
-attempt to get rid of the ridiculous quick-sort rutine. group is quite
-useful by itself I think it was John's idea originally though I
+Here a piece of Haskell code that I'm rather fond of. See it as an
+attempt to get rid of the ridiculous quick-sort routine. group is
+quite useful by itself I think it was John's idea originally though I
believe the lazy version is due to me [surprisingly complicated].
-gamma [used to be called] called gamma because I got inspired by the Gamma calculus. It
-is not very close to the calculus but does behave less sequential that
-both foldr and foldl. One could imagine a version of gamma that took a
-unit element as well thereby avoiding the problem with empty lists.
+gamma [used to be called] is called gamma because I got inspired by
+the Gamma calculus. It is not very close to the calculus but does
+behave less sequential that both foldr and foldl. One could imagine a
+version of gamma that took a unit element as well thereby avoiding the
+problem with empty lists.
I've tried this code against
natural merge sort wins. If the list is random [ average length of
rising subsequences = approx 2 ] mergesort still wins and natural
merge sort is marginally beeten by lennart's soqs. The space
-consumption of merge sort is a bit worse than Lennarts quick sort
+consumption of merge sort is a bit worse than Lennart's quick sort
approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
fpca article ] isn't used because of group.
\begin{code}
group :: (a -> a -> Bool) -> [a] -> [[a]]
+
group p [] = [[]]
group p (x:xs) =
let ((h1:t1):tt1) = group p xs
generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
generalMerge p xs [] = xs
generalMerge p [] ys = ys
-generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
- | y `p` x = y : generalMerge p (x:xs) ys
+generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
+ | otherwise = y : generalMerge p (x:xs) ys
-- gamma is now called balancedFold
balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
balancedFold' f xs = xs
-generalMergeSort p = balancedFold (generalMerge p) . map (:[])
-generalNaturalMergeSort p = balancedFold (generalMerge p) . group p
+generalMergeSort p [] = []
+generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
+
+generalNaturalMergeSort p [] = []
+generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
import U_list(U_list)
data U_atype = U_atc ProtoName U_list Int
rdU_atype :: _Addr -> _PackedString -> _State _RealWorld -> (U_atype, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import U_hpragma(U_hpragma)
import U_list(U_list)
import U_ttype(U_ttype)
-data U_binding = U_tbind U_list U_ttype U_list U_list Int U_hpragma | U_nbind U_ttype U_ttype Int U_hpragma | U_pbind U_list Int | U_fbind U_list Int | U_abind U_binding U_binding | U_lbind U_binding U_binding | U_ebind U_list U_binding Int | U_hbind U_list U_binding Int | U_ibind U_list ProtoName U_ttype U_binding Int U_hpragma | U_dbind U_list Int | U_cbind U_list U_ttype U_binding Int U_hpragma | U_sbind U_list U_ttype Int U_hpragma | U_mbind _PackedString U_list U_list Int | U_nullbind | U_import _PackedString U_list U_list U_binding _PackedString Int | U_hiding _PackedString U_list U_list U_binding _PackedString Int | U_vspec_uprag ProtoName U_list Int | U_vspec_ty_and_id U_ttype U_list | U_ispec_uprag ProtoName U_ttype Int | U_inline_uprag ProtoName U_list Int | U_deforest_uprag ProtoName Int | U_magicuf_uprag ProtoName _PackedString Int | U_abstract_uprag ProtoName Int | U_dspec_uprag ProtoName U_list Int
+data U_binding = U_tbind U_list U_ttype U_list U_list Int U_hpragma | U_nbind U_ttype U_ttype Int U_hpragma | U_pbind U_list Int | U_fbind U_list Int | U_abind U_binding U_binding | U_ibind U_list ProtoName U_ttype U_binding Int U_hpragma | U_dbind U_list Int | U_cbind U_list U_ttype U_binding Int U_hpragma | U_sbind U_list U_ttype Int U_hpragma | U_mbind _PackedString U_list U_list Int | U_nullbind | U_import _PackedString U_list U_list U_binding _PackedString Int | U_hiding _PackedString U_list U_list U_binding _PackedString Int | U_vspec_uprag ProtoName U_list Int | U_vspec_ty_and_id U_ttype U_list | U_ispec_uprag ProtoName U_ttype Int | U_inline_uprag ProtoName U_list Int | U_deforest_uprag ProtoName Int | U_magicuf_uprag ProtoName _PackedString Int | U_abstract_uprag ProtoName Int | U_dspec_uprag ProtoName U_list Int
rdU_binding :: _Addr -> _PackedString -> _State _RealWorld -> (U_binding, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
data U_coresyn
= U_cobinder ProtoName U_ttype | U_colit U_literal | U_colocal U_coresyn | U_cononrec U_coresyn U_coresyn | U_corec U_list | U_corec_pair U_coresyn U_coresyn | U_covar U_coresyn | U_coliteral U_literal | U_cocon U_coresyn U_list U_list | U_coprim U_coresyn U_list U_list | U_colam U_list U_coresyn | U_cotylam U_list U_coresyn | U_coapp U_coresyn U_list | U_cotyapp U_coresyn U_ttype | U_cocase U_coresyn U_coresyn | U_colet U_coresyn U_coresyn | U_coscc U_coresyn U_coresyn | U_coalg_alts U_list U_coresyn | U_coalg_alt U_coresyn U_list U_coresyn | U_coprim_alts U_list U_coresyn | U_coprim_alt U_literal U_coresyn | U_conodeflt | U_cobinddeflt U_coresyn U_coresyn | U_co_primop _PackedString | U_co_ccall _PackedString Int U_list U_ttype | U_co_casm U_literal Int U_list U_ttype | U_co_preludedictscc U_coresyn | U_co_alldictscc _PackedString _PackedString U_coresyn | U_co_usercc _PackedString _PackedString _PackedString U_coresyn U_coresyn | U_co_autocc U_coresyn _PackedString _PackedString U_coresyn U_coresyn | U_co_dictcc U_coresyn _PackedString _PackedString U_coresyn U_coresyn | U_co_scc_noncaf | U_co_scc_caf | U_co_scc_nondupd | U_co_scc_dupd | U_co_id _PackedString | U_co_orig_id _PackedString _PackedString | U_co_sdselid ProtoName ProtoName | U_co_classopid ProtoName ProtoName | U_co_defmid ProtoName ProtoName | U_co_dfunid ProtoName U_ttype | U_co_constmid ProtoName ProtoName U_ttype | U_co_specid U_coresyn U_list | U_co_wrkrid U_coresyn
rdU_coresyn :: _Addr -> _PackedString -> _State _RealWorld -> (U_coresyn, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import U_list(U_list)
data U_entidt = U_entid _PackedString | U_enttype _PackedString | U_enttypeall _PackedString | U_enttypecons _PackedString U_list | U_entclass _PackedString U_list | U_entmod _PackedString
rdU_entidt :: _Addr -> _PackedString -> _State _RealWorld -> (U_entidt, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface U_finfot where
import PreludePS(_PackedString)
-data U_finfot = U_nofinfo | U_finfo _PackedString _PackedString
+data U_finfot = U_finfo _PackedString _PackedString
rdU_finfot :: _Addr -> _PackedString -> _State _RealWorld -> (U_finfot, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import U_list(U_list)
data U_hpragma = U_no_pragma | U_idata_pragma U_list U_list | U_itype_pragma | U_iclas_pragma U_list | U_iclasop_pragma U_hpragma U_hpragma | U_iinst_simpl_pragma _PackedString U_hpragma | U_iinst_const_pragma _PackedString U_hpragma U_list | U_iinst_spec_pragma _PackedString U_hpragma U_list | U_igen_pragma U_hpragma U_hpragma U_hpragma U_hpragma U_hpragma U_list | U_iarity_pragma Int | U_iupdate_pragma _PackedString | U_ideforest_pragma | U_istrictness_pragma _PackedString U_hpragma | U_imagic_unfolding_pragma _PackedString | U_iunfolding_pragma U_hpragma U_coresyn | U_iunfold_always | U_iunfold_if_args Int Int _PackedString Int | U_iname_pragma_pr ProtoName U_hpragma | U_itype_pragma_pr U_list Int U_hpragma | U_iinst_pragma_3s U_list Int U_hpragma U_list | U_idata_pragma_4s U_list
rdU_hpragma :: _Addr -> _PackedString -> _State _RealWorld -> (U_hpragma, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import PreludePS(_PackedString)
data U_list = U_lcons _Addr U_list | U_lnil
rdU_list :: _Addr -> _PackedString -> _State _RealWorld -> (U_list, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import PreludePS(_PackedString)
data U_literal = U_integer _PackedString | U_intprim _PackedString | U_floatr _PackedString | U_doubleprim _PackedString | U_floatprim _PackedString | U_charr _PackedString | U_charprim _PackedString | U_string _PackedString | U_stringprim _PackedString | U_clitlit _PackedString _PackedString | U_norepi _PackedString | U_norepr _PackedString _PackedString | U_noreps _PackedString
rdU_literal :: _Addr -> _PackedString -> _State _RealWorld -> (U_literal, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import U_treeHACK(U_tree)
data U_pbinding = U_pgrhs U_tree U_list U_binding _PackedString Int
rdU_pbinding :: _Addr -> _PackedString -> _State _RealWorld -> (U_pbinding, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
type U_infixTree = (ProtoName, U_tree, U_tree)
data U_tree = U_hmodule _PackedString U_list U_list U_binding Int | U_ident ProtoName | U_lit U_literal | U_tuple U_list | U_ap U_tree U_tree | U_lambda U_list U_tree Int | U_let U_binding U_tree | U_casee U_tree U_list | U_ife U_tree U_tree U_tree | U_par U_tree | U_as ProtoName U_tree | U_lazyp U_tree | U_plusp U_tree U_literal | U_wildp | U_restr U_tree U_ttype | U_comprh U_tree U_list | U_qual U_tree U_tree | U_guard U_tree | U_def U_tree | U_tinfixop (ProtoName, U_tree, U_tree) | U_lsection U_tree ProtoName | U_rsection ProtoName U_tree | U_eenum U_tree U_list U_list | U_llist U_list | U_ccall _PackedString _PackedString U_list | U_scc _PackedString U_tree | U_negate U_tree
rdU_infixTree :: _Addr -> _PackedString -> _State _RealWorld -> ((ProtoName, U_tree, U_tree), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_tree :: _Addr -> _PackedString -> _State _RealWorld -> (U_tree, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
import U_list(U_list)
data U_ttype = U_tname ProtoName U_list | U_namedtvar ProtoName | U_tllist U_ttype | U_ttuple U_list | U_tfun U_ttype U_ttype | U_context U_list U_ttype | U_unidict ProtoName U_ttype | U_unityvartemplate ProtoName | U_uniforall U_list U_ttype | U_ty_maybe_nothing | U_ty_maybe_just U_ttype
rdU_ttype :: _Addr -> _PackedString -> _State _RealWorld -> (U_ttype, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
interface UgenAll where
import PreludePS(_PackedString)
import PreludePrimIO(returnPrimIO, thenPrimIO)
-import ProtoName(ProtoName)
+import ProtoName(ProtoName(..))
import SrcLoc(SrcLoc)
import U_atype(U_atype(..), rdU_atype)
import U_binding(U_binding(..), rdU_binding)
import U_ttype(U_ttype(..), rdU_ttype)
import UgenUtil(ParseTree(..), U_VOID_STAR(..), U_hstring(..), U_long(..), U_numId(..), U_stringId(..), U_unkId(..), UgnM(..), getSrcFileUgn, initUgn, ioToUgnM, mkSrcLocUgn, rdU_VOID_STAR, rdU_hstring, rdU_long, rdU_numId, rdU_stringId, rdU_unkId, returnUgn, setSrcFileUgn, thenUgn)
infixr 1 `thenPrimIO`
+data ProtoName
data U_atype = U_atc ProtoName U_list Int
-data U_binding = U_tbind U_list U_ttype U_list U_list Int U_hpragma | U_nbind U_ttype U_ttype Int U_hpragma | U_pbind U_list Int | U_fbind U_list Int | U_abind U_binding U_binding | U_lbind U_binding U_binding | U_ebind U_list U_binding Int | U_hbind U_list U_binding Int | U_ibind U_list ProtoName U_ttype U_binding Int U_hpragma | U_dbind U_list Int | U_cbind U_list U_ttype U_binding Int U_hpragma | U_sbind U_list U_ttype Int U_hpragma | U_mbind _PackedString U_list U_list Int | U_nullbind | U_import _PackedString U_list U_list U_binding _PackedString Int | U_hiding _PackedString U_list U_list U_binding _PackedString Int | U_vspec_uprag ProtoName U_list Int | U_vspec_ty_and_id U_ttype U_list | U_ispec_uprag ProtoName U_ttype Int | U_inline_uprag ProtoName U_list Int | U_deforest_uprag ProtoName Int | U_magicuf_uprag ProtoName _PackedString Int | U_abstract_uprag ProtoName Int | U_dspec_uprag ProtoName U_list Int
+data U_binding = U_tbind U_list U_ttype U_list U_list Int U_hpragma | U_nbind U_ttype U_ttype Int U_hpragma | U_pbind U_list Int | U_fbind U_list Int | U_abind U_binding U_binding | U_ibind U_list ProtoName U_ttype U_binding Int U_hpragma | U_dbind U_list Int | U_cbind U_list U_ttype U_binding Int U_hpragma | U_sbind U_list U_ttype Int U_hpragma | U_mbind _PackedString U_list U_list Int | U_nullbind | U_import _PackedString U_list U_list U_binding _PackedString Int | U_hiding _PackedString U_list U_list U_binding _PackedString Int | U_vspec_uprag ProtoName U_list Int | U_vspec_ty_and_id U_ttype U_list | U_ispec_uprag ProtoName U_ttype Int | U_inline_uprag ProtoName U_list Int | U_deforest_uprag ProtoName Int | U_magicuf_uprag ProtoName _PackedString Int | U_abstract_uprag ProtoName Int | U_dspec_uprag ProtoName U_list Int
data U_coresyn
= U_cobinder ProtoName U_ttype | U_colit U_literal | U_colocal U_coresyn | U_cononrec U_coresyn U_coresyn | U_corec U_list | U_corec_pair U_coresyn U_coresyn | U_covar U_coresyn | U_coliteral U_literal | U_cocon U_coresyn U_list U_list | U_coprim U_coresyn U_list U_list | U_colam U_list U_coresyn | U_cotylam U_list U_coresyn | U_coapp U_coresyn U_list | U_cotyapp U_coresyn U_ttype | U_cocase U_coresyn U_coresyn | U_colet U_coresyn U_coresyn | U_coscc U_coresyn U_coresyn | U_coalg_alts U_list U_coresyn | U_coalg_alt U_coresyn U_list U_coresyn | U_coprim_alts U_list U_coresyn | U_coprim_alt U_literal U_coresyn | U_conodeflt | U_cobinddeflt U_coresyn U_coresyn | U_co_primop _PackedString | U_co_ccall _PackedString Int U_list U_ttype | U_co_casm U_literal Int U_list U_ttype | U_co_preludedictscc U_coresyn | U_co_alldictscc _PackedString _PackedString U_coresyn | U_co_usercc _PackedString _PackedString _PackedString U_coresyn U_coresyn | U_co_autocc U_coresyn _PackedString _PackedString U_coresyn U_coresyn | U_co_dictcc U_coresyn _PackedString _PackedString U_coresyn U_coresyn | U_co_scc_noncaf | U_co_scc_caf | U_co_scc_nondupd | U_co_scc_dupd | U_co_id _PackedString | U_co_orig_id _PackedString _PackedString | U_co_sdselid ProtoName ProtoName | U_co_classopid ProtoName ProtoName | U_co_defmid ProtoName ProtoName | U_co_dfunid ProtoName U_ttype | U_co_constmid ProtoName ProtoName U_ttype | U_co_specid U_coresyn U_list | U_co_wrkrid U_coresyn
data U_entidt = U_entid _PackedString | U_enttype _PackedString | U_enttypeall _PackedString | U_enttypecons _PackedString U_list | U_entclass _PackedString U_list | U_entmod _PackedString
-data U_finfot = U_nofinfo | U_finfo _PackedString _PackedString
+data U_finfot = U_finfo _PackedString _PackedString
data U_hpragma = U_no_pragma | U_idata_pragma U_list U_list | U_itype_pragma | U_iclas_pragma U_list | U_iclasop_pragma U_hpragma U_hpragma | U_iinst_simpl_pragma _PackedString U_hpragma | U_iinst_const_pragma _PackedString U_hpragma U_list | U_iinst_spec_pragma _PackedString U_hpragma U_list | U_igen_pragma U_hpragma U_hpragma U_hpragma U_hpragma U_hpragma U_list | U_iarity_pragma Int | U_iupdate_pragma _PackedString | U_ideforest_pragma | U_istrictness_pragma _PackedString U_hpragma | U_imagic_unfolding_pragma _PackedString | U_iunfolding_pragma U_hpragma U_coresyn | U_iunfold_always | U_iunfold_if_args Int Int _PackedString Int | U_iname_pragma_pr ProtoName U_hpragma | U_itype_pragma_pr U_list Int U_hpragma | U_iinst_pragma_3s U_list Int U_hpragma U_list | U_idata_pragma_4s U_list
data U_list = U_lcons _Addr U_list | U_lnil
data U_literal = U_integer _PackedString | U_intprim _PackedString | U_floatr _PackedString | U_doubleprim _PackedString | U_floatprim _PackedString | U_charr _PackedString | U_charprim _PackedString | U_string _PackedString | U_stringprim _PackedString | U_clitlit _PackedString _PackedString | U_norepi _PackedString | U_norepr _PackedString _PackedString | U_noreps _PackedString
type U_unkId = ProtoName
type UgnM a = _PackedString -> _State _RealWorld -> (a, _State _RealWorld)
returnPrimIO :: a -> _State _RealWorld -> (a, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [u0, (_State _RealWorld)] [u1, u2]; _NO_DEFLT_ } _N_ #-}
thenPrimIO :: (_State _RealWorld -> (a, _State _RealWorld)) -> (a -> _State _RealWorld -> (b, _State _RealWorld)) -> _State _RealWorld -> (b, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: u0 -> _State _RealWorld -> (u1, _State _RealWorld)) (u4 :: _State _RealWorld) -> case _APP_ u2 [ u4 ] of { _ALG_ _TUP_2 (u5 :: u0) (u6 :: _State _RealWorld) -> _APP_ u3 [ u5, u6 ]; _NO_DEFLT_ } _N_ #-}
rdU_atype :: _Addr -> _PackedString -> _State _RealWorld -> (U_atype, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_binding :: _Addr -> _PackedString -> _State _RealWorld -> (U_binding, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_coresyn :: _Addr -> _PackedString -> _State _RealWorld -> (U_coresyn, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_entidt :: _Addr -> _PackedString -> _State _RealWorld -> (U_entidt, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_finfot :: _Addr -> _PackedString -> _State _RealWorld -> (U_finfot, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_hpragma :: _Addr -> _PackedString -> _State _RealWorld -> (U_hpragma, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_list :: _Addr -> _PackedString -> _State _RealWorld -> (U_list, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_literal :: _Addr -> _PackedString -> _State _RealWorld -> (U_literal, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_pbinding :: _Addr -> _PackedString -> _State _RealWorld -> (U_pbinding, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_infixTree :: _Addr -> _PackedString -> _State _RealWorld -> ((ProtoName, U_tree, U_tree), _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_tree :: _Addr -> _PackedString -> _State _RealWorld -> (U_tree, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_ttype :: _Addr -> _PackedString -> _State _RealWorld -> (U_ttype, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(P)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getSrcFileUgn :: _PackedString -> _State _RealWorld -> (_PackedString, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 2 XC 4 \ (u0 :: _PackedString) (u1 :: _State _RealWorld) -> case u1 of { _ALG_ S# (u2 :: State# _RealWorld) -> _!_ _TUP_2 [_PackedString, (_State _RealWorld)] [u0, u1]; _NO_DEFLT_ } _N_ #-}
initUgn :: _PackedString -> (_PackedString -> _State _RealWorld -> (a, _State _RealWorld)) -> _State _RealWorld -> (a, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _F_ _IF_ARGS_ 1 3 XXX 3 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _State _RealWorld) -> _APP_ u2 [ u1, u3 ] _N_ #-}
ioToUgnM :: (_State _RealWorld -> (a, _State _RealWorld)) -> _PackedString -> _State _RealWorld -> (a, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 102 _N_ _S_ "SAL" {_A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 2 _/\_ u0 -> \ (u1 :: _State _RealWorld -> (u0, _State _RealWorld)) (u2 :: _State _RealWorld) -> _APP_ u1 [ u2 ] _N_} _F_ _IF_ARGS_ 1 3 XXX 2 _/\_ u0 -> \ (u1 :: _State _RealWorld -> (u0, _State _RealWorld)) (u2 :: _PackedString) (u3 :: _State _RealWorld) -> _APP_ u1 [ u3 ] _N_ #-}
mkSrcLocUgn :: Int -> _PackedString -> _State _RealWorld -> (SrcLoc, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "LLU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_VOID_STAR :: _Addr -> _PackedString -> _State _RealWorld -> (_Addr, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXC 4 \ (u0 :: _Addr) (u1 :: _PackedString) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [_Addr, (_State _RealWorld)] [u0, u2]; _NO_DEFLT_ } _N_ #-}
rdU_hstring :: _Addr -> _PackedString -> _State _RealWorld -> (_PackedString, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 3 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_long :: Int -> _PackedString -> _State _RealWorld -> (Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXC 4 \ (u0 :: Int) (u1 :: _PackedString) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [Int, (_State _RealWorld)] [u0, u2]; _NO_DEFLT_ } _N_ #-}
rdU_numId :: _Addr -> _PackedString -> _State _RealWorld -> (Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_stringId :: _Addr -> _PackedString -> _State _RealWorld -> (_PackedString, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_unkId :: _Addr -> _PackedString -> _State _RealWorld -> (ProtoName, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-}
returnUgn :: b -> a -> _State _RealWorld -> (b, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _S_ "LLS" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: u1) (u3 :: u0) (u4 :: _State _RealWorld) -> case u4 of { _ALG_ S# (u5 :: State# _RealWorld) -> _!_ _TUP_2 [u1, (_State _RealWorld)] [u2, u4]; _NO_DEFLT_ } _N_ #-}
setSrcFileUgn :: _PackedString -> (_PackedString -> _State _RealWorld -> (a, _State _RealWorld)) -> _PackedString -> _State _RealWorld -> (a, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 4 _U_ 2102 _N_ _S_ "LSAL" {_A_ 3 _U_ 212 _N_ _N_ _F_ _IF_ARGS_ 1 3 XXX 3 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _State _RealWorld) -> _APP_ u2 [ u1, u3 ] _N_} _F_ _IF_ARGS_ 1 4 XXXX 3 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _PackedString) (u4 :: _State _RealWorld) -> _APP_ u2 [ u1, u4 ] _N_ #-}
thenUgn :: (b -> _State _RealWorld -> (a, _State _RealWorld)) -> (a -> b -> _State _RealWorld -> (c, _State _RealWorld)) -> b -> _State _RealWorld -> (c, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "SSLL" _F_ _ALWAYS_ _/\_ u0 u1 u2 -> \ (u3 :: u1 -> _State _RealWorld -> (u0, _State _RealWorld)) (u4 :: u0 -> u1 -> _State _RealWorld -> (u2, _State _RealWorld)) (u5 :: u1) (u6 :: _State _RealWorld) -> case _APP_ u3 [ u5, u6 ] of { _ALG_ _TUP_2 (u7 :: u0) (u8 :: _State _RealWorld) -> _APP_ u4 [ u7, u5, u8 ]; _NO_DEFLT_ } _N_ #-}
import SrcLoc(SrcLoc)
infixr 1 `thenPrimIO`
type ParseTree = _Addr
-data ProtoName {-# GHC_PRAGMA Unk _PackedString | Imp _PackedString _PackedString [_PackedString] _PackedString | Prel Name #-}
+data ProtoName
type U_VOID_STAR = _Addr
type U_hstring = _PackedString
type U_long = Int
type U_unkId = ProtoName
type UgnM a = _PackedString -> _State _RealWorld -> (a, _State _RealWorld)
getSrcFileUgn :: _PackedString -> _State _RealWorld -> (_PackedString, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 2 XC 4 \ (u0 :: _PackedString) (u1 :: _State _RealWorld) -> case u1 of { _ALG_ S# (u2 :: State# _RealWorld) -> _!_ _TUP_2 [_PackedString, (_State _RealWorld)] [u0, u1]; _NO_DEFLT_ } _N_ #-}
initUgn :: _PackedString -> (_PackedString -> _State _RealWorld -> (a, _State _RealWorld)) -> _State _RealWorld -> (a, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _F_ _IF_ARGS_ 1 3 XXX 3 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _State _RealWorld) -> _APP_ u2 [ u1, u3 ] _N_ #-}
ioToUgnM :: (_State _RealWorld -> (a, _State _RealWorld)) -> _PackedString -> _State _RealWorld -> (a, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 102 _N_ _S_ "SAL" {_A_ 2 _U_ 12 _N_ _N_ _F_ _IF_ARGS_ 1 2 XX 2 _/\_ u0 -> \ (u1 :: _State _RealWorld -> (u0, _State _RealWorld)) (u2 :: _State _RealWorld) -> _APP_ u1 [ u2 ] _N_} _F_ _IF_ARGS_ 1 3 XXX 2 _/\_ u0 -> \ (u1 :: _State _RealWorld -> (u0, _State _RealWorld)) (u2 :: _PackedString) (u3 :: _State _RealWorld) -> _APP_ u1 [ u3 ] _N_ #-}
mkSrcLocUgn :: Int -> _PackedString -> _State _RealWorld -> (SrcLoc, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "LLU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_VOID_STAR :: _Addr -> _PackedString -> _State _RealWorld -> (_Addr, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXC 4 \ (u0 :: _Addr) (u1 :: _PackedString) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [_Addr, (_State _RealWorld)] [u0, u2]; _NO_DEFLT_ } _N_ #-}
rdU_hstring :: _Addr -> _PackedString -> _State _RealWorld -> (_PackedString, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 3 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_long :: Int -> _PackedString -> _State _RealWorld -> (Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 201 _N_ _S_ "LAU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _F_ _IF_ARGS_ 0 3 XXC 4 \ (u0 :: Int) (u1 :: _PackedString) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [Int, (_State _RealWorld)] [u0, u2]; _NO_DEFLT_ } _N_ #-}
rdU_numId :: _Addr -> _PackedString -> _State _RealWorld -> (Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_stringId :: _Addr -> _PackedString -> _State _RealWorld -> (_PackedString, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-}
rdU_unkId :: _Addr -> _PackedString -> _State _RealWorld -> (ProtoName, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 1 _U_ 122 _N_ _S_ "U(P)" {_A_ 1 _U_ 201 _N_ _N_ _N_ _N_} _N_ _N_ #-}
returnPrimIO :: a -> _State _RealWorld -> (a, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [u0, (_State _RealWorld)] [u1, u2]; _NO_DEFLT_ } _N_ #-}
returnUgn :: b -> a -> _State _RealWorld -> (b, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 202 _N_ _S_ "LLS" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: u1) (u3 :: u0) (u4 :: _State _RealWorld) -> case u4 of { _ALG_ S# (u5 :: State# _RealWorld) -> _!_ _TUP_2 [u1, (_State _RealWorld)] [u2, u4]; _NO_DEFLT_ } _N_ #-}
setSrcFileUgn :: _PackedString -> (_PackedString -> _State _RealWorld -> (a, _State _RealWorld)) -> _PackedString -> _State _RealWorld -> (a, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 4 _U_ 2102 _N_ _S_ "LSAL" {_A_ 3 _U_ 212 _N_ _N_ _F_ _IF_ARGS_ 1 3 XXX 3 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _State _RealWorld) -> _APP_ u2 [ u1, u3 ] _N_} _F_ _IF_ARGS_ 1 4 XXXX 3 _/\_ u0 -> \ (u1 :: _PackedString) (u2 :: _PackedString -> _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: _PackedString) (u4 :: _State _RealWorld) -> _APP_ u2 [ u1, u4 ] _N_ #-}
thenPrimIO :: (_State _RealWorld -> (a, _State _RealWorld)) -> (a -> _State _RealWorld -> (b, _State _RealWorld)) -> _State _RealWorld -> (b, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "SSL" _F_ _ALWAYS_ _/\_ u0 u1 -> \ (u2 :: _State _RealWorld -> (u0, _State _RealWorld)) (u3 :: u0 -> _State _RealWorld -> (u1, _State _RealWorld)) (u4 :: _State _RealWorld) -> case _APP_ u2 [ u4 ] of { _ALG_ _TUP_2 (u5 :: u0) (u6 :: _State _RealWorld) -> _APP_ u3 [ u5, u6 ]; _NO_DEFLT_ } _N_ #-}
thenUgn :: (b -> _State _RealWorld -> (a, _State _RealWorld)) -> (a -> b -> _State _RealWorld -> (c, _State _RealWorld)) -> b -> _State _RealWorld -> (c, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 4 _U_ 1122 _N_ _S_ "SSLL" _F_ _ALWAYS_ _/\_ u0 u1 u2 -> \ (u3 :: u1 -> _State _RealWorld -> (u0, _State _RealWorld)) (u4 :: u0 -> u1 -> _State _RealWorld -> (u2, _State _RealWorld)) (u5 :: u1) (u6 :: _State _RealWorld) -> case _APP_ u3 [ u5, u6 ] of { _ALG_ _TUP_2 (u7 :: u0) (u8 :: _State _RealWorld) -> _APP_ u4 [ u7, u5, u8 ]; _NO_DEFLT_ } _N_ #-}
gfline : long; >;
abind : < gabindfst : binding;
gabindsnd : binding; >;
+/*OLD:95/08:
lbind : < glbindfst : binding;
glbindsnd : binding; >;
- ebind : < gebindl : list;
+*/
+/*OLD:95/08: ebind : < gebindl : list;
gebind : binding;
geline : long; >;
- hbind : < ghbindl : list;
+*/
+/*OLD: 95/08: hbind : < ghbindl : list;
ghbind : binding;
ghline : long; >;
+*/
ibind : < gibindc : list;
gibindid : unkId;
gibindi : ttype;
giebinddef : binding;
giebindfile : stringId;
giebindline : long; >;
+/* "hiding" is used in a funny way:
+ it has to have the *exact* same structure as "import";
+ because what we do is: create an "import" then change
+ its tag to "hiding". Yeeps. (WDP 95/08)
+*/
hiding : < gihbindmod : stringId;
gihbindexp : list;
gihbindren : list;
import Util
%}}
type finfot;
- nofinfo : < >;
+/*OLD:95/08: nofinfo : < >; */
finfo : < fi1: stringId; fi2: stringId; >;
end;
#if 0
/* nothing to add here, really */
void
-MallocFailHook (request_size)
+MallocFailHook (request_size, msg)
I_ request_size; /* in bytes */
+ char *msg;
{
fprintf(stderr, "malloc: failed on request for %lu bytes\n", request_size);
}
#define _isconstr(s) (CharTable[*s]&(_C))
BOOLEAN isconstr PROTO((char *)); /* fwd decl */
-unsigned char CharTable[NCHARS] = {
+static unsigned char CharTable[NCHARS] = {
/* nul */ 0, 0, 0, 0, 0, 0, 0, 0,
/* bs */ 0, _S, _S, _S, _S, 0, 0, 0,
/* dle */ 0, 0, 0, 0, 0, 0, 0, 0,
* have been renamed as hsXXXXX rather than yyXXXXX. --JSM
*/
-int hslineno = 0; /* Line number at end of token */
+static int hslineno = 0; /* Line number at end of token */
int hsplineno = 0; /* Line number at end of previous token */
-int hscolno = 0; /* Column number at end of token */
+static int hscolno = 0; /* Column number at end of token */
int hspcolno = 0; /* Column number at end of previous token */
-int hsmlcolno = 0; /* Column number for multiple-rule lexemes */
+static int hsmlcolno = 0; /* Column number for multiple-rule lexemes */
int startlineno = 0; /* The line number where something starts */
int endlineno = 0; /* The line number where something ends */
/* Essential forward declarations */
-static VOID hsnewid PROTO((char *, int));
-static VOID layout_input PROTO((char *, int));
-static VOID cleartext (NO_ARGS);
-static VOID addtext PROTO((char *, unsigned));
-static VOID addchar PROTO((char));
+static void hsnewid PROTO((char *, int));
+static void layout_input PROTO((char *, int));
+static void cleartext (NO_ARGS);
+static void addtext PROTO((char *, unsigned));
+static void addchar PROTO((char));
static char *fetchtext PROTO((unsigned *));
+static void new_filename PROTO((char *));
+static int Return PROTO((int));
+static void hsentercontext PROTO((int));
/* Special file handling for IMPORTS */
/* Note: imports only ever go *one deep* (hence no need for a stack) WDP 94/09 */
* Simple comments and whitespace. Normally, we would just ignore these, but
* in case we're processing a string escape, we need to note that we've seen
* a gap.
+ *
+ * Note that we cater for a comment line that *doesn't* end in a newline.
+ * This is incorrect, strictly speaking, but seems like the right thing
+ * to do. Reported by Rajiv Mirani. (WDP 95/08)
*/
%}
-<Code,GlaExt,StringEsc>"--".*{NL}{WS}* |
+<Code,GlaExt,StringEsc>"--".*{NL}?{WS}* |
<Code,GlaExt,GhcPragma,UserPragma,StringEsc>{WS}+ { noGap = FALSE; }
%{
This allows unnamed sources to be piped into the parser.
*/
+extern BOOLEAN acceptPrim;
+
void
-yyinit()
+yyinit(void)
{
- extern BOOLEAN acceptPrim;
-
input_filename = xstrdup("<stdin>");
/* We must initialize the input buffer _now_, because we call
PUSH_STATE(Code);
}
-void
-new_filename(f) /* This looks pretty dodgy to me (WDP) */
- char *f;
+static void
+new_filename(char *f) /* This looks pretty dodgy to me (WDP) */
{
if (input_filename != NULL)
free(input_filename);
forcing insertion of ; or } as appropriate
*/
-BOOLEAN
-hsshouldindent()
+static BOOLEAN
+hsshouldindent(void)
{
return (!forgetindent && INDENTON);
}
/* Enter new context and set new indentation level */
void
-hssetindent()
+hssetindent(void)
{
#ifdef HSP_DEBUG
fprintf(stderr, "hssetindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
/* Enter a new context without changing the indentation level */
void
-hsincindent()
+hsincindent(void)
{
#ifdef HSP_DEBUG
fprintf(stderr, "hsincindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
/* Turn off indentation processing, usually because an explicit "{" has been seen */
void
-hsindentoff()
+hsindentoff(void)
{
forgetindent = TRUE;
}
/* Enter a new layout context. */
-void
-hsentercontext(indent)
- int indent;
+static void
+hsentercontext(int indent)
{
/* Enter new context and set indentation as specified */
if (++icontexts >= MAX_CONTEXTS) {
/* Exit a layout context */
void
-hsendindent()
+hsendindent(void)
{
--icontexts;
#ifdef HSP_DEBUG
* Return checks the indentation level and returns ;, } or the specified token.
*/
-int
-Return(tok)
- int tok;
+static int
+Return(int tok)
{
#ifdef HSP_DEBUG
extern int yyleng;
**********************************************************************/
/* setyyin(file) open file as new lex input buffer */
+extern FILE *yyin;
+
void
-setyyin(file)
- char *file;
+setyyin(char *file)
{
- extern FILE *yyin;
-
hsbuf_save = YY_CURRENT_BUFFER;
if ((yyin = fopen(file, "r")) == NULL) {
char errbuf[ERR_BUF_SIZE];
#endif
}
-static VOID
-layout_input(text, len)
-char *text;
-int len;
+static void
+layout_input(char *text, int len)
{
#ifdef HSP_DEBUG
fprintf(stderr, "Scanning \"%s\"\n", text);
}
void
-setstartlineno()
+setstartlineno(void)
{
startlineno = hsplineno;
#if 1/*etags*/
char *text;
} textcache = { 0, 0, NULL };
-static VOID
-cleartext()
+static void
+cleartext(void)
{
/* fprintf(stderr, "cleartext\n"); */
textcache.next = 0;
}
}
-static VOID
-addtext(text, length)
-char *text;
-unsigned length;
+static void
+addtext(char *text, unsigned length)
{
/* fprintf(stderr, "addtext: %d %s\n", length, text); */
textcache.next += length;
}
-static VOID
-#ifdef __STDC__
+static void
addchar(char c)
-#else
-addchar(c)
- char c;
-#endif
{
/* fprintf(stderr, "addchar: %c\n", c); */
}
static char *
-fetchtext(length)
-unsigned *length;
+fetchtext(unsigned *length)
{
/* fprintf(stderr, "fetchtext: %d\n", textcache.next); */
hsnewid Enters an id of length n into the symbol table.
*/
-static VOID
-hsnewid(name, length)
-char *name;
-int length;
+static void
+hsnewid(char *name, int length)
{
char save = name[length];
}
BOOLEAN
-isconstr(s) /* walks past leading underscores before using the macro */
- char *s;
+isconstr(char *s) /* walks past leading underscores before using the macro */
{
char *temp = s;
* *
**********************************************************************/
-BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */
+static BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */
extern BOOLEAN nonstandardFlag;
extern BOOLEAN etags;
* *
**********************************************************************/
-list fixlist;
+/* OLD 95/08: list fixlist; */
static int Fixity = 0, Precedence = 0;
struct infix;
interface:
INTERFACE modid
- { fixlist = Lnil;
+ { /* OLD 95/08: fixlist = Lnil; */
strcpy(iface_name, id_to_string($2));
}
WHERE ibody
/* SCC Expression */
| SCC STRING exp
- { extern BOOLEAN ignoreSCC;
- extern BOOLEAN warnSCC;
-
- if (ignoreSCC) {
+ { if (ignoreSCC) {
if (warnSCC)
fprintf(stderr,
"\"%s\", line %d: _scc_ (`set [profiling] cost centre') ignored\n",
the starting line for definitions.
*/
-/*TESTTEST
-bind : opatk
- | vark lampats
- { $$ = mkap($1,$2); }
- | opatk varop opat %prec PLUS
- {
- $$ = mkinfixop($2,$1,$3);
- }
- ;
-
-opatk : dpatk
- | opatk conop opat %prec PLUS
- {
- $$ = mkinfixop($2,$1,$3);
- precparse($$);
- }
- ;
-
-*/
-
opatk : dpatk
| opatk op opat %prec PLUS
{
;
-/*
- The mkpars are so that infix parsing doesn't get confused.
-
- KH.
-*/
-
tuple : OPAREN exp COMMA texps CPAREN
{ if (ttree($4) == tuple)
$$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4)));
{ $$ = mktuple(Lnil); }
;
+/*
+ The mkpar is so that infix parsing doesn't get confused.
+
+ KH.
+*/
texps : exp { $$ = mkpar($1); }
| exp COMMA texps
{ if (ttree($3) == tuple)
;
qual : { inpat = TRUE; } exp { inpat = FALSE; } qualrest
- { if ($4 == NULL)
+ { if ($4 == NULL) {
+ patternOrExpr(/*wanted:*/ LEGIT_EXPR,$2);
$$ = mkguard($2);
- else
- {
- checkpatt($2);
+ } else {
+ patternOrExpr(/*wanted:*/ LEGIT_PATT,$2);
+ $$ = mkqual($2,$4);
+/* OLD: WDP 95/08
if(ttree($4)==def)
{
tree prevpatt_save = PREVPATT;
PREVPATT = prevpatt_save;
}
else
- $$ = mkqual($2,$4);
- }
+*/
+ }
}
;
yyerror(s);
}
+extern char *yytext;
+extern int yyleng;
+
void
yyerror(s)
char *s;
{
- extern char *yytext;
- extern int yyleng;
-
/* We want to be able to distinguish 'error'-raised yyerrors
from yyerrors explicitly coded by the parser hacker.
*/
#include "utils.h"
/* partain: special version for strings that may have NULs (etc) in them
+ (used in UgenUtil.lhs)
*/
long
get_hstring_len(hs)
The hash function. Returns 0 for Null strings.
*/
-static unsigned hash_fn(ident)
-char *ident;
+static unsigned hash_fn(char *ident)
{
unsigned len = (unsigned) strlen(ident);
unsigned res;
{
FILE *fp = fopen(fileName, mode);
if (fp != NULL) {
- (VOID) fclose(fp);
+ (void) fclose(fp);
return 0;
}
return 1;
list imports_dirlist, sys_imports_dirlist; /* The imports lists */
extern char HiSuffix[];
extern char PreludeHiSuffix[];
-extern BOOLEAN ExplicitHiSuffixGiven;
+/* OLD 95/08: extern BOOLEAN ExplicitHiSuffixGiven; */
#define MAX_MATCH 16
This finds a module along the imports directory list.
*/
-VOID
-find_module_on_imports_dirlist(module_name, is_sys_import, returned_filename)
- char *module_name;
- BOOLEAN is_sys_import;
- char *returned_filename;
+void
+find_module_on_imports_dirlist(char *module_name, BOOLEAN is_sys_import, char *returned_filename)
{
char try[FILENAME_SIZE];
BOOLEAN tried_source_dir = FALSE;
char *try_end;
- char *suffix_to_use = (is_sys_import) ? PreludeHiSuffix : HiSuffix;
+ char *suffix_to_use = (is_sys_import) ? PreludeHiSuffix : HiSuffix;
+ char *suffix_to_report = suffix_to_use; /* save this for reporting, because we
+ might change suffix_to_use later */
int modname_len = strlen(module_name);
/*
switch ( no_of_matches ) {
default:
fprintf(stderr,"Warning: found %d %s files for module \"%s\"\n",
- no_of_matches, suffix_to_use, module_name);
+ no_of_matches, suffix_to_report, module_name);
break;
case 0:
{
char disaster_msg[MODNAME_SIZE+1000];
sprintf(disaster_msg,"can't find interface (%s) file for module \"%s\"%s",
- suffix_to_use, module_name,
+ suffix_to_report, module_name,
(strncmp(module_name, "PreludeGlaIO", 12) == 0)
? "\n(The PreludeGlaIO interface no longer exists);"
:(
ninfix = 0;
}
+#if 0
+/* UNUSED */
void
exitiscope()
{
--iscope;
}
+#endif
void
exposeis()
static int
-ionelookup(name,iscope)
- id name;
- int iscope;
+ionelookup(id name, int iscope)
{
int i;
char *iname = id_to_string(name);
}
char *
-fixop(n)
- int n;
+fixop(int n)
{
return infixtab[iscope][n].iname;
}
char *
-fixtype(n)
- int n;
+fixtype(int n)
{
switch(infixtab[iscope][n].ifixity) {
case INFIXL:
}
}
-
+#if 0
+/* UNUSED? */
int
fixity(n)
int n;
#endif
return(n < 0? INFIXL: infixtab[iscope][n].ifixity);
}
+#endif /* 0 */
long int
**********************************************************************/
int
-main(argc, argv)
- int argc;
- char **argv;
+main(int argc, char **argv)
{
Lnil = mklnil(); /* The null list -- used in lsing, etc. */
all = mklnil(); /* This should be the list of all derivable types */
/* fwd decls, necessary and otherwise */
static void ptree PROTO( (tree) );
-static void plist PROTO( (void (*)(), list) );
+static void plist PROTO( (void (*)(/*NOT WORTH IT: void * */), list) );
static void pid PROTO( (id) );
static void pstr PROTO( (char *) );
static void pbool PROTO( (BOOLEAN) );
char/string lexer comments. (WDP 94/11)
*/
static void
-print_string(str)
- hstring str;
+print_string(hstring str)
{
char *gs;
char c;
}
static int
-get_character(str)
- hstring str;
+get_character(hstring str)
{
int c = (int)((str->bytes)[0]);
if (str->len != 1) { /* ToDo: assert */
- fprintf(stderr, "get_character: length != 1? (%d: %s)\n", str->len, str->bytes);
+ fprintf(stderr, "get_character: length != 1? (%ld: %s)\n", str->len, str->bytes);
}
if (c < 0) {
}
static void
-pliteral(t)
- literal t;
+pliteral(literal t)
{
switch(tliteral(t)) {
case integer:
case par: t = gpare(t); goto again;
case hmodule:
PUTTAG('M');
- printf("#%u\t",ghmodline(t));
+ printf("#%lu\t",ghmodline(t));
pid(ghname(t));
pstr(input_filename);
prbind(ghmodlist(t));
case lambda:
PUTTAG('l');
- printf("#%u\t",glamline(t));
+ printf("#%lu\t",glamline(t));
plist(ptree,glampats(t));
ptree(glamexpr(t));
break;
static void
plist(fun, l)
- void (*fun)();
+ void (*fun)(/* NOT WORTH IT: void * */);
list l;
{
if (tlist(l) == lcons) {
id i;
{
if(hashIds)
- printf("!%u\t", hash_index(i));
+ printf("!%lu\t", hash_index(i));
else
printf("#%s\t", id_to_string(i));
}
switch(tbinding(b)) {
case tbind:
PUTTAG('t');
- printf("#%u\t",gtline(b));
+ printf("#%lu\t",gtline(b));
plist(pttype, gtbindc(b));
plist(pid, gtbindd(b));
pttype(gtbindid(b));
break;
case nbind :
PUTTAG('n');
- printf("#%u\t",gnline(b));
+ printf("#%lu\t",gnline(b));
pttype(gnbindid(b));
pttype(gnbindas(b));
ppragma(gnpragma(b));
break;
case pbind :
PUTTAG('p');
- printf("#%u\t",gpline(b));
+ printf("#%lu\t",gpline(b));
plist(ppbinding, gpbindl(b));
break;
case fbind :
PUTTAG('f');
- printf("#%u\t",gfline(b));
+ printf("#%lu\t",gfline(b));
plist(ppbinding, gfbindl(b));
break;
case abind :
break;
case cbind :
PUTTAG('$');
- printf("#%u\t",gcline(b));
+ printf("#%lu\t",gcline(b));
plist(pttype,gcbindc(b));
pttype(gcbindid(b));
prbind(gcbindw(b));
break;
case ibind :
PUTTAG('%');
- printf("#%u\t",giline(b));
+ printf("#%lu\t",giline(b));
plist(pttype,gibindc(b));
pid(gibindid(b));
pttype(gibindi(b));
break;
case dbind :
PUTTAG('D');
- printf("#%u\t",gdline(b));
+ printf("#%lu\t",gdline(b));
plist(pttype,gdbindts(b));
break;
/* signature(-like) things, including user pragmas */
case sbind :
PUTTAGSTR("St");
- printf("#%u\t",gsline(b));
+ printf("#%lu\t",gsline(b));
plist(pid,gsbindids(b));
pttype(gsbindid(b));
ppragma(gspragma(b));
case vspec_uprag:
PUTTAGSTR("Ss");
- printf("#%u\t",gvspec_line(b));
+ printf("#%lu\t",gvspec_line(b));
pid(gvspec_id(b));
plist(pttype,gvspec_tys(b));
break;
case ispec_uprag:
PUTTAGSTR("SS");
- printf("#%u\t",gispec_line(b));
+ printf("#%lu\t",gispec_line(b));
pid(gispec_clas(b));
pttype(gispec_ty(b));
break;
case inline_uprag:
PUTTAGSTR("Si");
- printf("#%u\t",ginline_line(b));
+ printf("#%lu\t",ginline_line(b));
pid(ginline_id(b));
plist(pid,ginline_howto(b));
break;
case deforest_uprag:
PUTTAGSTR("Sd");
- printf("#%u\t",gdeforest_line(b));
+ printf("#%lu\t",gdeforest_line(b));
pid(gdeforest_id(b));
break;
case magicuf_uprag:
PUTTAGSTR("Su");
- printf("#%u\t",gmagicuf_line(b));
+ printf("#%lu\t",gmagicuf_line(b));
pid(gmagicuf_id(b));
pid(gmagicuf_str(b));
break;
case abstract_uprag:
PUTTAGSTR("Sa");
- printf("#%u\t",gabstract_line(b));
+ printf("#%lu\t",gabstract_line(b));
pid(gabstract_id(b));
break;
case dspec_uprag:
PUTTAGSTR("Sd");
- printf("#%u\t",gdspec_line(b));
+ printf("#%lu\t",gdspec_line(b));
pid(gdspec_id(b));
plist(pttype,gdspec_tys(b));
break;
case mbind:
PUTTAG('7');
- printf("#%u\t",gmline(b));
+ printf("#%lu\t",gmline(b));
pid(gmbindmodn(b));
plist(pentid,gmbindimp(b));
plist(prename,gmbindren(b));
break;
case import:
PUTTAG('e');
- printf("#%u\t",giebindline(b));
+ printf("#%lu\t",giebindline(b));
pstr(giebindfile(b));
pid(giebindmod(b));
plist(pentid,giebindexp(b));
break;
case hiding:
PUTTAG('h');
- printf("#%u\t",gihbindline(b));
+ printf("#%lu\t",gihbindline(b));
pstr(gihbindfile(b));
pid(gihbindmod(b));
plist(pentid,gihbindexp(b));
switch (tatype(a)) {
case atc :
PUTTAG('1');
- printf("#%u\t",gatcline(a));
+ printf("#%lu\t",gatcline(a));
pid(gatcid(a));
plist(pttype, gatctypel(a));
break;
PUTTAG('L');
pstr(fixop(i));
pstr(fixtype(i));
- printf("#%u\t",precedence(i));
+ printf("#%lu\t",precedence(i));
}
}
PUTTAG('N');
{
switch(tpbinding(p)) {
case pgrhs : PUTTAG('W');
- printf("#%u\t",ggline(p));
+ printf("#%lu\t",ggline(p));
pid(ggfuncname(p));
ptree(ggpat(p));
plist(pgrhses,ggdexprs(p));
/* Forward Declarations */
-char *ineg PROTO((char *));
-tree unparen PROTO((tree));
+char *ineg PROTO((char *));
+static tree unparen PROTO((tree));
+static void is_conapp_patt PROTO((int, tree, tree));
+static void rearrangeprec PROTO((tree, tree));
+static void error_if_expr_wanted PROTO((int, char *));
+static void error_if_patt_wanted PROTO((int, char *));
tree fns[MAX_CONTEXTS] = { NULL };
short samefn[MAX_CONTEXTS] = { 0 };
BOOLEAN inpat = FALSE;
+static BOOLEAN checkorder2 PROTO((binding, BOOLEAN));
+static BOOLEAN checksig PROTO((BOOLEAN, binding));
/*
check infix value in range 0..9
Check Previous Pattern usage
*/
+/* UNUSED:
void
checkprevpatt()
{
if (PREVPATT == NULL)
hsperror("\"'\" used before a function definition");
}
+*/
void
checksamefn(fn)
Check that a list of types is a list of contexts
*/
+#if 0
+/* UNUSED */
void
checkcontext(context)
list context;
context = ltl(context);
}
}
+#endif /* 0 */
void
checkinpat()
hsperror("syntax error");
}
+/* ------------------------------------------------------------------------
+*/
+
void
-checkpatt(e)
- tree e;
+patternOrExpr(int wanted, tree e)
+ /* see utils.h for what args are */
{
switch(ttree(e))
{
- case ident:
+ case ident: /* a pattern or expr */
+ break;
+
case wildp:
- break;
+ error_if_expr_wanted(wanted, "wildcard in expression");
+ break;
case lit:
switch (tliteral(glit(e))) {
case doubleprim:
case floatprim:
case string:
+ case stringprim:
case charr:
case charprim:
- case stringprim:
- break;
- default:
- hsperror("not a valid literal pattern");
+ break; /* pattern or expr */
+
+ case clitlit:
+ error_if_patt_wanted(wanted, "``literal-literal'' in pattern");
+
+ default: /* the others only occur in pragmas */
+ hsperror("not a valid literal pattern or expression");
}
break;
case negate:
- if (ttree(gnexp(e)) != lit) {
- hsperror("syntax error: \"-\" applied to a non-literal");
- } else {
- literal l = glit(gnexp(e));
-
- if (tliteral(l) != integer && tliteral(l) != floatr) {
- hsperror("syntax error: \"-\" applied to a non-number");
- }
+ { tree sub = gnexp(e);
+ if (ttree(sub) != lit) {
+ error_if_patt_wanted(wanted, "\"-\" applied to a non-literal");
+ } else {
+ literal l = glit(sub);
+
+ if (tliteral(l) != integer && tliteral(l) != floatr) {
+ error_if_patt_wanted(wanted, "\"-\" applied to a non-number");
+ }
+ }
+ patternOrExpr(wanted, sub);
}
break;
tree f = gfun(e);
tree a = garg(e);
- checkconap(f, a);
+ is_conapp_patt(wanted, f, a); /* does nothing unless wanted == LEGIT_PATT */
+ patternOrExpr(wanted, f);
+ patternOrExpr(wanted, a);
}
break;
case as:
- checkpatt(gase(e));
+ error_if_expr_wanted(wanted, "`as'-pattern instead of an expression");
+ patternOrExpr(wanted, gase(e));
break;
case lazyp:
- checkpatt(glazyp(e));
+ error_if_expr_wanted(wanted, "irrefutable pattern instead of an expression");
+ patternOrExpr(wanted, glazyp(e));
break;
case plusp:
- checkpatt(gplusp(e));
+ patternOrExpr(wanted, gplusp(e));
break;
case tinfixop:
{
- tree f = ginfun((struct Sap *)e),
+ tree f = ginfun((struct Sap *)e),
a1 = ginarg1((struct Sap *)e),
a2 = ginarg2((struct Sap *)e);
struct Splusp *e_plus;
- checkpatt(a1);
-
- if (ttree(f) == ident && strcmp(id_to_string(gident(f)),"+")==0)
- {
- if(ttree(a2) != lit || tliteral((literal) ttree(a2)) != integer)
- hsperror("syntax error: non-integer in (n+k) pattern");
-
- if(ttree(a1) == wildp || (ttree(a1) == ident && !isconstr(gident(a1))))
- {
- e->tag = plusp;
- e_plus = (struct Splusp *) e;
- *Rgplusp(e_plus) = a1;
- *Rgplusi(e_plus) = glit(a2);
- }
- else
- hsperror("syntax error: non-variable in (n+k) pattern");
- }
- else
- {
- if(ttree(f) == ident && !isconstr(gident(f)))
- hsperror("syntax error: variable application in pattern");
- checkpatt(a2);
- }
+ patternOrExpr(wanted, a1);
+ patternOrExpr(wanted, a2);
+
+ if (wanted == LEGIT_PATT) {
+ if (ttree(f) == ident && strcmp(id_to_string(gident(f)),"+")==0) {
+
+ if(ttree(a2) != lit || tliteral((literal) ttree(a2)) != integer)
+ hsperror("non-integer in (n+k) pattern");
+
+ if(ttree(a1) == wildp || (ttree(a1) == ident && !isconstr(gident(a1))))
+ {
+ e->tag = plusp;
+ e_plus = (struct Splusp *) e;
+ *Rgplusp(e_plus) = a1;
+ *Rgplusi(e_plus) = glit(a2);
+ }
+ else
+ hsperror("non-variable in (n+k) pattern");
+
+ } else {
+ if(ttree(f) == ident && !isconstr(gident(f)))
+ hsperror("variable application in pattern");
+ }
+ }
}
break;
case tuple:
{
- list tup = gtuplelist(e);
- while (tlist(tup) == lcons)
- {
- checkpatt(lhd(tup));
- tup = ltl(tup);
- }
+ list tup;
+ for (tup = gtuplelist(e); tlist(tup) == lcons; tup = ltl(tup)) {
+ patternOrExpr(wanted, lhd(tup));
+ }
}
break;
- case par:
- checkpatt(gpare(e));
+ case par: /* parenthesised */
+ patternOrExpr(wanted, gpare(e));
break;
case llist:
{
- list l = gllist(e);
- while (tlist(l) == lcons)
- {
- checkpatt(lhd(l));
- l = ltl(l);
- }
+ list l;
+ for (l = gllist(e); tlist(l) == lcons; l = ltl(l)) {
+ patternOrExpr(wanted, lhd(l));
+ }
}
break;
#ifdef DPH
case proc:
{
- list pids = gprocid(e);
- while (tlist(pids) == lcons)
- {
- checkpatt(lhd(pids));
- pids = ltl(pids);
- }
- checkpatt(gprocdata(e));
+ list pids;
+ for (pids = gprocid(e); tlist(pids) == lcons; pids = ltl(pids)) {
+ patternOrExpr(wanted, lhd(pids));
+ }
+ patternOrExpr(wanted, gprocdata(e));
}
break;
#endif /* DPH */
+ case lambda:
+ case let:
+ case casee:
+ case ife:
+ case restr:
+ case comprh:
+ case lsection:
+ case rsection:
+ case eenum:
+ case ccall:
+ case scc:
+ error_if_patt_wanted(wanted, "unexpected construct in a pattern");
+ break;
+
default:
- hsperror("not a pattern");
+ hsperror("not a pattern or expression");
}
}
+static void
+is_conapp_patt(int wanted, tree f, tree a)
+{
+ if (wanted == LEGIT_EXPR)
+ return; /* that was easy */
+
+ switch(ttree(f))
+ {
+ case ident:
+ if (isconstr(gident(f)))
+ {
+ patternOrExpr(wanted, a);
+ return;
+ }
+ {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf,"not a constructor application -- %s",gident(f));
+ hsperror(errbuf);
+ }
-BOOLEAN /* return TRUE if LHS is a pattern; FALSE if a function */
-is_patt_or_fun(e, outer_level)
- tree e;
- BOOLEAN outer_level;
- /* only needed because x+y is a *function* at
- the "outer level", but an n+k *pattern* at
- any "inner" level. Sigh. */
+ case ap:
+ is_conapp_patt(wanted, gfun(f), garg(f));
+ patternOrExpr(wanted, a);
+ return;
+
+ case par:
+ is_conapp_patt(wanted, gpare(f), a);
+ break;
+
+ case tuple:
+ {
+ char errbuf[ERR_BUF_SIZE];
+ sprintf(errbuf,"tuple pattern `applied' to arguments (missing comma?)");
+ hsperror(errbuf);
+ }
+ break;
+
+ default:
+ hsperror("not a constructor application");
+ }
+}
+
+static void
+error_if_expr_wanted(int wanted, char *msg)
+{
+ if (wanted == LEGIT_EXPR)
+ hsperror(msg);
+}
+
+static void
+error_if_patt_wanted(int wanted, char *msg)
+{
+ if (wanted == LEGIT_PATT)
+ hsperror(msg);
+}
+
+/* ---------------------------------------------------------------------- */
+
+static BOOLEAN /* return TRUE if LHS is a pattern; FALSE if a function */
+is_patt_or_fun(tree e, BOOLEAN outer_level)
+ /* "outer_level" only needed because x+y is a *function* at
+ the "outer level", but an n+k *pattern* at
+ any "inner" level. Sigh. */
{
switch(ttree(e))
{
#ifdef DPH
case proc:
#endif
- checkpatt(e);
+ patternOrExpr(LEGIT_PATT, e);
return TRUE;
case ident:
tree fn = function(e);
/*fprintf(stderr,"ap:f=%d %s (%d),a=%d %s\n",ttree(gfun(e)),(ttree(gfun(e)) == ident) ? (gident(gfun(e))) : "",ttree(fn),ttree(garg(e)),(ttree(garg(e)) == ident) ? (gident(garg(e))) : "");*/
- checkpatt(a);
+ patternOrExpr(LEGIT_PATT, a);
if(ttree(fn) == ident)
return(isconstr(gident(fn)));
struct Splusp *e_plus;
/* Even function definitions must have pattern arguments */
- checkpatt(a1);
- checkpatt(a2);
+ patternOrExpr(LEGIT_PATT, a1);
+ patternOrExpr(LEGIT_PATT, a2);
if (ttree(f) == ident)
{
switch (ttree(e))
{
case ap:
- checkpatt(garg(e));
+ patternOrExpr(LEGIT_PATT, garg(e));
return(function(gfun(e)));
case par:
}
-tree
+static tree
unparen(e)
tree e;
{
return(e);
}
-void
-checkconap(f, a)
- tree f, a;
-{
- switch(ttree(f))
- {
- case ident:
- if (isconstr(gident(f)))
- {
- checkpatt(a);
- return;
- }
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"syntax error: not a constructor application -- %s",gident(f));
- hsperror(errbuf);
- }
-
- case ap:
- checkconap(gfun(f), garg(f));
- checkpatt(a);
- return;
-
- case par:
- checkconap(gpare(f), a);
- break;
-
- case tuple:
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"syntax error: tuple pattern `applied' to arguments (missing comma?)");
- hsperror(errbuf);
- }
- break;
-
- default:
- hsperror("syntax error: not a constructor application");
- }
-}
-
/*
Extend a function by adding a new definition to its list of bindings.
*/
void
-precparse(t)
- tree t;
+precparse(tree t)
{
#if 0
-#ifdef HSP_DEBUG
+# ifdef HSP_DEBUG
fprintf(stderr,"precparse %x\n",ttree(t));
-#endif
+# endif
#endif
if(ttree(t) == tinfixop)
{
tree left = ginarg1((struct Sap *)t);
#if 0
-#ifdef HSP_DEBUG
+# ifdef HSP_DEBUG
fprintf(stderr,"precparse:t=");ptree(t);printf("\nleft=");ptree(left);printf("\n");
-#endif
+# endif
#endif
if(ttree(left) == negate)
*ttabpos = infixlookup(tid);
#if 0
-#ifdef HSP_DEBUG
+# ifdef HSP_DEBUG
fprintf(stderr,"precparse: lid=%s; tid=%s,ltab=%d,ttab=%d\n",
id_to_string(lid),id_to_string(tid),pprecedence(lefttabpos),pprecedence(ttabpos));
-#endif
+# endif
#endif
if (pprecedence(lefttabpos) < pprecedence(ttabpos))
The recursive call to precparse ensures this filters down as necessary.
*/
-void
-rearrangeprec(t1,t2)
- tree t1, t2;
+static void
+rearrangeprec(tree t1, tree t2)
{
tree arg3 = ginarg2((struct Sap *)t2);
id id1 = gident(ginfun((struct Sap *)t1)),
return(p);
}
+#if 0
+/* UNUSED: at the moment */
void
checkmodname(import,interface)
id import, interface;
hsperror(errbuf);
}
}
+#endif /* 0 */
/*
Check the ordering of declarations in a cbody.
checkorder2(decls,TRUE);
}
-BOOLEAN
+static BOOLEAN
checkorder2(decls,sigs)
binding decls;
BOOLEAN sigs;
}
-BOOLEAN
+static BOOLEAN
checksig(sig,decl)
BOOLEAN sig;
binding decl;
qual : < gqpat : tree;
gqexp : tree; >;
guard : < ggexp : tree; >;
- def : < ggdef : tree; >;
+ def : < ggdef : tree; >; /* unused, I believe WDP 95/08 */
+/* "tinfixop" is an odd bird:
+ we clobber its tag into another "tree", thus marking
+ that tree as infixery. We do not create tinfixops
+ per se. (WDP 95/08)
+*/
tinfixop: < gdummy : infixTree; >;
lsection: < glsexp : tree;
glsop : unkId; >;
/* Imported Values */
extern list Lnil;
-VOID is_context_format PROTO((ttype)); /* forward */
+static void is_context_format PROTO((ttype)); /* forward */
/*
partain: see also the comment by "decl" in hsparser.y.
/* is_context_format is the same as "type2context" except that it just performs checking */
/* ttype is either "tycon" [class] or "tycon (named)tvar" [class var] */
-VOID
+static void
is_context_format(t)
ttype t;
{
int maxAcceptablePragmaVersion = 5; /* 0.26+ */
int thisIfacePragmaVersion = 0;
-char *input_file_dir; /* The directory where the input file is. */
+static char *input_file_dir; /* The directory where the input file is. */
char HiSuffix[64] = ".hi"; /* can be changed with -h flag */
char PreludeHiSuffix[64] = ".hi"; /* can be changed with -g flag */
-BOOLEAN ExplicitHiSuffixGiven = 0;
+/* OLD 95/08: BOOLEAN ExplicitHiSuffixGiven = 0; */
static BOOLEAN verbose = FALSE; /* Set for verbose messages. */
+/* Forward decls */
+static void who_am_i PROTO((void));
+
/**********************************************************************
* *
* *
case 'h':
strcpy(HiSuffix, *argv+1);
- ExplicitHiSuffixGiven = 1;
+/*OLD 95/08: ExplicitHiSuffixGiven = 1; */
keep_munging_option = FALSE;
break;
exit(1);
}
-void
-who_am_i()
+static void
+who_am_i(void)
{
fprintf(stderr,"Glasgow Haskell parser, version %s\n", PARSER_VERSION);
}
}
list
-lapp(l1, l2)
- list l1;
- VOID_STAR l2;
+lapp(list l1, VOID_STAR l2)
{
list t;
extern char HiSuffix[];
extern char PreludeHiSuffix[];
-extern void process_args PROTO((int, char **));
+void process_args PROTO((int, char **));
/* end of util.c stuff */
-extern list mklcons PROTO((void *h, list t)); /* if we have PROTO, we have "void *" */
-extern list lapp PROTO((list l1, void *l2));
-extern list lconc PROTO((list l1, list l2));
-extern list mktruecase PROTO((tree t));
+list mklcons PROTO((void *h, list t)); /* if we have PROTO, we have "void *" */
+list lapp PROTO((list l1, void *l2));
+list lconc PROTO((list l1, list l2));
+list mktruecase PROTO((tree t));
#define lsing(l) mklcons(l, Lnil) /* Singleton Lists */
#define ldub(l1, l2) mklcons(l1, lsing(l2)) /* Two-element Lists */
#define SAMEFN samefn[icontexts]
#define PREVPATT prevpatt[icontexts]
-extern tree *Rginfun PROTO((struct Sap *));
-extern tree *Rginarg1 PROTO((struct Sap *));
-extern tree *Rginarg2 PROTO((struct Sap *));
+tree *Rginfun PROTO((struct Sap *));
+tree *Rginarg1 PROTO((struct Sap *));
+tree *Rginarg2 PROTO((struct Sap *));
#define ginfun(xx) *Rginfun(xx)
#define ginarg1(xx) *Rginarg1(xx)
#define ginarg2(xx) *Rginarg2(xx)
-extern id installid PROTO((char *)); /* Create a new identifier */
-extern hstring installHstring PROTO((int, char *)); /* Create a new literal string */
+id installid PROTO((char *)); /* Create a new identifier */
+hstring installHstring PROTO((int, char *)); /* Create a new literal string */
-extern id install_literal PROTO((char *));
-extern char *id_to_string PROTO((id));
+id install_literal PROTO((char *));
+char *id_to_string PROTO((id));
-extern struct infix *infixlookup();
+struct infix *infixlookup PROTO((id));
/* partain additions */
-extern char *xmalloc PROTO((unsigned)); /* just a GNU-style error-checking malloc */
-extern int printf PROTO((const char *, ...));
-extern int fprintf PROTO((FILE *, const char *, ...));
-/*varies (sun/alpha): extern int fputc PROTO((char, FILE *)); */
-extern int fputs PROTO((const char *, FILE *));
-extern int sscanf PROTO((const char *, const char *, ...));
-extern long strtol PROTO((const char *, char **, int));
-extern size_t fread PROTO((void *, size_t, size_t, FILE *));
-extern int fclose PROTO((FILE *));
-extern int isatty PROTO((int));
+char *xmalloc PROTO((unsigned)); /* just a GNU-style error-checking malloc */
+int printf PROTO((const char *, ...));
+int fprintf PROTO((FILE *, const char *, ...));
+/*varies (sun/alpha): int fputc PROTO((char, FILE *)); */
+int fputs PROTO((const char *, FILE *));
+int sscanf PROTO((const char *, const char *, ...));
+long strtol PROTO((const char *, char **, int));
+size_t fread PROTO((void *, size_t, size_t, FILE *));
+int fclose PROTO((FILE *));
+int isatty PROTO((int));
/*extern ??? _filbuf */
/*extern ??? _flsbuf */
-extern void format_string PROTO((FILE *, unsigned char *, int));
-extern tree mkbinop PROTO((char *, tree, tree));
-extern tree mkinfixop PROTO((char *, tree, tree));
-extern list type2context PROTO((ttype));
-extern pbinding createpat PROTO((list, binding));
-extern void process_args PROTO((int, char **));
-extern void hash_init PROTO((void));
-extern void print_hash_table PROTO((void));
-extern long int hash_index PROTO((id));
-extern void yyinit PROTO((void));
-extern int yyparse PROTO((void));
-extern int yylex PROTO((void));
-extern void setyyin PROTO((char *));
-extern void yyerror PROTO((char *));
-extern void error PROTO((char *));
-extern void hsperror PROTO((char *));
-extern void enteriscope PROTO((void));
-extern void exposeis PROTO((void));
-extern void makeinfix PROTO((id, int, int));
-extern int nfixes PROTO((void));
-extern long int precedence PROTO((int));
-extern int pprecedence PROTO((struct infix *));
-extern void rearrangeprec PROTO((tree, tree));
-extern int pfixity PROTO((struct infix *));
-extern void hsincindent PROTO((void));
-extern void hssetindent PROTO((void));
-extern void hsentercontext PROTO((int));
-extern void hsendindent PROTO((void));
-extern void hsindentoff PROTO((void));
-
-extern int checkfixity PROTO((char *));
-extern void checksamefn PROTO((char *));
-extern void checkcontext PROTO((list));
-extern void checkinpat PROTO((void));
-extern void checkpatt PROTO((tree));
-extern BOOLEAN lhs_is_patt PROTO((tree));
-extern tree function PROTO((tree));
-extern void checkconap PROTO((tree, tree));
-extern void extendfn PROTO((binding, binding));
-extern void precparse PROTO((tree));
-extern void checkorder PROTO((binding));
-extern BOOLEAN checkorder2 PROTO((binding, BOOLEAN));
-extern BOOLEAN checksig PROTO((BOOLEAN, binding));
-extern void checkprec PROTO((tree, id, BOOLEAN));
-extern BOOLEAN isconstr PROTO((char *));
-extern void setstartlineno PROTO((void));
-extern void pprogram PROTO((tree));
-extern void who_am_i PROTO((void));
-extern void new_filename PROTO((char *));
-extern int Return PROTO((int));
+void format_string PROTO((FILE *, unsigned char *, int));
+tree mkbinop PROTO((char *, tree, tree));
+tree mkinfixop PROTO((char *, tree, tree));
+list type2context PROTO((ttype));
+pbinding createpat PROTO((list, binding));
+void process_args PROTO((int, char **));
+void hash_init PROTO((void));
+void print_hash_table PROTO((void));
+long int hash_index PROTO((id));
+void yyinit PROTO((void));
+int yyparse PROTO((void));
+int yylex PROTO((void));
+void setyyin PROTO((char *));
+void yyerror PROTO((char *));
+void error PROTO((char *));
+void hsperror PROTO((char *));
+void enteriscope PROTO((void));
+void exposeis PROTO((void));
+void makeinfix PROTO((id, int, int));
+int nfixes PROTO((void));
+long int precedence PROTO((int));
+int pprecedence PROTO((struct infix *));
+int pfixity PROTO((struct infix *));
+void pprogram PROTO((tree));
+void hsincindent PROTO((void));
+void hssetindent PROTO((void));
+void hsendindent PROTO((void));
+void hsindentoff PROTO((void));
+
+int checkfixity PROTO((char *));
+void checksamefn PROTO((char *));
+void checkinpat PROTO((void));
+
+void patternOrExpr PROTO((int,tree));
+/* the "int" arg says what we want; it is one of: */
+#define LEGIT_PATT 1
+#define LEGIT_EXPR 2
+
+BOOLEAN lhs_is_patt PROTO((tree));
+tree function PROTO((tree));
+void extendfn PROTO((binding, binding));
+void precparse PROTO((tree));
+void checkorder PROTO((binding));
+void checkprec PROTO((tree, id, BOOLEAN));
+BOOLEAN isconstr PROTO((char *));
+void setstartlineno PROTO((void));
+void find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *));
+char *fixop PROTO((int));
+char *fixtype PROTO((int));
/* mattson additions */
-extern char *xstrdup PROTO((char *)); /* Duplicate a string */
-extern char *xstrndup PROTO((char *, unsigned));/* Duplicate a substring */
-extern char *xrealloc PROTO((char *, unsigned));/* Re-allocate a string */
+char *xstrdup PROTO((char *)); /* Duplicate a string */
+char *xstrndup PROTO((char *, unsigned)); /* Duplicate a substring */
+char *xrealloc PROTO((char *, unsigned)); /* Re-allocate a string */
#endif /* __UTILS_H */
--- /dev/null
+A binary-only from-working-sources no-guarantees snapshot of the
+Glasgow Haskell compiler (GHC) for i386-unknown-linuxaout and
+i386-unknown-solaris2 platforms is now available from
+ftp://ftp.dcs.glasgow.ac.uk/pub/haskell/glasgow/ghc-0.27-<platform>.tar.gz.
+(The files ghc-0.26-docs-and-examples.tar.gz and
+ghc-0.26-ps-docs.tar.gz [PostScript] may also be of interest.)
+
+This pseudo-release adds profiling and concurrent-Haskell support for
+i386-*-linuxaout. It is the first GHC that works on i386-*-solaris2
+machines (sequential, profiling, and concurrent support provided).
+
+As 0.27 is a snapshot and not a "proper" release, it may have serious,
+show-stopping bugs in it. If you *need* what 0.27 provides, use it;
+otherwise, you should stick with 0.26.
+
+It should be relatively straightforward to tweak
+ghc/driver/ghc-asm.(l)prl to support Linux ELF format; ditto for other
+Unices on x86 platforms. Please let us know if you make such changes.
+
+GCC 2.7.x is required; GCC 2.6.x will *not* work.
+
+Binaries (.o files and executables) produced by GHC 0.27 cannot be
+intermixed with those from GHC 0.26 or 0.25; you'll need to recompile
+everything.
+
+The -concurrent stuff *definitely* has at least one bug we haven't
+been able to catch. Concurrent programs that show
+readily-reproducible buggy behavior would be most welcome.
+
+The profiling libraries for *solaris2 are huge, for reasons we don't
+understand. If you need to scrap them for space reasons, see the end
+of the installation notes below. Insights into the problem would also
+be most appreciated.
+
+Please report any bugs to glasgow-haskell-bugs@dcs.glasgow.ac.uk.
+
+Will Partain
+AQUA project (slave)
+
+Dated: 95/12/20
+
+=== INSTALLATION NOTES ==============================================
+
+Ignore the installation instructions in any documentation. This is
+the stuff that applies for this distribution.
+
+Unpack the distribution.
+
+Move "ghc-0.27-<platform>" to wherever you like.
+
+Make a link to ghc-0.27-<platform>/ghc/driver/ghc, so that "ghc" will
+be in your PATH.
+
+Change the hardwired paths in ghc/driver/ghc and in
+ghc/utils/hscpp/hscpp to point to where things are on your system.
+(Also: ghc/utils/mkdependHS/mkdependHS, if you want to use it.)
+Notably: where "perl" is (first line of each script), where $TopPwd is
+(ghc script), where your gcc cpp ($OrigCpp) is (hscpp and mkdependHS
+scripts). *Don't* set any environment variables to do this.
+
+GHC should then work. Try "ghc -v" on something simple, to make sure
+it compiles and links a program correctly.
+
+If you don't want the profiling libraries (e.g., to save disk space), do:
+
+ cd ghc
+ rm runtime/*_p.a lib/*_p.a
+
+If you don't want to concurrent-Haskell libraries (e.g., same reason), do:
+
+ cd ghc
+ rm runtime/*_mc.a lib/*_mc.a
#define NoInstallTargetForSubdirs
#define NoTagTargetForSubdirs
-SUBDIRS = add_to_compiler \
- users_guide \
- install_guide \
- release_notes
+SUBDIRS = add_to_compiler \
+ users_guide \
+ install_guide \
+ release_notes \
+ state_interface
XCOMM developers_guide ?
XCOMM interfaces ?
The reader interested in the final code-generation parts of the
compiler, from Core syntax to STG syntax\srcloc{stgSyn/CoreToStg.lhs}
-to Abstract~C,\srcloc{codeGen/} should consult Peyton Jones's recent
+to Abstract~C\srcloc{codeGen/}, should consult Peyton Jones's recent
paper, ``Implementing lazy functional languages on stock hardware: the
Spineless Tagless G-machine'' \cite{peyton-jones92a}.
Further note: We have found that the STG
syntax\srcloc{stgSyn/StgSyn.lhs} is the better medium for a few
-transformations.\srcloc{stgSyn/SimplStg.lhs} This is fine---STG syntax
+transformations\srcloc{stgSyn/SimplStg.lhs}. This is fine---STG syntax
is a just-as-manipulable functional language as Core syntax, even if
it's a bit messier.
Section~\ref{sec:AbsSyntax}), the Core syntax is also {\em
parameterised}, this time with respect to binders and bound-variables
(or ``bindees''). The definition of a Core expression
-begins:\srcloc{coreSyn/CoreSyn.lhs}
-\begin{tightcode}
+begins\srcloc{coreSyn/CoreSyn.lhs}:
+\begin{mytightcode}
data CoreExpr binder bindee
= CoVar bindee
| CoLit CoreLiteral
...
type PlainCoreBinder = Id
type PlainCoreBindee = Id
-type PlainCoreExpr = CoreExpr PlainCoreBinder PlainCoreBindee
-\end{tightcode}
+type PlainCoreExpr = CoreExpr PlainCoreBinder PlainCoreBindee\end{mytightcode}
Most back-end passes use the parameterisation shown above, namely
-@PlainCoreExprs@,\srcloc{coreSyn/PlainCore.lhs} parameterised on @Id@
+@PlainCoreExprs@\srcloc{coreSyn/PlainCore.lhs}, parameterised on @Id@
for both binders and bindees.
An example of a pass that uses a different parameterisation is
-occurrence analysis,\srcloc{simplCore/OccurAnal.lhs} which gathers
+occurrence analysis\srcloc{simplCore/OccurAnal.lhs}, which gathers
up info about the {\em occurrences} of bound variables. It uses:
-\begin{tightcode}
+\begin{mytightcode}
data BinderInfo {\dcd\rm-- various things to record about binders...}
type TaggedBinder tag = (Id, tag)
type TaggedCoreExpr tag = CoreExpr (TaggedBinder tag) Id
-substAnalyseExpr :: PlainCoreExpr -> TaggedCoreExpr BinderInfo
-\end{tightcode}
+substAnalyseExpr :: PlainCoreExpr -> TaggedCoreExpr BinderInfo\end{mytightcode}
The pass's expression-mangling function then has the unsurprising type
shown above.
Core syntax has a ``twin'' datatype that is also sometimes useful:
-{\em annotated} Core syntax.\srcloc{coreSyn/AnnCoreSyn.lhs} This is a
+{\em annotated} Core syntax\srcloc{coreSyn/AnnCoreSyn.lhs}. This is a
datatype identical in form to Core syntax, but such that every
``node'' of a Core expression can be annotated with some information
of your choice. As an example, the type of a pass that attaches a
@Set@ of free variables to every subexpression in a Core expression
-might be:\srcloc{coreSyn/FreeVars.lhs}
-\begin{tightcode}
+might be\srcloc{coreSyn/FreeVars.lhs}:
+\begin{mytightcode}
freeVars :: PlainCoreExpr -> AnnCoreExpr Id Id (Set Id)
- {\dcd\rm-- parameterised on binders, bindees, and annotation}
-\end{tightcode}
+ {\dcd\rm-- parameterised on binders, bindees, and annotation}\end{mytightcode}
\subsection{Unboxing and other Core syntax details}
\label{sec:unboxing}
goes into the typechecker is quite different from what comes out.
Let's first consider this fragment of the abstract-syntax
-definition,\srcloc{abstractSyn/HsExpr.lhs} for Haskell explicit-list
+definition\srcloc{abstractSyn/HsExpr.lhs}, for Haskell explicit-list
expressions (Haskell report, section~3.5
\cite{hudak91a}):\nopagebreak[4]
-\begin{tightcode}
+\begin{mytightcode}
data Expr var pat =
...
| ExplicitList [Expr var pat]
type ProtoNameExpr = Expr ProtoName ProtoNamePat
type RenamedExpr = Expr Name RenamedPat
-type TypecheckedExpr = Expr Id TypecheckedPat
-\end{tightcode}
+type TypecheckedExpr = Expr Id TypecheckedPat\end{mytightcode}
an @ExplicitList@ appears only in typechecker input; an @ExplicitListOut@
is the corresponding construct that appears
only in the output, with the inferred type information attached.
\subsubsection{Basic datatypes in the compiler}
None of the internal datatypes in the example just given are
-particularly interesting except @Ids@.\srcloc{basicTypes/Id.lhs} A
+particularly interesting except @Ids@\srcloc{basicTypes/Id.lhs}. A
program variable, which enters the typechecker as a string, emerges as
an @Id@.
these basic data types. (Don't be too scared---@Ids@ are the hairiest
entities in the whole compiler!)
Here we go:
-\begin{tightcode}\codeallowbreaks{}
-data Id
+\begin{mytightcode}
+\codeallowbreaks{}data Id
= Id Unique {\dcd\rm-- key for fast comparison}
UniType {\dcd\rm-- Id's type; used all the time;}
IdInfo {\dcd\rm-- non-essential info about this Id;}
PragmaInfo {\dcd\rm-- user-specified pragmas about this Id;}
- IdDetails {\dcd\rm-- stuff about individual kinds of Ids.}
-\end{tightcode}
+ IdDetails {\dcd\rm-- stuff about individual kinds of Ids.}\end{mytightcode}
So, every @Id@ comes with:
\begin{enumerate}
\item
-A @Unique@,\srcloc{basicTypes/Unique.lhs} essentially a unique
+A @Unique@\srcloc{basicTypes/Unique.lhs}, essentially a unique
@Int@, for fast comparison;
\item
A @UniType@ (more on them below... section~\ref{sec:UniType}) giving the variable's
\end{enumerate}
Then the fun begins with @IdDetails@...
-\begin{tightcode}\codeallowbreaks{}
-data IdDetails
+\begin{mytightcode}
+\codeallowbreaks{}data IdDetails
{\dcd\rm---------------- Local values}
| TupleCon Int {\dcd\rm-- its arity}
- {\dcd\rm-- There are quite a few more flavours of {\tt IdDetails}...}
-\end{tightcode}
+ {\dcd\rm-- There are quite a few more flavours of {\tt IdDetails}...}\end{mytightcode}
% A @ShortName@,\srcloc{basicTypes/NameTypes.lhs} which includes a name string
% and a source-line location for the name's binding occurrence;
\subsubsection{@UniTypes@, representing types in the compiler}
\label{sec:UniType}
-Let us look further at @UniTypes@.\srcloc{uniType/} Their definition
+Let us look further at @UniTypes@\srcloc{uniType/}. Their definition
is:
-\begin{tightcode}\codeallowbreaks{}
-data UniType
+\begin{mytightcode}
+\codeallowbreaks{}data UniType
= UniTyVar TyVar
| UniFun UniType {\dcd\rm-- function type}
| UniTyVarTemplate TyVarTemplate
| UniForall TyVarTemplate
- UniType
-\end{tightcode}
+ UniType\end{mytightcode}
When the typechecker processes a source module, it adds @UniType@
information to all the basic entities (e.g., @Ids@), among other
places (see Section~\ref{sec:second-order} for more details). These
If a programmer wrote @(Eq a) => a -> [a]@, it would be represented
as:\footnote{The internal structures of @Ids@,
@Classes@, @TyVars@, and @TyCons@ are glossed over here...}
-\begin{tightcode}\codeallowbreaks{}
-UniForall {\dcd$\alpha$}
+\begin{mytightcode}
+\codeallowbreaks{}UniForall {\dcd$\alpha$}
(UniFun (UniDict {\dcd\em Eq} (UniTyVar {\dcd$\alpha$}))
(UniFun (UniTyVarTemplate {\dcd$\alpha$})
(UniData {\dcd\em listTyCon}
- [UniTyVarTemplate {\dcd$\alpha$}])))
-\end{tightcode}
+ [UniTyVarTemplate {\dcd$\alpha$}])))\end{mytightcode}
From this example we see:
\begin{itemize}
\item
about @Ids@ is now hidden in the
@IdInfo@\srcloc{basicTypes/IdInfo.lhs} datatype. It looks something
like:
-\begin{tightcode}\codeallowbreaks{}
-data IdInfo
+\begin{mytightcode}
+\codeallowbreaks{}data IdInfo
= NoIdInfo {\dcd\rm-- OK, we know nothing...}
| MkIdInfo
{\dcd\rm-- (used to match up workers/wrappers)}
UnfoldingInfo {\dcd\rm-- its unfolding}
UpdateInfo {\dcd\rm-- which args should be updated}
- SrcLocation {\dcd\rm-- source location of definition}
-\end{tightcode}
+ SrcLocation {\dcd\rm-- source location of definition}\end{mytightcode}
As you can see, we may accumulate a lot of information about an Id!
(The types for all the sub-bits are given in the same place...)
over to output-only translation machinery. Here are a few more
fragments of the @Expr@ type, all of which appear only in typechecker
output:
-\begin{tightcode}
+\begin{mytightcode}
data Expr var pat =
...
| DictLam [DictVar] (Expr var pat)
| DictApp (Expr var pat) [DictVar]
| Dictionary [DictVar] [Id]
| SingleDict DictVar
- ...
-\end{tightcode}
+ ...\end{mytightcode}
You needn't worry about this stuff:
After the desugarer gets through with such constructs, there's nothing
left but @Ids@, tuples, tupling functions, etc.,---that is, ``plain
\item
To hook your pass into the compiler, either add something directly to
-the @Main@ module of the compiler,\srcloc{main/Main.lhs} or into the
-Core-to-Core simplification driver,\srcloc{simplCore/SimplCore.lhs} or
-into the STG-to-STG driver.\srcloc{simplStg/SimplStg.lhs}
+the @Main@ module of the compiler\srcloc{main/Main.lhs}, or into the
+Core-to-Core simplification driver\srcloc{simplCore/SimplCore.lhs}, or
+into the STG-to-STG driver\srcloc{simplStg/SimplStg.lhs}.
Also add something to the compilation-system
driver\srcloc{ghc/driver/ghc.lprl}
the code you add to the compiler. To this end, here is a list of
monads already in use in the compiler:
\begin{description}
-\item[@UniqueSupply@ monad:] \srcloc{basicTypes/Unique.lhs}
+\item[@UniqueSupply@ monad:]\srcloc{basicTypes/Unique.lhs}%
To carry a name supply around; do a @getUnique@ when you
need one. Used in several parts of the compiler.
-\item[Typechecker monad:] \srcloc{typecheck/TcMonad.lhs}
+\item[Typechecker monad:]\srcloc{typecheck/TcMonad.lhs}%
Quite a complicated monad; carries around a substitution, some
source-location information, and a @UniqueSupply@; also plumbs
typechecker success/failure back up to the right place.
-\item[Desugarer monad:] \srcloc{deSugar/DsMonad.lhs}
+\item[Desugarer monad:]\srcloc{deSugar/DsMonad.lhs}%
Carries around a @UniqueSupply@ and source-location information (to
put in pattern-matching-failure error messages).
-\item[Code-generator monad:] \srcloc{codeGen/CgMonad.lhs}
+\item[Code-generator monad:]\srcloc{codeGen/CgMonad.lhs}%
Carries around an environment that maps variables to addressing modes
(e.g., ``in this block, @f@ is at @Node@ offset 3''); also, carries
around stack- and heap-usage information. Quite tricky plumbing, in
part so that the ``Abstract~C'' output will be produced lazily.
-\item[Monad for underlying I/O machinery:] \srcloc{ghc/lib/io/GlaIOMonad.lhs}
+\item[Monad for underlying I/O machinery:]\srcloc{ghc/lib/io/GlaIOMonad.lhs}%
This is the basis of our I/O implementation. See the paper about it
\cite{peyton-jones92b}.
\end{description}
way through the compiler. These are notable in that you are allowed
to see/make-use-of all of their constructors:
\begin{description}
-\item[Prefix form:]\srcloc{reader/PrefixSyn.lhs} You shouldn't need
-this.
+\item[Prefix form:]\srcloc{reader/PrefixSyn.lhs}%
+You shouldn't need this.
-\item[Abstract Haskell syntax:]\srcloc{abstractSyn/AbsSyn.lhs} Access
-via the @AbsSyn@ interface. An example of what you should {\em not}
+\item[Abstract Haskell syntax:]\srcloc{abstractSyn/AbsSyn.lhs}%
+Access via the @AbsSyn@ interface. An example of what you should {\em not}
do is import the @AbsSynFuns@ (or @HsBinds@ or ...) interface
directly. @AbsSyn@ tells you what you're supposed to see.
-\item[Core syntax:]\srcloc{coreSyn/*Core.lhs} Core syntax is
-parameterised, and you should access it {\em via one of the
+\item[Core syntax:]\srcloc{coreSyn/*Core.lhs}%
+Core syntax is parameterised, and you should access it {\em via one of the
parameterisations}. The most common is @PlainCore@; another is
@TaggedCore@. Don't use @CoreSyn@, though.
-\item[STG syntax:]\srcloc{stgSyn/StgSyn.lhs} Access via the @StgSyn@ interface.
+\item[STG syntax:]\srcloc{stgSyn/StgSyn.lhs}%
+Access via the @StgSyn@ interface.
-\item[Abstract~C syntax:]\srcloc{absCSyn/AbsCSyn.lhs} Access via the
-@AbsCSyn@ interface.
+\item[Abstract~C syntax:]\srcloc{absCSyn/AbsCSyn.lhs}%
+Access via the @AbsCSyn@ interface.
\end{description}
The second major group of datatypes are the ``basic entity''
datatypes; these are notable in that you don't need to know their
representation to use them. Several have already been mentioned:
\begin{description}
-\item[UniTypes:]\srcloc{uniType/AbsUniType.lhs} This is a gigantic
+\item[UniTypes:]\srcloc{uniType/AbsUniType.lhs}%
+This is a gigantic
interface onto the world of @UniTypes@; accessible via the
@AbsUniType@ interface. You should import operations on all the {\em
pieces} of @UniTypes@ (@TyVars@, @TyVarTemplates@, @TyCons@,
behind @AbsUniType@'s back!} (Otherwise, we won't discover the
shortcomings of the interface...)
-\item[Identifiers:]\srcloc{basicTypes/Id.lhs} Interface: @Id@.
+\item[Identifiers:]\srcloc{basicTypes/Id.lhs}%
+Interface: @Id@.
-\item[``Core'' literals:]\srcloc{basicTypes/CoreLit.lhs} These are
-the unboxed literals used in Core syntax onwards. Interface: @CoreLit@.
+\item[``Core'' literals:]\srcloc{basicTypes/CoreLit.lhs}%
+These are the unboxed literals used in Core syntax onwards. Interface: @CoreLit@.
-\item[Environments:]\srcloc{envs/GenericEnv.lhs}
+\item[Environments:]\srcloc{envs/GenericEnv.lhs}%
A generic environment datatype, plus a generally useful set of
operations, is provided via the @GenericEnv@ interface. We encourage
you to use this, rather than roll your own; then your code will
environment stuff (of which there is plenty) is built on @GenericEnv@,
so there are plenty of examples to follow.
-\item[@Uniques@:]\srcloc{basicTypes/Unique.lhs} Essentially @Ints@.
+\item[@Uniques@:]\srcloc{basicTypes/Unique.lhs}%
+Essentially @Ints@.
When you need something unique for fast comparisons. Interface:
@Unique@. This interface also provides a simple @UniqueSupply@ monad;
often just the thing...
-\item[Wired-in standard prelude knowledge:]\srcloc{prelude/} The
-compiler has to know a lot about the standard prelude. What it knows
+\item[Wired-in standard prelude knowledge:]\srcloc{prelude/}%
+The compiler has to know a lot about the standard prelude. What it knows
is in the @compiler/prelude@ directory; all the rest of the compiler
gets its prelude knowledge through the @AbsPrel@ interface.
The front end, discussed further in Section~\ref{sec:front-end}, is
the part that may report errors back to the user. The two main pieces
-are a {\em renamer},\srcloc{renamer/} which handles naming issues,
+are a {\em renamer}\srcloc{renamer/}, which handles naming issues,
including support of the Haskell module system, and the {\em
-typechecker}.\srcloc{typecheck/}
+typechecker}\srcloc{typecheck/}.
The front end operates on a collection of data types that we call
-``abstract syntax.''\srcloc{abstractSyn/} These types
+``abstract syntax\srcloc{abstractSyn/}.'' These types
match the Haskell language, construct for construct. For example,
if you write @... [ x | x <- [1..n] ] ...@, the typechecker
will actually see something like:
A conventional desugaring pass\srcloc{deSugar/} (basically Wadler's
Chapter~5 of Peyton Jones's 1987 implementation book
\cite{peyton-jones87b}) converts the typechecker's abstract-syntax output
-(with types attached) into the ``CoreSyntax''\srcloc{coreSyn/} data
+(with types attached) into the ``CoreSyntax\srcloc{coreSyn/}'' data
type. This data type is little more than the second-order polymorphic
lambda calculus and is intended to be the {\em lingua franca} of the
compiler's back end, including almost all of the optimisation passes.
that ``shared term graph'' language! (Who's fooling who here,
Simon?)} target architecture), then some STG-to-STG transformations,
and finally out of the functional world\srcloc{codeGen/} into
-``Abstract~C,''\srcloc{absCSyn/} a datatype intended as an adequate
+``Abstract~C\srcloc{absCSyn/},'' a datatype intended as an adequate
launching pad into both portable C and into get-your-hands-{\em
really}-dirty native-code generation for a particular instruction-set
architecture. We can generate C, or native-code for SPARCs and DEC
%
\newcommand{\onlyIfSrcLocs}[1]{#1}
%
+% Aran Lunzer told me to do this magic:
+\def\mytightcode{\codeaux{\leftmargin=0pt}}%
+\let\endmytightcode\endcodeaux
+% what he told me:
+%% CODE environment
+%% ----------------
+%% To get a single line of spacing above and below a code segment, with
+%% zero added indention (like a verbatim environment), and consistent appearance
+%% whether or not you use \codeallowbreaks:
+%%
+%% \def\code{\codeaux{\leftmargin=0pt}}
+%%
+%% Then for a normal, unbreakable section:
+%%
+%% \begin{code}
+%% first line of code
+%% ...
+%% last line of code\end{code}
+%%
+%% And for a breakable section:
+%%
+%% \begin{code}
+%% \codeallowbreaks{}first line of code
+%% ...
+%% last line of code\end{code}
+%%
+%%
+%% srcloc marginpars
+%% -----------------
+%%
+%% To ensure that marginpars appear on the same line as their associated text,
+%% especially in a description list, add a \mbox{} to their definition:
+%%
+%% \renewcommand{\srcloc}[1]{\mbox{}\marginpar{\footnotesize\tt #1}}
+%%
+%% This empty mbox doesn't introduce anything visible, but can screw up your
+%% spacing unless you are careful. So...
+%%
+%% Usage in a description list:
+%%
+%% \item[item description:]\srcloc{no spaces around!}%
+%% Here is the item text.
+%%
+%% In the middle of a sentence:
+%%
+%% And now for something\srcloc{completely} different.
+%%
+%% Near a period or colon (MUST come before the punctuation):
+%%
+%% Hello, good evening, and welcome\srcloc{foo}. Here is the fnord.
+%
\begin{document}
\title{How to Add an Optimisation Pass\\
to the Glasgow Haskell compiler\\
Besides the documents listed in the References below, there are
several internal compiler documents that come with the GHC
-distribution.\srcloc{ghc/docs/README}
+distribution\srcloc{ghc/docs/README}.
If you are hacking GHC, you should be on the @glasgow-haskell-users@
mailing list. Send mail to
%* *
%****************************************************************
-\newcommand{\srcloc}[1]{\marginpar{\footnotesize\tt #1}}
+\newcommand{\srcloc}[1]{\mbox{}\marginpar{\footnotesize\tt #1}}
%
% to avoid src-location marginpars, put this in your doc's pre-amble.
%\renewcommand{\srcloc}[1]{}
--- /dev/null
+\documentstyle[a4wide,grasp]{article}
+\renewcommand{\textfraction}{0.1}
+\renewcommand{\floatpagefraction}{0.9}
+\renewcommand{\dblfloatpagefraction}{0.9}
+
+\sloppy
+
+
+\begin{document}
+
+\title{GHC prelude: types and operations}
+\author{Simon L Peyton Jones \and John Launchbury \and Will Partain}
+
+\maketitle
+\tableofcontents
+
+This ``state interface document'' corresponds to Glasgow Haskell
+version~0.23.
+
+\section{Really primitive stuff}
+
+This section defines all the types which are primitive in Glasgow Haskell, and the
+operations provided for them.
+
+A primitive type is one which cannot be defined in Haskell, and which is
+therefore built into the language and compiler.
+Primitive types are always unboxed; that is, a value of primitive type cannot be
+bottom.
+
+Primitive values are often represented by a simple bit-pattern, such as @Int#@,
+@Float#@, @Double#@. But this is not necessarily the case: a primitive value
+might be represented by a pointer to a heap-allocated object. Examples include
+@Array#@, the type of primitive arrays. You might think this odd: doesn't being
+heap-allocated mean that it has a box? No, it does not. A primitive array is
+heap-allocated because it is too big a value to fit in a register, and would be
+too expensive to copy around; in a sense, it is accidental that it is represented
+by a pointer. If a pointer represents a primitive value, then it really does
+point to that value: no unevaluated thunks, no indirections...nothing can be at
+the other end of the pointer than the primitive value.
+
+This section also describes a few non-primitive types, which are needed
+to express the result types of some primitive operations.
+
+\subsection{Character and numeric types}
+
+There are the following obvious primitive types:
+@
+type Char#
+type Int# -- see also Word# and Addr#, later
+type Float#
+type Double#
+@
+If you want to know their exact equivalents in C, see
+@ghc/includes/StgTypes.lh@ in the GHC source.
+
+Literals for these types may be written as follows:
+@
+1# an Int#
+1.2# a Float#
+1.34## a Double#
+'a'# a Char#; for weird characters, use '\o<octal>'#
+"a"# an Addr# (a `char *')
+@
+
+\subsubsection{Comparison operations}
+@
+{gt,ge,eq,ne,lt,le}Char# :: Char# -> Char# -> Bool
+ -- ditto for Int#, Word#, Float#, Double#, and Addr#
+@
+
+\subsubsection{Unboxed-character operations}
+@
+ord# :: Char# -> Int#
+chr# :: Int# -> Char#
+@
+
+\subsubsection{Unboxed-@Int@ operations}
+@
+{plus,minus,times,quot,div,rem}Int# :: Int# -> Int# -> Int#
+negateInt# :: Int# -> Int#
+@
+NB: No error/overflow checking!
+
+\subsubsection{Unboxed-@Float@ and @Double@ operations}
+@
+{plus,minus,times,divide}Float# :: Float# -> Float# -> Float#
+negateFloat# :: Float# -> Float#
+
+float2Int# :: Float# -> Int# -- just a cast, no checking!
+int2Float# :: Int# -> Float#
+
+expFloat# :: Float# -> Float#
+logFloat# :: Float# -> Float#
+sqrtFloat# :: Float# -> Float#
+sinFloat# :: Float# -> Float#
+cosFloat# :: Float# -> Float#
+tanFloat# :: Float# -> Float#
+asinFloat# :: Float# -> Float#
+acosFloat# :: Float# -> Float#
+atanFloat# :: Float# -> Float#
+sinhFloat# :: Float# -> Float#
+coshFloat# :: Float# -> Float#
+tanhFloat# :: Float# -> Float#
+powerFloat# :: Float# -> Float# -> Float#
+@
+There's an exactly-matching set of unboxed-@Double@ ops; replace
+@Float#@ with @Double#@ in the list above. There are two
+coercion functions for @Float#@/@Double#@:
+@
+float2Double# :: Float# -> Double#
+double2Float# :: Double# -> Float#
+@
+The primitive versions of @encodeFloat@/@decodeFloat@:
+@
+encodeFloat# :: Int# -> Int# -> ByteArray# -- Integer mantissa
+ -> Int# -- Int exponent
+ -> Float#
+
+decodeFloat# :: Float#
+ -> _ReturnIntAndGMP
+@
+(And the same for @Double#@s.)
+
+\subsection{Operations on/for @Integers@ (interface to GMP)}
+\label{sect:horrid-Integer-pairing-types}
+
+We implement @Integers@ (arbitrary-precision integers) using the GNU
+multiple-precision (GMP) package.
+
+The data type for @Integer@ must mirror that for @MP_INT@ in @gmp.h@
+(see @gmp.info@). It comes out as:
+@
+data Integer = J# Int# Int# ByteArray#
+@
+So, @Integer@ is really just a ``pairing'' type for a particular
+collection of primitive types.
+
+The operations in the GMP return other combinations of
+GMP-plus-something, so we need ``pairing'' types for those, too:
+@
+type _ReturnGMP = Integer -- synonym
+data _Return2GMPs = _Return2GMPs Int# Int# ByteArray#
+ Int# Int# ByteArray#
+data _ReturnIntAndGMP = _ReturnIntAndGMP Int#
+ Int# Int# ByteArray#
+
+-- ????? something to return a string of bytes (in the heap?)
+@
+The primitive ops to support @Integers@ use the ``pieces'' of the
+representation, and are as follows:
+@
+negateInteger# :: Int# -> Int# -> ByteArray# -> Integer
+
+{plus,minus,times}Integer# :: Int# -> Int# -> ByteArray#
+ -> Int# -> Int# -> ByteArray#
+ -> Integer
+
+cmpInteger# :: Int# -> Int# -> ByteArray#
+ -> Int# -> Int# -> ByteArray#
+ -> Int# -- -1 for <; 0 for ==; +1 for >
+
+divModInteger#, quotRemInteger#
+ :: Int# -> Int# -> ByteArray#
+ -> Int# -> Int# -> ByteArray#
+ -> _Return2GMPs
+
+integer2Int# :: Int# -> Int# -> ByteArray#
+ -> Int#
+
+int2Integer# :: Int# -> Integer -- NB: no error-checking on these two!
+word2Integer# :: Word# -> Integer
+
+addr2Integer# :: Addr# -> Integer
+ -- the Addr# is taken to be a `char *' string
+ -- to be converted into an Integer
+@
+
+
+\subsection{Words and addresses}
+
+A @Word#@ is used for bit-twiddling operations. It is the same size as
+an @Int#@, but has no sign nor any arithmetic operations.
+@
+type Word# -- Same size/etc as Int# but *unsigned*
+type Addr# -- A pointer from outside the "Haskell world" (from C, probably);
+ -- described under "arrays"
+@
+@Word#@s and @Addr#@s have the usual comparison operations.
+Other unboxed-@Word@ ops (bit-twiddling and coercions):
+@
+and#, or# :: Word# -> Word# -> Word#
+
+not# :: Word# -> Word#
+
+shiftL#, shiftRA#, shiftRL# :: Word# -> Int# -> Word#
+ -- shift left, right arithmetic, right logical
+
+iShiftL#, iShiftRA#, iShiftRL# :: Int# -> Int# -> Int#
+ -- same shift ops, but on Int#s
+
+int2Word# :: Int# -> Word# -- just a cast, really
+word2Int# :: Word# -> Int#
+@
+
+Unboxed-@Addr@ ops (C casts, really):
+@
+int2Addr# :: Int# -> Addr#
+addr2Int# :: Addr# -> Int#
+@
+Operations for indexing off of C pointers (@Addr#@s) to snatch values
+are listed under ``arrays''.
+
+\subsection{Arrays}
+
+The type @Array# elt@ is the type of primitive,
+unboxed arrays of values of type @elt@.
+@
+type Array# elt
+@
+@Array#@ is more primitive than a Haskell
+array --- indeed, Haskell arrays are implemented using @Array#@ ---
+in that an @Array#@ is indexed only by @Int#@s, starting at zero. It is also
+more primitive by virtue of being unboxed. That doesn't mean that it isn't
+a heap-allocated object --- of course, it is. Rather, being unboxed means
+that it is represented by a pointer to the array itself, and not to a thunk
+which will evaluate to the array (or to bottom).
+The components of an @Array#@ are themselves boxed.
+
+The type @ByteArray#@ is similar to @Array#@, except that it contains
+just a string of (non-pointer) bytes.
+@
+type ByteArray#
+@
+Arrays of these types are useful when a Haskell program wishes to
+construct a value to pass to a C procedure. It is also possible to
+use them to build (say) arrays of unboxed characters for internal use
+in a Haskell program. Given these uses, @ByteArray#@ is deliberately
+a bit vague about the type of its components. Operations are provided
+to extract values of type @Char#@, @Int#@, @Float#@, @Double#@, and
+@Addr#@ from arbitrary offsets within a @ByteArray#@. (For type @Foo#@,
+the $i$th offset gets you the $i$th @Foo#@, not the @Foo#@ at byte-position $i$. Mumble.)
+(If you want a @Word#@, grab an @Int#@, then coerce it.)
+
+Lastly, we have static byte-arrays, of type @Addr#@ [mentioned
+previously]. (Remember the duality between arrays and pointers in C.)
+Arrays of this types are represented by a pointer to an array in the
+world outside Haskell, so this pointer is not followed by the garbage
+collector. In other respects they are just like @ByteArray#@. They
+are only needed in order to pass values from C to Haskell.
+
+\subsubsection{Reading and writing.}
+
+Primitive arrays are linear, and indexed starting at zero.
+
+The size and indices of a @ByteArray#@, @Addr#@, and
+@MutableByteArray#@ are all in bytes. It's up to the program to
+calculate the correct byte offset from the start of the array. This
+allows a @ByteArray#@ to contain a mixture of values of different
+type, which is often needed when preparing data for and unpicking
+results from C. (Umm... not true of indices... WDP 95/09)
+
+{\em Should we provide some @sizeOfDouble#@ constants?}
+
+Out-of-range errors on indexing should be caught by the code which
+uses the primitive operation; the primitive operations themselves do
+{\em not} check for out-of-range indexes. The intention is that the
+primitive ops compile to one machine instruction or thereabouts.
+
+We use the terms ``reading'' and ``writing'' to refer to accessing {\em mutable}
+arrays (see Section~\ref{sect:mutable}), and ``indexing''
+to refer to reading a value from an {\em immutable}
+array.
+
+If you want to read/write a @Word#@, read an @Int#@ and coerce.
+
+Immutable byte arrays are straightforward to index (all indices in bytes):
+@
+indexCharArray# :: ByteArray# -> Int# -> Char#
+indexIntArray# :: ByteArray# -> Int# -> Int#
+indexAddrArray# :: ByteArray# -> Int# -> Addr#
+indexFloatArray# :: ByteArray# -> Int# -> Float#
+indexDoubleArray# :: ByteArray# -> Int# -> Double#
+
+indexCharOffAddr# :: Addr# -> Int# -> Char#
+indexIntOffAddr# :: Addr# -> Int# -> Int#
+indexFloatOffAddr# :: Addr# -> Int# -> Float#
+indexDoubleOffAddr# :: Addr# -> Int# -> Double#
+indexAddrOffAddr# :: Addr# -> Int# -> Addr# -- Get an Addr# from an Addr# offset
+@
+The last of these, @indexAddrOffAddr#@, extracts an @Addr#@ using an offset
+from another @Addr#@, thereby providing the ability to follow a chain of
+C pointers.
+
+Something a bit more interesting goes on when indexing arrays of boxed
+objects, because the result is simply the boxed object. So presumably
+it should be entered --- we never usually return an unevaluated
+object! This is a pain: primitive ops aren't supposed to do
+complicated things like enter objects. The current solution is to
+return a lifted value, but I don't like it!
+@
+indexArray# :: Array# elt -> Int# -> _Lift elt -- Yuk!
+@
+
+\subsubsection{The state type}
+
+The primitive type @State#@ represents the state of a state transformer.
+It is parameterised on the desired type of state, which serves to keep
+states from distinct threads distinct from one another. But the {\em only}
+effect of this parameterisation is in the type system: all values of type
+@State#@ are represented in the same way. Indeed, they are all
+represented by nothing at all! The code generator ``knows'' to generate no
+code, and allocate no registers etc, for primitive states.
+@
+type State# s
+@
+
+The type @_RealWorld@ is truly opaque: there are no values defined
+of this type, and no operations over it. It is ``primitive'' in that
+sense---but it is {\em not unboxed!} Its only role in life is to be the type
+which distinguishes the @PrimIO@ state transformer (see
+Section~\ref{sect:io-spec}).
+@
+data _RealWorld
+@
+
+\subsubsection{States}
+
+A single, primitive, value of type @State# _RealWorld@ is provided.
+@
+realWorld# :: State# _RealWorld
+@
+(Note: in the compiler, not a @PrimOp@; just a mucho magic @Id@.)
+
+\subsection{State pairing types}
+\label{sect:horrid-pairing-types}
+
+This subsection defines some types which, while they aren't quite primitive
+because we can define them in Haskell, are very nearly so. They define
+constructors which pair a primitive state with a value of each primitive type.
+They are required to express the result type of the primitive operations in the
+state monad.
+@
+data StateAndPtr# s elt = StateAndPtr# (State# s) elt
+
+data StateAndChar# s = StateAndChar# (State# s) Char#
+data StateAndInt# s = StateAndInt# (State# s) Int#
+data StateAndWord# s = StateAndWord# (State# s) Word#
+data StateAndFloat# s = StateAndFloat# (State# s) Float#
+data StateAndDouble# s = StateAndDouble# (State# s) Double#
+data StateAndAddr# s = StateAndAddr# (State# s) Addr#
+
+data StateAndStablePtr# s a = StateAndStablePtr# (State# s) (StablePtr# a)
+data StateAndMallocPtr# s = StateAndMallocPtr# (State# s) MallocPtr#
+data StateAndSynchVar# s a = StateAndSynchVar# (State# s) (SynchVar# a)
+
+data StateAndArray# s elt = StateAndArray# (State# s) (Array# elt)
+data StateAndMutableArray# s elt = StateAndMutableArray# (State# s) (MutableArray# s elt)
+data StateAndByteArray# s = StateAndByteArray# (State# s) ByteArray#
+data StateAndMutableByteArray# s = StateAndMutableByteArray# (State# s) (MutableByteArray# s)
+@
+
+
+\subsection{Mutable arrays}
+\label{sect:mutable}
+
+Corresponding to @Array#@ and @ByteArray#@,
+we have the types of mutable versions of each.
+In each case, the representation is a pointer
+to a suitable block of (mutable) heap-allocated storage.
+@
+type MutableArray# s elt
+type MutableByteArray# s
+@
+\subsubsection{Allocation.}
+
+Mutable arrays can be allocated.
+Only pointer-arrays are initialised; arrays of non-pointers are filled
+in by ``user code'' rather than by the array-allocation primitive.
+Reason: only the pointer case has to worry about GC striking with a
+partly-initialised array.
+@
+newArray# :: Int# -> elt -> State# s -> StateAndMutableArray# s elt
+
+newCharArray# :: Int# -> State# s -> StateAndMutableByteArray# s
+newIntArray# :: Int# -> State# s -> StateAndMutableByteArray# s
+newAddrArray# :: Int# -> State# s -> StateAndMutableByteArray# s
+newFloatArray# :: Int# -> State# s -> StateAndMutableByteArray# s
+newDoubleArray# :: Int# -> State# s -> StateAndMutableByteArray# s
+@
+The size of a @ByteArray#@ is given in bytes.
+
+\subsubsection{Reading and writing}
+
+%OLD: Remember, offsets in a @MutableByteArray#@ are in bytes.
+@
+readArray# :: MutableArray# s elt -> Int# -> State# s -> StateAndPtr# s elt
+readCharArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndChar# s
+readIntArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndInt# s
+readAddrArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndAddr# s
+readFloatArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndFloat# s
+readDoubleArray# :: MutableByteArray# s -> Int# -> State# s -> StateAndDouble# s
+
+writeArray# :: MutableArray# s elt -> Int# -> elt -> State# s -> State# s
+writeCharArray# :: MutableByteArray# s -> Int# -> Char# -> State# s -> State# s
+writeIntArray# :: MutableByteArray# s -> Int# -> Int# -> State# s -> State# s
+writeAddrArray# :: MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s
+writeFloatArray# :: MutableByteArray# s -> Int# -> Float# -> State# s -> State# s
+writeDoubleArray# :: MutableByteArray# s -> Int# -> Double# -> State# s -> State# s
+@
+
+\subsubsection{Equality.}
+
+One can take ``equality'' of mutable arrays. What is compared is the
+{\em name} or reference to the mutable array, not its contents.
+@
+sameMutableArray# :: MutableArray# s elt -> MutableArray# s elt -> Bool
+sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Bool
+@
+
+\subsubsection{Freezing mutable arrays}
+
+Only unsafe-freeze has a primitive. (Safe freeze is done directly in Haskell
+by copying the array and then using @unsafeFreeze@.)
+@
+unsafeFreezeArray# :: MutableArray# s elt -> State# s -> StateAndArray# s elt
+unsafeFreezeByteArray# :: MutableByteArray# s -> State# s -> StateAndByteArray# s
+@
+
+\subsubsection{Stable pointers}
+
+{\em Andy's comment.} {\bf Errors:} The following is not strictly true: the current
+implementation is not as polymorphic as claimed. The reason for this
+is that the C programmer will have to use a different entry-routine
+for each type of stable pointer. At present, we only supply a very
+limited number (1) of these routines. It might be possible to
+increase the range of these routines by providing general purpose
+entry points to apply stable pointers to (stable pointers to)
+arguments and to enter (stable pointers to) boxed primitive values.
+{\em End of Andy's comment.}
+
+A stable pointer is a name for a Haskell object which can be passed to the
+external world. It is ``stable'' in the sense that the name does not change when
+the Haskell garbage collector runs --- in contrast to the address of the object
+which may well change.
+
+The stable pointer type is parameterised by the type of the thing which is named.
+@
+type StablePtr# a
+@
+A stable pointer is represented by an index into the (static)
+@StablePointerTable@. The Haskell garbage collector treats the
+@StablePointerTable@ as a source of roots for GC.
+
+The @makeStablePointer@ function converts a value into a stable pointer.
+It is part of the @PrimIO@ monad, because we want to be sure we don't
+allocate one twice by accident, and then only free one of the copies.
+@
+makeStablePointer# :: a -> State# _RealWorld -> StateAndStablePtr# _RealWorld a
+freeStablePointer# :: StablePtr# a -> State# _RealWorld -> State# _RealWorld
+deRefStablePointer# :: StablePtr# a -> State# _RealWorld -> StateAndPtr _RealWorld a
+@
+There is also a C procedure @FreeStablePtr@ which frees a stable pointer.
+
+\subsubsection{``Malloc'' pointers}
+
+A ``malloc'' pointer is an ordinary pointer from outside the Haskell world
+(i.e., from the C world) where the Haskell world has been told ``Let me
+know when you're finished with this ...''.
+
+The ``malloc'' pointer type is just a special @Addr#@ ({\em not} parameterised).
+@
+type MallocPtr#
+@
+{\em ToDo: say more about this and how it's used...}
+
+The main point is that when Haskell discards a
+value of type @MallocPtr#@, it calls the procedure @FreeMallocPtr@, which
+must be provided by the C world. @FreeMallocPtr@ might in turn call
+the GHC-provided procedure @FreeStablePtr@, to deallocate a stable pointer.
+No other GHC runtime system procedures should be called by @FreeMallocPtr@.
+
+(Implementation: a linked list of all @MallocPtr#@s is maintained to allow the
+garbage collector to detect when a @MallocPtr#@ becomes garbage.)
+
+Like @Array@, @MallocPtr#@s are represented by heap objects.
+
+{\bf ToDo --- Important:} Ian Poole reports a need for functions to return a list of
+CHPs. Should we add a @CHeapPtrArray@ type too? or just
+hack something up?
+
+The only Haskell operation we might want on @MallocPtr#@s is an
+equality test. However, this is easily implemented if desired:
+@
+> eqCHP x y = (_runST (_ccall_ equal x y) == 1::Int)
+
+C> equal (x, y)
+C> {
+C> return (x == y ? 1 : 0);
+C> }
+@
+
+The C world must provide a function @FreeCHeapPointer@ which
+will be called (with a C Heap pointer as argument) when the garbage
+collector releases a CHP.
+
+{\bf ToDo:} Decide whether @FreeCHeapPointer@ is allowed to call on a
+stable pointer. (I sincerely hope not since we will still be in the
+GC at this point.)
+
+\subsubsection{Synchronizing variables (I-vars, M-vars)}
+
+ToDo ToDo ToDo
+
+@
+type SynchVar# s elt -- primitive
+
+newSynchVar#:: State# s -> StateAndSynchVar# s elt
+
+takeMVar# :: SynchVar# s elt -> State# s -> StateAndPtr# s elt
+putMVar# :: SynchVar# s elt -> State# s -> State# s
+
+readIVar# :: SynchVar# s elt -> State# s -> StateAndPtr# s elt
+writeIVar# :: SynchVar# s elt -> State# s -> State# s
+@
+
+\subsubsection{Controlling the garbage collector}
+
+The C function {\tt PerformGC\/}, allows the C world to force Haskell
+to do a garbage collection. It can only be called while Haskell
+is performing a C Call.
+
+Note that this function can be used to define a Haskell IO operation
+with the same effect:
+@
+> performGCIO :: PrimIO ()
+> performGCIO = _ccall_gc_ PerformGC
+@
+
+{\bf ToDo:} Is there any need for abnormal/normal termination to force
+a GC too? Is there any need for a function that provides finer
+control over GC: argument = amount of space required; result = amount
+of space recovered.
+
+\subsection{@spark#@ primitive operation (for parallel execution)}
+
+{\em ToDo: say something} It's used in the unfolding for @par@.
+
+\subsection{The @errorIO#@ primitive operation}
+
+The @errorIO#@ primitive takes an argument of type @PrimIO@. It aborts execution of
+the current program, and continues instead by performing the given @PrimIO@ value
+on the current state of the world.
+@
+errorIO# :: PrimIO () -> a
+@
+
+\subsection{C Calls}
+
+{\bf ToDo:} current implementation has state variable as second
+argument not last argument.
+
+The @ccall#@ primitive can't be given an ordinary type, because it has
+a variable number of arguments. The nearest we can get is:
+@
+ccall# :: CRoutine -> a1# -> ... -> an# -> State# _RealWorld -> StateAndR# _RealWorld
+@
+where the type variables @a1#@\ldots@an#@ and @r#@ can be instantiated by any
+primitive type, and @StateAndR#@ is the appropriate pairing type from
+Section~\ref{sect:horrid-pairing-types}. The @CRoutine@
+isn't a proper Haskell type at all; it just reminds us that @ccall#@ needs to
+know what C routine to call.
+
+This notation is really short for a massive family of @ccall#@ primitives, one
+for each combination of types. (Of course, the compiler simply remembers the
+types involved, and generates appropriate code when it finally spits out the C.)
+
+Unlike all the other primitive operators, @ccall#@ is not bound to an in-scope
+identifier. The only way it is possible to generate a @ccall#@ is via the
+@_ccall_@ construct.
+
+All this applies equally to @casm#@:
+@
+casm# :: CAsmString -> a1# -> ... -> an# -> State# _RealWorld -> StateAndR# _RealWorld
+@
+
+%------------------------------------------------------------
+\section{Library stuff built with the Really Primitive Stuff}
+
+\subsection{The state transformer monad}
+
+\subsubsection{Types}
+
+A state transformer is a function from a state to a pair of a result and a new
+state.
+@
+type _ST s a = _State s -> (a, _State s)
+@
+The @_ST@ type is {\em abstract}, so that the programmer cannot see its
+representation. If he could, he could write bad things like:
+@
+bad :: _ST s a
+bad = \s -> ...(f s)...(g s)...
+@
+Here, @s@ is duplicated, which would be bad news.
+
+A state is represented by a primitive state value, of type @State# s@,
+wrapped up in a @_State@ constructor. The reason for boxing it in this
+way is so that we can be strict or lazy in the state. (Remember, all
+primitive types are unboxed, and hence can't be bottom; but types built
+with @data@ are all boxed.)
+@
+data _State s = S# (State# s)
+@
+
+\subsubsection{The state transformer combinators}
+
+Now for the combinators, all of which live inside the @_ST@
+abstraction. Notice that @returnST@ and @thenST@ are lazy in the
+state.
+@
+returnST :: a -> _ST s a
+returnST a s = (a, s)
+
+thenST :: _ST s a -> (a -> _ST s b) -> _ST s b
+thenST m k s = let (r,new_s) = m s
+ in
+ k r new_s
+
+fixST :: (a -> _ST s a) -> _ST s a
+fixST k s = let ans = k r s
+ (r,new_s) = ans
+ in
+ ans
+@
+The interesting one is, of course, @_runST@. We can't infer its type!
+(It has a funny name because it must be wired into the compiler.)
+@
+-- _runST :: forall a. (forall s. _ST s a) -> a
+_runST m = case m (S# realWorld#) of
+ (r,_) -> r
+@
+
+\subsubsection{Other useful combinators}
+
+There are various other standard combinators, all defined in terms the
+fundamental combinators above. The @seqST@ combinator is like
+@thenST@, except that it discards the result of the first state
+transformer:
+@
+seqST :: _ST s a -> _ST s b -> _ST s b
+seqST m1 m2 = m1 `thenST` (\_ -> m2)
+@
+
+We also have {\em strict} (... in the state...) variants of the
+then/return combinators (same types as their pals):
+@
+returnStrictlyST a s@(S# _) = (a, s)
+
+thenStrictlyST m k s@(S# _)
+ = case (m s) of { (r, new_s@(S# _)) ->
+ k r new_s }
+
+seqStrictlyST m k = ... ditto, for seqST ...
+@
+
+The combinator @listST@ takes a list of state transformers, and
+composes them in sequence, returning a list of their results:
+@
+listST :: [_ST s a] -> _ST s [a]
+listST [] = returnST []
+listST (m:ms) = m `thenST` \ r ->
+ listST ms `thenST` \ rs ->
+ returnST (r:rs)
+@
+The @mapST@ combinator ``lifts'' a function from a value to state
+transformers to one which works over a list of values:
+@
+mapST :: (a -> _ST s b) -> [a] -> _ST s [b]
+mapST f ms = listST (map f ms)
+@
+The @mapAndUnzipST@ combinator is similar to @mapST@, except that here the
+function returns a pair:
+@
+mapAndUnzipST :: (a -> _ST s (b,c)) -> [a] -> _ST s ([b],[c])
+mapAndUnzipST f (m:ms)
+ = f m `thenST` \ ( r1, r2) ->
+ mapAndUnzipST f ms `thenST` \ (rs1, rs2) ->
+ returnST (r1:rs1, r2:rs2)
+@
+
+\subsubsection{The @PrimIO@ monad}
+\label{sect:io-spec}
+
+The @PrimIO@ type is defined in as a state transformer which manipulates the
+@_RealWorld@.
+@
+type PrimIO a = _ST _RealWorld a -- Transparent
+@
+The @PrimIO@ type is an ordinary type synonym, transparent to the programmer.
+
+The type @_RealWorld@ and value @realWorld#@ do not need to be hidden (although
+there is no particular point in exposing them). Even having a value of type
+@realWorld#@ does not compromise safety, since the type @_ST@ is hidden.
+
+It is type-correct to use @returnST@ in an I/O context, but it is a
+bit more efficient to use @returnPrimIO@. The latter is strict in the
+state, which propagates backwards to all the earlier combinators
+(provided they are unfolded). Why is it safe for @returnPrimIO@ to be
+strict in the state? Because every context in which an I/O state
+transformer is used will certainly evaluate the resulting state; it is
+the state of the real world!
+@
+returnPrimIO :: a -> PrimIO a
+returnPrimIO a s@(S# _) -> (a, s)
+@
+We provide strict versions of the other combinators too.
+@
+thenPrimIO m k s = case m s of
+ (r,s) -> k r s
+@
+@fixPrimIO@ has to be lazy, though!
+@
+fixPrimIO = fixST
+@
+The other combinators are just the same as before, but use the strict
+@thenPrimIO@ and @returnPrimIO@ for efficiency.
+@
+foldrPrimIO f z [] = z
+foldrPrimIO f z (m:ms) = foldrPrimIO f z ms `thenPrimIO` \ ms' ->
+ f m ms'
+
+listPrimIO ms = foldrPrimIO (\ a xs -> a `thenPrimIO` \ x -> returnPrimIO (x : xs))
+ (returnPrimIO []) ms
+
+mapPrimIO f ms = listPrimIO (map f ms)
+
+mapAndUnzipPrimIO f (m:ms)
+ = f m `thenPrimIO` \ ( r1, r2) ->
+ mapAndUnzipPrimIO f ms `thenPrimIO` \ (rs1, rs2) ->
+ returnPrimIO (r1:rs1, r2:rs2)
+@
+
+\subsection{Arrays}
+
+\subsubsection{Types}
+
+@
+data Array ix elt = _Array (ix,ix) (Array# elt)
+data _ByteArray ix = _ByteArray (ix,ix) ByteArray#
+
+data _MutableArray s ix elt = _MutableArray (ix,ix) (MutableArray# s elt)
+data _MutableByteArray s ix = _MutableByteArray (ix,ix) (MutableByteArray# s)
+@
+
+\subsubsection{Operations on immutable arrays}
+
+Ordinary array indexing is straightforward.
+@
+(!) :: Ix ix => Array ix elt -> ix -> elt
+@
+QUESTIONs: should @_ByteArray@s be indexed by Ints or ix? With byte offsets
+or sized ones? (sized ones [WDP])
+@
+indexCharArray :: Ix ix => _ByteArray ix -> ix -> Char
+indexIntArray :: Ix ix => _ByteArray ix -> ix -> Int
+indexAddrArray :: Ix ix => _ByteArray ix -> ix -> _Addr
+indexFloatArray :: Ix ix => _ByteArray ix -> ix -> Float
+indexDoubleArray :: Ix ix => _ByteArray ix -> ix -> Double
+@
+@Addr@s are indexed straightforwardly by @Int@s. Unlike the primitive
+operations, though, the offsets assume that the array consists entirely of the
+type of value being indexed, and so there's an implicit multiplication by
+the size of that value. To access @Addr@s with mixed values requires
+you to do a DIY job using the primitives.
+@
+indexAddrChar :: Addr -> Int -> Char
+...etc...
+indexStaticCharArray :: Addr -> Int -> Char
+indexStaticIntArray :: Addr -> Int -> Int
+indexStaticFloatArray :: Addr -> Int -> Float
+indexStaticDoubleArray :: Addr -> Int -> Double
+indexStaticArray :: Addr -> Int -> Addr
+@
+
+\subsubsection{Operations on mutable arrays}
+@
+newArray :: Ix ix => (ix,ix) -> elt -> _ST s (_MutableArray s ix elt)
+newCharArray :: Ix ix => (ix,ix) -> _ST s (_MutableByteArray s ix)
+...
+@
+
+@
+readArray :: Ix ix => _MutableArray s ix elt -> ix -> _ST s elt
+readCharArray :: Ix ix => _MutableByteArray s ix -> ix -> _ST s Char
+...
+@
+
+@
+writeArray :: Ix ix => _MutableArray s ix elt -> ix -> elt -> _ST s ()
+writeCharArray :: Ix ix => _MutableByteArray s ix -> ix -> Char -> _ST s ()
+...
+@
+
+@
+freezeArray :: Ix ix => _MutableArray s ix elt -> _ST s (Array ix elt)
+freezeCharArray :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix Char)
+...
+@
+
+We have no need on one-function-per-type for unsafe freezing:
+@
+unsafeFreezeArray :: Ix ix => _MutableArray s ix elt -> _ST s (Array ix elt)
+unsafeFreezeByteArray :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix elt)
+@
+
+Sometimes we want to snaffle the bounds of one of these beasts:
+@
+boundsOfArray :: Ix ix => _MutableArray s ix elt -> (ix, ix)
+boundsOfByteArray :: Ix ix => _MutableByteArray s ix -> (ix, ix)
+@
+
+Lastly, ``equality'':
+@
+sameMutableArray :: _MutableArray s ix elt -> _MutableArray s ix elt -> Bool
+sameMutableByteArray :: _MutableByteArray s ix -> _MutableByteArray s ix -> Bool
+@
+
+
+\subsection{Variables}
+
+\subsubsection{Types}
+
+Mutable variables are (for now anyway) implemented as arrays. The @MutableVar@ type
+is opaque, so we can change the implementation later if we want.
+@
+type MutableVar s a = _MutableArray s Int a
+@
+
+\subsubsection{Operations}
+@
+newVar :: a -> _ST s (MutableVar s a)
+readVar :: MutableVar s a -> _ST s a
+writeVar :: MutableVar s a -> a -> _ST s ()
+sameVar :: MutableVar s a -> MutableVar s a -> Bool
+@
+
+\subsection{Stable pointers}
+
+Nothing exciting here, just simple boxing up.
+@
+data _StablePtr a = _StablePtr (StablePtr# a)
+
+makeStablePointer :: a -> _StablePtr a
+freeStablePointer :: _StablePtr a -> PrimIO ()
+@
+
+\subsection{``Malloc'' pointers}
+
+Again, just boxing up.
+@
+data _MallocPtr = _MallocPtr MallocPtr#
+@
+
+\subsection{C calls}
+
+Everything in this section goes for @_casm_@ too.
+
+{\em ToDo: mention @_ccall_gc_@ and @_casm_gc_@...}
+
+The @_ccall_@ construct has the following form:
+$$@_ccall_@~croutine~a_1~\ldots~a_n$$
+This whole construct has type $@PrimIO@~res$.
+The rules are these:
+\begin{itemize}
+\item
+The first ``argument'', $croutine$, must be the literal name of a C procedure.
+It cannot be a Haskell expression which evaluates to a string, etc; it must be
+simply the name of the procedure.
+\item
+The arguments $a_1, \ldots,a_n$ must be of {\em C-callable} type.
+\item
+The whole construct has type $@PrimIO@~ty$, where $ty$ is a {\em C-returnable} type.
+\end{itemize}
+A {\em boxed-primitive} type is both C-callable and C-returnable.
+A boxed primitive type is anything declared by:
+@
+data T = C# t
+@
+where @t@ is a primitive type. Note that
+programmer-defined boxed-primitive types are perfectly OK:
+@
+data Widget = W# Int#
+data Screen = S# CHeapPtr#
+@
+
+There are other types that can be passed to C (C-callable). This
+table summarises (including the standard boxed-primitive types):
+@
+Boxed Type of transferd Corresp. Which is
+Type Prim. component C type *probably*...
+------ --------------- ------ -------------
+Char Char# StgChar unsigned char
+Int Int# StgInt long int
+_Word Word# StgWord unsigned long int
+_Addr Addr# StgAddr char *
+Float Float# StgFloat float
+Double Double# StgDouble double
+
+Array Array# StgArray StgPtr
+_ByteArray ByteArray# StgByteArray StgPtr
+_MutableArray MutableArray# StgArray StgPtr
+_MutableByteArray MutableByteArray# StgByteArray StgPtr
+
+_State State# nothing!
+
+_StablePtr StablePtr# StgStablePtr StgPtr
+_MallocPtr MallocPtr# StgMallocPtr StgPtr
+@
+
+All of the above are {\em C-returnable} except:
+@
+ Array, _ByteArray, _MutableArray, _MutableByteArray
+@
+
+{\bf ToDo:} I'm pretty wary of @Array@ and @_MutableArray@ being in
+this list, and not too happy about @_State@ [WDP].
+
+{\bf ToDo:} Can code generator pass all the primitive types? Should this be
+extended to include {\tt Bool\/} (or any enumeration type?)
+
+The type checker must be able to figure out just which of the C-callable/returnable
+types is being used. If it can't, you have to add type signatures. For example,
+@
+f x = _ccall_ foo x
+@
+is not good enough, because the compiler can't work out what type @x@ is, nor
+what type the @_ccall_@ returns. You have to write, say:
+@
+f :: Int -> PrimIO Float
+f x = _ccall_ foo x
+@
+
+\subsubsection{Implementation}
+
+The desugarer unwraps the @_ccall_@ construct by inserting the necessary
+evaluations etc to unbox the arguments. For example, the body of the definition
+of @f@ above would become:
+@
+ (\ s -> case x of { I# x# ->
+ case s of { S# s# ->
+ case ccall# [Int#,Float#] x# s# of { StateAndFloat# f# new_s# ->
+ (F# f#, S# new_s#)
+ }}})
+@
+Notice that the state, too, is unboxed.
+
+The code generator must deal specially with primitive objects which
+are stored on the heap.
+
+... details omitted ...
+
+More importantly, it must construct a C Heap Pointer heap-object after
+a @_ccall_@ which returns a @MallocPtr#@.
+
+%--------------------------------------------------------
+\section{Non-primitive stuff that must be wired into GHC}
+
+@
+data Char = C# Char#
+data Int = I# Int#
+data _Word = W# Word#
+data _Addr = A# Addr#
+
+data Float = F# Float#
+data Double = D# Double#
+data Integer = J# Int# Int# ByteArray#
+
+-- and the other boxed-primitive types:
+ Array, _ByteArray, _MutableArray, _MutableByteArray,
+ _StablePtr, _MallocPtr
+
+data Bool = False | True
+data CMP_TAG# = LT# | EQ# | GT# -- used in derived comparisons
+
+data List a = [] | a : (List a)
+-- tuples...
+
+data Ratio a = a :% a
+type Rational = Ratio Integer
+
+data {Request,Response,etc} -- so we can check the type of "main"
+
+data _Lift a = _Lift a -- used Yukkily as described elsewhere
+
+type String = [Char] -- convenience, only
+@
+
+%------------------------------------------------------------
+\section{Programmer interface(s)}
+
+\subsection{The bog-standard interface}
+
+If you rely on the implicit @import Prelude@ that GHC normally does
+for you, and if you don't use any weird flags (notably
+@-fglasgow-exts@), and if you don't import one of the fairly-magic
+@PreludeGla*@ interfaces, then GHC should work {\em exactly} as the
+Haskell report says, and the full user namespaces should be available
+to you.
+
+Exception: until we burn in the new names @_scc_@ and @_ccall_@, the
+names @scc@ and @ccall@ are still available.
+
+\subsection{If you mess about with @import Prelude@...}
+
+Innocent renaming and hiding, e.g.,
+@
+import Prelude hiding ( fromIntegral ) renaming (map to mop)
+@
+should work just fine (even it {\em is} atrocious programming practice).
+
+There are some things you can do that will make GHC crash, e.g.,
+hiding a standard class:
+@
+import Prelude hiding ( Eq(..) )
+@
+Don't do that.
+
+\subsection{Turning on Glasgow extensions with @-fglasgow-exts@}
+
+If you turn on @-fglasgow-exts@, then all the primitive types and
+operations described herein are available.
+
+It is possible that some name conflicts between your code and the
+wired-in things might spring to life (though we doubt it...).
+Change your names :-)
+
+\subsection{@import PreludeGlaST@}
+
+@
+type ST s a = _ST s a -- so you don't need -fglasgow-exts...
+@
+
+\subsection{@import PreludeGlaMisc@}
+
+\end{document}
+
%-ddump-asm-globals-info
%----------------------------------------------------------------------
+\subsubsection{How to read Core syntax (from some \tr{-ddump-*} flags)}
+\index{reading Core syntax}
+\index{Core syntax, how to read}
+
+Let's do this by commenting an example. It's from doing
+\tr{-ddump-ds} on this code:
+\begin{verbatim}
+skip2 m = m : skip2 (m+2)
+\end{verbatim}
+
+Before we jump in, a word about names of things. Within GHC,
+variables, type constructors, etc., are identified by their
+``Uniques.'' These are of the form `letter' plus `number' (both
+loosely interpreted). The `letter' gives some idea of where the
+Unique came from; e.g., \tr{_} means ``built-in type variable'';
+\tr{t} means ``from the typechecker''; \tr{s} means ``from the
+simplifier''; and so on. The `number' is printed fairly compactly in
+a `base-62' format, which everyone hates except me (WDP).
+
+Remember, everything has a ``Unique'' and it is usually printed out
+when debugging, in some form or another. So here we go...
+
+\begin{verbatim}
+Desugared:
+Main.skip2{-r1L6-} :: _forall_ a$_4 =>{{Num a$_4}} -> a$_4 -> [a$_4]
+
+--# `r1L6' is the Unique for Main.skip2;
+--# `_4' is the Unique for the type-variable (template) `a'
+--# `{{Num a$_4}}' is a dictionary argument
+
+_NI_
+
+--# `_NI_' means "no (pragmatic) information" yet; it will later
+--# evolve into the GHC_PRAGMA info that goes into interface files.
+
+Main.skip2{-r1L6-} =
+ /\ _4 -> \ d.Num.t4Gt ->
+ let {
+ {- CoRec -}
+ +.t4Hg :: _4 -> _4 -> _4
+ _NI_
+ +.t4Hg = (+{-r3JH-} _4) d.Num.t4Gt
+
+ fromInt.t4GS :: Int{-2i-} -> _4
+ _NI_
+ fromInt.t4GS = (fromInt{-r3JX-} _4) d.Num.t4Gt
+
+--# The `+' class method (Unique: r3JH) selects the addition code
+--# from a `Num' dictionary (now an explicit lamba'd argument).
+--# Because Core is 2nd-order lambda-calculus, type applications
+--# and lambdas (/\) are explicit. So `+' is first applied to a
+--# type (`_4'), then to a dictionary, yielding the actual addition
+--# function that we will use subsequently...
+
+--# We play the exact same game with the (non-standard) class method
+--# `fromInt'. Unsurprisingly, the type `Int' is wired into the
+--# compiler.
+
+ lit.t4Hb :: _4
+ _NI_
+ lit.t4Hb =
+ let {
+ ds.d4Qz :: Int{-2i-}
+ _NI_
+ ds.d4Qz = I#! 2#
+ } in fromInt.t4GS ds.d4Qz
+
+--# `I# 2#' is just the literal Int `2'; it reflects the fact that
+--# GHC defines `data Int = I# Int#', where Int# is the primitive
+--# unboxed type. (see relevant info about unboxed types elsewhere...)
+
+--# The `!' after `I#' indicates that this is a *saturated*
+--# application of the `I#' data constructor (i.e., not partially
+--# applied).
+
+ skip2.t3Ja :: _4 -> [_4]
+ _NI_
+ skip2.t3Ja =
+ \ m.r1H4 ->
+ let { ds.d4QQ :: [_4]
+ _NI_
+ ds.d4QQ =
+ let {
+ ds.d4QY :: _4
+ _NI_
+ ds.d4QY = +.t4Hg m.r1H4 lit.t4Hb
+ } in skip2.t3Ja ds.d4QY
+ } in
+ :! _4 m.r1H4 ds.d4QQ
+
+ {- end CoRec -}
+ } in skip2.t3Ja
+\end{verbatim}
+
+(``It's just a simple functional language'' is an unregisterised
+trademark of Peyton Jones Enterprises, plc.)
+
+%----------------------------------------------------------------------
\subsubsection[arity-checking]{Options to insert arity-checking code}
\index{arity checking}
script that comes with PVM3, but we sometimes meddle with the
\tr{debugger2} script. We include ours in the GHC distribution,
in \tr{ghc/utils/pvm/}.
+
+\item[\tr{-e<num>}:]
+\index{-e<num> RTS option (parallel)}
+(PARALLEL ONLY) Limit the number of pending sparks per processor to
+\tr{<num>}. The default is 100. A larger number may be appropriate if
+your program generates large amounts of parallelism initially.
\end{description}
%************************************************************************
--- /dev/null
+%
+% Included by profiling.lit
+%
+
+When you run your profiled program with the \tr{-p} RTS option
+\index{\tr{-p<sort> RTS option (profiling)}, you get the following
+information about your ``cost centres'':
+
+\begin{description}
+%-------------------------------------------------------------
+\item[\tr{COST CENTRE}:] The cost-centre's name.
+%-------------------------------------------------------------
+\item[\tr{MODULE}:]
+The module associated with the cost-centre;
+important mostly if you have identically-named cost-centres in
+different modules.
+%-------------------------------------------------------------
+\item[\tr{scc}:]
+How many times this cost-centre was entered; think
+of it as ``I got to the \tr{_scc_} construct this many times...''
+%-------------------------------------------------------------
+\item[\tr{subcc}:]
+How many times this cost-centre ``passed control'' to another
+cost-centre; for example, \tr{scc=4} plus \tr{subscc=8} means
+``This \tr{_scc_} was entered four times, but went out to
+other \tr{_scc_s} eight times.''
+%-------------------------------------------------------------
+\item[\tr{%time}:]
+What part of the time was spent in this cost-centre (see also ``ticks,''
+below).
+%-------------------------------------------------------------
+\item[\tr{%alloc}:]
+What part of the memory allocation was done in this cost-centre
+(see also ``bytes,'' below).
+\end{description}
+
+If you use the \tr{-P} RTS option
+\index{\tr{-P<sort> RTS option (profiling)}, you will also get the
+following information:
+\begin{description}
+%-------------------------------------------------------------
+\item[\tr{cafcc}:] Two columns, analogous to the \tr{scc} and \tr{subcc}
+columns, except these are for CAF cost-centres: the first column
+is how many times this top-level CAF cost-centre was entered;
+the second column is how many times this cost-centre (CAF or otherwise)
+entered another CAF cost-centre.
+%-------------------------------------------------------------
+\item[\tr{thunks}:]
+How many times we entered (evaluated) a thunk---an unevaluated
+object in the heap---while we were in this cost-centre.
+%-------------------------------------------------------------
+\item[\tr{funcs}:]
+How many times we entered (evaluated) a function while we we in this
+cost-centre. (In Haskell, functions are first-class values and may be
+passed as arguments, returned as results, evaluated, and generally
+manipulated just like data values)
+%-------------------------------------------------------------
+\item[\tr{PAPs}:]
+How many times we entered (evaluated) a partial application (PAP), i.e.,
+a function applied to fewer arguments than it needs. For example, \tr{Int}
+addition applied to one argument would be a PAP. A PAP is really
+just a particular form for a function.
+%-------------------------------------------------------------
+\item[\tr{closures}:]
+How many heap objects were allocated; these objects may be of varying
+size. If you divide the number of bytes (mentioned below) by this
+number of ``closures'', then you will get the average object size.
+(Not too interesting, but still...)
+%-------------------------------------------------------------
+\item[\tr{ticks}:] The raw number of time ``ticks'' which were
+attributed to this cost-centre; from this, we get the \tr{%time}
+figure mentioned above.
+%-------------------------------------------------------------
+\item[\tr{bytes}:] Number of bytes allocated in the heap while in
+this cost-centre; again, this is the raw number from which we
+get the \tr{%alloc} figure mentioned above.
+\end{description}
%************************************************************************
%* *
+\subsection[prof-output]{What's in a profiling report?}
+\index{profiling report, meaning thereof}
+%* *
+%************************************************************************
+
+\input{prof-output.lit}
+
+%************************************************************************
+%* *
\subsection[prof-graphs]{Producing graphical heap profiles}
\index{heap profiles, producing}
%* *
\item[\tr{-B}:]
\index{-B RTS option}
Sound the bell at the start of each (major) garbage collection.
-[Why anyone would do this, I cannot imagine.]
+
+Oddly enough, people really do use this option! Our pal in Durham
+(England), PaulCallaghan, writes: ``Some people here use it for a
+variety of purposes---honestly!---e.g., confirmation that the
+code/machine is doing something, infinite loop detection, gauging cost
+of recently added code. Certain people can even tell what stage [the
+program] is in by the beep pattern. But the major use is for annoying
+others in the same office...''
\item[\tr{-I}:]
Use the ``debugging mini-interpreter'' with sanity-checking; you have
\tr{U(...)} is strict and
``unpackable'' (very good), and \tr{A} is absent (very good).
+For an ``unpackable'' \tr{U(...)} argument, the info inside
+tells the strictness of its components. So, if the argument is a
+pair, and it says \tr{U(AU(LSS))}, that means ``the first component of the
+pair isn't used; the second component is itself unpackable, with three
+components (lazy in the first, strict in the second \& third).''
+
If the function isn't exported, just compile with the extra flag \tr{-ddump-simpl};
next to the signature for any binder, it will print the self-same
pragmatic information as would be put in an interface file.
ghc-asm-sparc.prl \
ghc-asm-solaris.prl \
ghc-asm-m68k.prl \
- ghc-asm-iX86.prl \
+ ghc-asm.prl \
ghc-asm-alpha.prl \
ghc-asm-hppa.prl \
ghc-asm-mips.prl \
} elsif ( /\.\.ng:$/ ) { # Local labels not to be confused with new chunks
$chk[$i] .= $_;
- } elsif ( /^(ret_|djn_)/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
- } elsif ( /^vtbl_([A-Za-z0-9_]+):$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'vector';
- $chksymb[$i] = $1;
-
- $vectorchk{$1} = $i;
-
- } elsif ( /^([A-Za-z0-9_]+)DirectReturn:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'direct';
- $chksymb[$i] = $1;
-
- $directchk{$1} = $i;
-
- } elsif ( /^[A-Za-z0-9_]+_upd:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
} elsif ( /^\$C(\d+):$/ ) {
$chk[++$i] .= $_;
$chkcat[$i] = 'string';
$chkcat[$i] = 'infotbl';
$chksymb[$i] = $symb;
+ die "Info table already? $symb; $i\n" if defined($infochk{$symb});
+
$infochk{$symb} = $i;
} elsif ( /^([A-Za-z0-9_]+)_entry:$/ ) {
$chkcat[$i] = 'data';
$chksymb[$i] = '';
+ } elsif ( /^(ret_|djn_)/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
+ } elsif ( /^vtbl_([A-Za-z0-9_]+):$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'vector';
+ $chksymb[$i] = $1;
+
+ $vectorchk{$1} = $i;
+
+ } elsif ( /^([A-Za-z0-9_]+)DirectReturn:$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'direct';
+ $chksymb[$i] = $1;
+
+ $directchk{$1} = $i;
+
+ } elsif ( /^[A-Za-z0-9_]+_upd:$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
} elsif ( /^[A-Za-z0-9_]/ ) {
local($thing);
chop($thing = $_);
print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
# entry code will be put here!
+ # paranoia
+ if ( $chk[$infochk{$symb}] =~ /\.quad\s+([A-Za-z0-9_]+_entry)$/
+ && $1 ne "${symb}_entry" ) {
+ print STDERR "!!! entry point???\n",$chk[$infochk{$symb}];
+ }
+
$chkcat[$infochk{$symb}] = 'DONE ALREADY';
}
$c =~ s/^\tjmp \$31,\(\$27\),0\n\t\.align 4\n\t\.end/\t.align 4\n\t.end/;
}
+ # NB: no very good way to look for "dangling" references
+ # to fast-entry pt
+
print OUTASM "\.text\n\t\.align 3\n";
print OUTASM $c;
$chkcat[$slowchk{$symb}] = 'DONE ALREADY';
$chkcat[$i] = 'literal';
$chksymb[$i] = $1;
- } elsif ( /^(ret_|djn_)/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
- } elsif ( /^vtbl_([A-Za-z0-9_]+)$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'vector';
- $chksymb[$i] = $1;
-
- $vectorchk{$1} = $i;
-
- } elsif ( /^([A-Za-z0-9_]+)DirectReturn$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'direct';
- $chksymb[$i] = $1;
-
- $directchk{$1} = $i;
-
- } elsif ( /^[A-Za-z0-9_]+_upd$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
} elsif ( /^__stg_split_marker(\d+)$/ ) {
$chk[++$i] .= $_;
$chkcat[$i] = 'splitmarker';
$chkcat[$i] = 'infotbl';
$chksymb[$i] = $symb;
+ die "Info table already? $symb; $i\n" if defined($infochk{$symb});
+
$infochk{$symb} = $i;
} elsif ( /^([A-Za-z0-9_]+)_entry$/ ) {
$chkcat[$i] = 'bss';
$chksymb[$i] = $1;
+ } elsif ( /^(ret_|djn_)/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
+ } elsif ( /^vtbl_([A-Za-z0-9_]+)$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'vector';
+ $chksymb[$i] = $1;
+
+ $vectorchk{$1} = $i;
+
+ } elsif ( /^([A-Za-z0-9_]+)DirectReturn$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'direct';
+ $chksymb[$i] = $1;
+
+ $directchk{$1} = $i;
+
+ } elsif ( /^[A-Za-z0-9_]+_upd$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
} elsif ( /^[A-Za-z0-9_]/ && ! /^L\$\d+$/) {
local($thing);
chop($thing = $_);
print OUTASM "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
# entry code will be put here!
-# if ( $chk[$infochk{$symb}] =~ /\.word\s+([A-Za-z0-9_]+_entry)$/
-# && $1 ne "_${symb}_entry" ) {
-# print STDERR "!!! entry point???\n",$chk[$infochk{$symb}];
-# }
+
+ # paranoia
+ if ( $chk[$infochk{$symb}] =~ /\.word\s+([A-Za-z0-9_]+_entry)$/
+ && $1 ne "${symb}_entry" ) {
+ print STDERR "!!! entry point???\n",$chk[$infochk{$symb}];
+ }
$chkcat[$infochk{$symb}] = 'DONE ALREADY';
}
$c =~ s/^\s+ldil.*\n\s+ldo.*\n\s+bv.*\n(.*\n)?\s+\.EXIT/$1\t.EXIT/;
}
+ # ToDo: ???? any good way to look for "dangling" references
+ # to fast-entry pt ???
+
print OUTASM "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
print OUTASM $c;
$chkcat[$slowchk{$symb}] = 'DONE ALREADY';
+++ /dev/null
-%************************************************************************
-%* *
-\section[Driver-asm-fiddling]{Fiddling with assembler files (iX86)}
-%* *
-%************************************************************************
-
-Tasks:
-\begin{itemize}
-\item
-Utterly stomp out C functions' prologues and epilogues; i.e., the
-stuff to do with the C stack.
-\item
-Any other required tidying up.
-\end{itemize}
-
-\begin{code}
-sub mangle_asm {
- local($in_asmf, $out_asmf) = @_;
-
- # multi-line regexp matching:
- local($*) = 1;
- local($i, $c);
- &init_FUNNY_THINGS();
-
- open(INASM, "< $in_asmf")
- || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n");
- open(OUTASM,"> $out_asmf")
- || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n");
-
- # read whole file, divide into "chunks":
- # record some info about what we've found...
-
- @chk = (); # contents of the chunk
- $numchks = 0; # number of them
- @chkcat = (); # what category of thing in each chunk
- @chksymb = (); # what symbol(base) is defined in this chunk
- %slowchk = (); # ditto, its regular "slow" entry code
- %fastchk = (); # ditto, fast entry code
- %closurechk = (); # ditto, the (static) closure
- %infochk = (); # given a symbol base, say what chunk its info tbl is in
- %vectorchk = (); # ditto, return vector table
- %directchk = (); # ditto, direct return code
-
- $i = 0;
- $chkcat[0] = 'misc';
-
- while (<INASM>) {
-#??? next if /^\.stab.*___stg_split_marker/;
-#??? next if /^\.stab.*ghc.*c_ID/;
- next if /^#(NO_)?APP/;
-
- if ( /^\s+/ ) { # most common case first -- a simple line!
- # duplicated from the bottom
-
- $chk[$i] .= $_;
-
- } elsif ( /^_(ret_|djn_)/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
- } elsif ( /^_vtbl_([A-Za-z0-9_]+):$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'vector';
- $chksymb[$i] = $1;
-
- $vectorchk{$1} = $i;
-
- } elsif ( /^_([A-Za-z0-9_]+)DirectReturn:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'direct';
- $chksymb[$i] = $1;
-
- $directchk{$1} = $i;
-
- } elsif ( /^_[A-Za-z0-9_]+_upd:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
- } elsif ( /^LC(\d+):$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'string';
- $chksymb[$i] = $1;
-
- } elsif ( /^___stg_split_marker(\d+):$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'splitmarker';
- $chksymb[$i] = $1;
-
- } elsif ( /^_([A-Za-z0-9_]+)_info:$/ ) {
- $symb = $1;
- $chk[++$i] .= $_;
- $chkcat[$i] = 'infotbl';
- $chksymb[$i] = $symb;
-
- $infochk{$symb} = $i;
-
- } elsif ( /^_([A-Za-z0-9_]+)_entry:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'slow';
- $chksymb[$i] = $1;
-
- $slowchk{$1} = $i;
-
- } elsif ( /^_([A-Za-z0-9_]+)_fast\d+:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'fast';
- $chksymb[$i] = $1;
-
- $fastchk{$1} = $i;
-
- } elsif ( /^_([A-Za-z0-9_]+)_closure:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'closure';
- $chksymb[$i] = $1;
-
- $closurechk{$1} = $i;
-
- } elsif ( /^_ghc.*c_ID:/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'consist';
-
- } elsif ( /^(___gnu_compiled_c|gcc2_compiled\.):/ ) {
- ; # toss it
-
- } elsif ( /^_ErrorIO_call_count:/ # HACK!!!!
- || /^_[A-Za-z0-9_]+\.\d+:$/
- || /^_.*_CAT:/ # PROF: _entryname_CAT
- || /^_CC_.*_struct:/ # PROF: _CC_ccident_struct
- || /^_.*_done:/ # PROF: _module_done
- || /^__module_registered:/ # PROF: _module_registered
- ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'data';
- $chksymb[$i] = '';
-
- } elsif ( /^_[A-Za-z0-9_]/ ) {
- local($thing);
- chop($thing = $_);
- print STDERR "Funny global thing?: $_"
- unless $KNOWN_FUNNY_THING{$thing}
- || /^__(PRIn|PRStart).*:/ # pointer reversal GC routines
- || /^_CC_.*:/ # PROF: _CC_ccident
- || /^__reg.*:/; # PROF: __reg<module>
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
- } else { # simple line (duplicated at the top)
-
- $chk[$i] .= $_;
- }
- }
- $numchks = $#chk + 1;
-
- # the division into chunks is imperfect;
- # we throw some things over the fence into the next
- # chunk.
- #
- # also, there are things we would like to know
- # about the whole module before we start spitting
- # output.
-
- # NB: we start meddling at chunk 1, not chunk 0
-
- for ($i = 1; $i < $numchks; $i++) {
- $c = $chk[$i]; # convenience copy
-
-# print STDERR "\nCHK $i (BEFORE) (",$chkcat[$i],"):\n", $c;
-
- # toss all prologue stuff;
- # be slightly paranoid to make sure there's
- # nothing surprising in there
- if ( $c =~ /--- BEGIN ---/ ) {
- if (($p, $r) = split(/--- BEGIN ---/, $c)) {
- $p =~ s/^\tpushl \%edi\n//;
- $p =~ s/^\tpushl \%esi\n//;
- $p =~ s/^\tsubl \$\d+,\%esp\n//;
- die "Prologue junk?: $p\n" if $p =~ /^\t[^\.]/;
-
- # glue together what's left
- $c = $p . $r;
- }
- }
-
- # toss all epilogue stuff; again, paranoidly
- if ( $c =~ /--- END ---/ ) {
- if (($r, $e) = split(/--- END ---/, $c)) {
- $e =~ s/^\tret\n//;
- $e =~ s/^\tpopl \%edi\n//;
- $e =~ s/^\tpopl \%esi\n//;
- $e =~ s/^\taddl \$\d+,\%esp\n//;
- die "Epilogue junk?: $e\n" if $e =~ /^\t[^\.]/;
-
- # glue together what's left
- $c = $r . $e;
- }
- }
-
- # toss all calls to __DISCARD__
- $c =~ s/^\tcall ___DISCARD__\n//g;
-
- # pin a funny end-thing on (for easier matching):
- $c .= 'FUNNY#END#THING';
-
- # pick some end-things and move them to the next chunk
-
- while ( $c =~ /^\s*(\.align\s+\d+(,0x90)?\n|\.globl\s+\S+\n|\.text\n|\.data\n|\.stab[^n].*\n)FUNNY#END#THING/ ) {
- $to_move = $1;
-
- if ( $to_move =~ /\.(globl|stab)/ && $i < ($numchks - 1) ) {
- $chk[$i + 1] = $to_move . $chk[$i + 1];
- # otherwise they're tossed
- }
-
- $c =~ s/^.*\nFUNNY#END#THING/FUNNY#END#THING/;
- }
-
- $c =~ s/FUNNY#END#THING//;
- $chk[$i] = $c; # update w/ convenience copy
- }
-
- # print out all the literal strings first
- for ($i = 0; $i < $numchks; $i++) {
- if ( $chkcat[$i] eq 'string' ) {
- print OUTASM "\.text\n\t\.align 4\n";
- # not sure what alignment is required (WDP 95/02)
- # .align 4 (on 16-byte boundaries) is 486-cache friendly
- print OUTASM $chk[$i];
-
- $chkcat[$i] = 'DONE ALREADY';
- }
- }
-
- for ($i = 0; $i < $numchks; $i++) {
-# print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n";
-
- next if $chkcat[$i] eq 'DONE ALREADY';
-
- if ( $chkcat[$i] eq 'misc' ) {
- print OUTASM "\.text\n\t\.align 4\n";
- &print_doctored($chk[$i], 0);
-
- } elsif ( $chkcat[$i] eq 'data' ) {
- print OUTASM "\.data\n\t\.align 2\n"; # ToDo: change align??
- print OUTASM $chk[$i];
-
- } elsif ( $chkcat[$i] eq 'consist' ) {
- if ( $chk[$i] =~ /\.ascii.*\)(hsc|cc) (.*)\\11"\n\t\.ascii\s+"(.*)\\0"/ ) {
- local($consist) = "$1.$2.$3";
- $consist =~ s/,/./g;
- $consist =~ s/\//./g;
- $consist =~ s/-/_/g;
- $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly?
- print OUTASM "\.text\n$consist:\n";
- } else {
- print STDERR "Couldn't grok consistency: ", $chk[$i];
- }
-
- } elsif ( $chkcat[$i] eq 'splitmarker' ) {
- # we can just re-constitute this one...
- print OUTASM "___stg_split_marker",$chksymb[$i],":\n";
-
- } elsif ( $chkcat[$i] eq 'closure'
- || $chkcat[$i] eq 'infotbl'
- || $chkcat[$i] eq 'slow'
- || $chkcat[$i] eq 'fast' ) { # do them in that order
- $symb = $chksymb[$i];
-
- # CLOSURE
- if ( defined($closurechk{$symb}) ) {
- print OUTASM "\.data\n\t\.align 2\n"; # ToDo: change align?
- print OUTASM $chk[$closurechk{$symb}];
- $chkcat[$closurechk{$symb}] = 'DONE ALREADY';
- }
-
- # INFO TABLE
- if ( defined($infochk{$symb}) ) {
-
- print OUTASM "\.text\n\t\.align 4\n"; # NB: requires padding
- print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
- # entry code will be put here!
-
- $chkcat[$infochk{$symb}] = 'DONE ALREADY';
- }
-
- # STD ENTRY POINT
- if ( defined($slowchk{$symb}) ) {
-
- # teach it to drop through to the fast entry point:
- $c = $chk[$slowchk{$symb}];
- $c =~ s/^\tmovl \$_${symb}_fast\d+,\%edx\n\tjmp \*\%edx\n//;
- $c =~ s/^\tmovl \$_${symb}_fast\d+,\%eax\n\tjmp \*\%eax\n//;
-
- print STDERR "still has jump to fast entry point:\n$c"
- if $c =~ /_${symb}_fast/;
-
- print OUTASM "\.text\n\t\.align 4\n";
- &print_doctored($c, 1); # NB: the 1!!!
- $chkcat[$slowchk{$symb}] = 'DONE ALREADY';
- }
-
- # FAST ENTRY POINT
- if ( defined($fastchk{$symb}) ) {
- print OUTASM "\.text\n\t\.align 4\n"; # Fills w/ no-ops!
- &print_doctored($chk[$fastchk{$symb}], 0);
- $chkcat[$fastchk{$symb}] = 'DONE ALREADY';
- }
-
- } elsif ( $chkcat[$i] eq 'vector'
- || $chkcat[$i] eq 'direct' ) { # do them in that order
- $symb = $chksymb[$i];
-
- # VECTOR TABLE
- if ( defined($vectorchk{$symb}) ) {
- print OUTASM "\.text\n\t\.align 4\n"; # NB: requires padding
- print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0);
- # direct return code will be put here!
- $chkcat[$vectorchk{$symb}] = 'DONE ALREADY';
- }
-
- # DIRECT RETURN
- if ( defined($directchk{$symb}) ) {
- print OUTASM "\.text\n\t\.align 4\n";
- &print_doctored($chk[$directchk{$symb}], 0);
- $chkcat[$directchk{$symb}] = 'DONE ALREADY';
- }
-
- } else {
- &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm iX86)\n$chkcat[$i]\n$chk[$i]\n");
- }
- }
- # finished
- close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n");
- close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n");
-}
-\end{code}
-
-\begin{code}
-sub print_doctored {
- local($_, $need_fallthru_patch) = @_;
-
- if ( ! /^\t[a-z]/ ) { # no instructions in here, apparently
- print OUTASM $_;
-
- } else { # must do some **HACKING**
- local($entry_patch) = '';
- local($exit_patch) = '';
- local($call_entry_patch)= '';
- local($call_exit_patch) = '';
- local($sp_entry_patch) = '';
- local($sp_exit_patch) = '';
-
- # gotta watch out for weird instructions that
- # invisibly smash various regs:
- # rep* %ecx used for counting
- # scas* %edi used for destination index
- # cmps* %e[sd]i used for indices
- # loop* %ecx used for counting
- #
- # SIGH.
- print STDERR "WEIRD INSN!\n$_" if /^\t(rep|scas|loop|cmps)/;
-
- # WDP: this still looks highly dubious to me. 95/07
- # We cater for:
- # * use of STG reg [ nn(%ebx) ] where no machine reg avail
- # * some secret uses of machine reg, requiring STG reg
- # to be saved/restored
- # * but what about totally-unexpected uses of machine reg?
- # (maybe I've forgotten how this works...)
-
- if ( $StolenX86Regs < 3
- && ( /32\(\%ebx\)/ || /^\tcmps/ ) ) { # R1 (esi)
- $entry_patch .= "\tmovl \%esi,32(\%ebx)\n";
- $exit_patch .= "\tmovl 32(\%ebx),\%esi\n";
- # nothing for call_{entry,exit} because %esi is callee-save
- }
- if ( $StolenX86Regs < 4
- && ( /64\(\%ebx\)/ || /^\t(scas|cmps)/ ) ) { # SpA (edi)
- $entry_patch .= "\tmovl \%edi,64(\%ebx)\n";
- $exit_patch .= "\tmovl 64(\%ebx),\%edi\n";
- # nothing for call_{entry,exit} because %edi is callee-save
- }
- if ( $StolenX86Regs < 5
- && ( /36\(\%ebx\)/ || /^\t(rep|loop)/ ) ) { # R2 (ecx)
- $entry_patch .= "\tmovl \%ecx,36(\%ebx)\n";
- $exit_patch .= "\tmovl 36(\%ebx),\%ecx\n";
-
- $call_exit_patch .= "\tmovl \%ecx,108(\%ebx)\n";
- $call_entry_patch .= "\tmovl 108(\%ebx),\%ecx\n";
- }
- # first, convert calls to *very magic form*: (ToDo: document for real!)
- # from
- # pushl $768
- # call _PerformGC_wrapper
- # addl $4,%esp
- # to
- # movl $768, %eax
- # call _PerformGC_wrapper
- #
- # Special macros in ghc/includes/COptWraps.lh, used in
- # ghc/runtime/CallWrap_C.lc, are required for this to work!
- #
- s/^\tpushl \$(\d+)\n\tcall _PerformGC_wrapper\n\taddl \$4,\%esp\nL(\d+):\n/\tmovl \$$1,\%eax\n\tmovl \$L$2a,104\(\%ebx\)\n\tmovl \$_PerformGC_wrapper,\%edx\n\tjmp \*\%edx\nL$2a:\n__SP_ENTRY_PATCH__L$2:\n/g;
- s/^\tpushl \%eax\n\tcall _PerformGC_wrapper\n\taddl \$4,\%esp\nL(\d+):\n/\tmovl \$L$1a,104\(\%ebx\)\n\tmovl \$_PerformGC_wrapper,\%edx\n\tjmp \*\%edx\nL$1a:\n__SP_ENTRY_PATCH__L$1:\n/g;
-
- s/^\tpushl \%edx\n\tcall _PerformGC_wrapper\n\taddl \$4,\%esp\nL(\d+):\n/\tmovl \%edx,\%eax\n\tmovl \$L$1a,104\(\%ebx\)\n\tmovl \$_PerformGC_wrapper,\%edx\n\tjmp \*\%edx\nL$1a:\n__SP_ENTRY_PATCH__L$1:\n/g;
-
- if ( $StolenX86Regs < 5 ) { # %ecx is ordinary reg
- s/^\tpushl \%ecx\n\tcall _PerformGC_wrapper\n\taddl \$4,\%esp\nL(\d+):\n/\tmovl \%ecx,\%eax\n\tmovl \$L$1a,104\(\%ebx\)\n\tmovl \$_PerformGC_wrapper,\%edx\n\tjmp \*\%edx\nL$1a:\n__SP_ENTRY_PATCH__L$1:\n/g;
- }
-
- die "PerformGC_wrapper still alive!\n$_" if / _PerformGC_wrapper/;
-
- # --------------------------------------------------------
- # OK, now acct for the fact that %esp holds Hp on entry;
- #
- # * must hold C-stack ptr if we go to C
- # * must get Hp ( 80(%ebx) ) back in it if we come back from C
- # * must hold Hp when we go on to the next guy
- # * don't worry about PerformGC_wrapper -- it is magic
- # * we have a "save location" for %esp ( 100(%ebx) )
- # * because C-stack ptr doesn't change in Haskell-land,
- # we don't have to save it -- just restore it when
- # necessary.
- #
- if ( $SpX86Mangling ) { # NB: not used in RTS
- if ( /(\tcall |\tpushl |\%esp)/ ) { # *anything* C-stack-ish...
- # then we patch up...
- $sp_entry_patch = "\tmovl \%esp,80(\%ebx)\n\tmovl 100(\%ebx),%esp\n";
- $sp_exit_patch = "\tmovl 80(\%ebx),\%esp\n";
-
- } elsif ( /80\(\%ebx\)/ ) { # no C-stack stuff: try to squash Hp refs!
- $sp_entry_patch = '';
- $sp_exit_patch = '';
-
- # mangle heap-check code
-
- s/\tmovl 80\(\%ebx\),%eax\n\taddl \$(\d+),\%eax\n\tmovl \%eax,80\(\%ebx\)\n\tcmpl \%eax,84\(\%ebx\)\n/\taddl \$$1,\%esp\n\tcmpl \%esp,84\(\%ebx\)\n/g;
-
- # mangle other Hp refs
- s/80\(\%ebx\)/\%esp/g;
-
- # squash some repeated reloadings of Hp
- while ( /\tmovl \%esp,\%eax\n\t([a-z].*)\n\tmovl \%esp,\%eax\n/ ) {
- local($x) = $1;
- $x =~ s/\%eax/\%esp/g;
- s/\tmovl \%esp,\%eax\n\t([a-z].*)\n\tmovl \%esp,\%eax\n/\t$x\n\tmovl \%esp,\%eax\n/;
- }
-
- while ( /\tmovl \%esp,\%edx\n\t([a-z].*)\n\tmovl \%esp,\%edx\n/ ) {
- local($x) = $1;
- $x =~ s/\%edx/\%esp/g;
- s/\tmovl \%esp,\%edx\n\t([a-z].*)\n\tmovl \%esp,\%edx\n/\t$x\n\tmovl \%esp,\%edx\n/;
- }
-
- if ( $StolenX86Regs < 5 ) { # %ecx is ordinary reg
- while ( /\tmovl \%esp,\%ecx\n\t([a-z].*)\n\tmovl \%esp,\%ecx\n/ ) {
- local($x) = $1;
- $x =~ s/\%ecx/\%esp/g;
- s/\tmovl \%esp,\%ecx\n\t([a-z].*)\n\tmovl \%esp,\%ecx\n/\t$x\n\tmovl \%esp,\%ecx\n/;
- }
- }
-
- s/\tmovl \%esp,\%eax\n\tmovl \%eax,\%edx\n\taddl \$-(\d+),\%edx\n\tmovl \%edx,(-\d+)?\(\%eax\)\n/\tmovl \%esp,\%edx\n\taddl \$-$1,\%edx\n\tmovl \%edx,$2\(\%esp\)\n/g;
-
- }
- }
-
- # --------------------------------------------------------
- # next, here we go with non-%esp patching!
- #
- s/^(\t[a-z])/$sp_entry_patch$entry_patch$1/; # before first instruction
- s/^(\tcall .*\n(\taddl \$\d+,\%esp\n)?)/$call_exit_patch$1$call_entry_patch/g; # _all_ calls
-
- if ($StolenX86Regs == 2 ) { # YURGH! spurious uses of esi,edi,ecx?
- s/^(\tjmp .*)(\%esi|\%edi|\%ecx)(.*\n)/\tmovl $2,\%eax\n$1\%eax$3/g;
- } elsif ($StolenX86Regs == 3 ) { # spurious uses of edi,ecx?
- s/^(\tjmp .*)(\%edi|\%ecx)(.*\n)/\tmovl $2,\%eax\n$1\%eax$3/g;
- } elsif ($StolenX86Regs == 4 ) { # spurious uses of ecx?
- s/^(\tjmp .*)(\%ecx)(.*\n)/\tmovl $2,\%eax\n$1\%eax$3/g;
- }
-
- s/^\tjmp \*L/\tJMP___L/g;
-
-#testing:
-# while ( /^(\tjmp (\*)?[^L].*\n)/ && $sp_exit_patch ) {
-# print STDERR "Converting\n$1to\n$sp_exit_patch$exit_patch$1";
-# s/^(\tjmp)( (\*)?[^L].*\n)/$sp_exit_patch$exit_patch\tJMPME$2/;
-# }
-
- # fix _all_ non-local jumps
- s/^(\tjmp (\*)?[^L].*\n)/$sp_exit_patch$exit_patch$1/g;
-
-#test: s/JMPME/jmp /g;
-
- s/^\tJMP___L/\tjmp \*L/g;
-
- # fix post-PerformGC wrapper (re-)entries
- s/__SP_ENTRY_PATCH__/$sp_entry_patch/g;
-
- if ($StolenX86Regs == 2 ) {
- die "ARGH! Jump uses \%esi, \%edi, or \%ecx with -monly-2-regs:\n$_"
- if /^\t(jmp|call) .*\%e(si|di|cx)/;
- } elsif ($StolenX86Regs == 3 ) {
- die "ARGH! Jump uses \%edi or \%ecx with -monly-3-regs:\n$_"
- if /^\t(jmp|call) .*\%e(di|cx)/;
- } elsif ($StolenX86Regs == 4 ) {
- die "ARGH! Jump uses \%ecx with -monly-4-regs:\n$_"
- if /^\t(jmp|call) .*\%ecx/;
- }
-
- # final peephole fix
- s/^\tmovl 36\(\%ebx\),\%ecx\n\tjmp \*36\(\%ebx\)\n/\tmovl 36\(\%ebx\),\%ecx\n\tjmp \*\%ecx\n/;
-
- # --------------------------------------------------------
- # that's it -- print it
- #
- die "Funny jumps?\n$_" if /^\tjmp [^L\*]/; # paranoia
-
- print OUTASM $_;
-
- if ( $need_fallthru_patch ) { # exit patch for end of slow entry code
- print OUTASM $sp_exit_patch, $exit_patch;
- # ToDo: make it not print if there is a "jmp" at the end
- }
- }
-}
-\end{code}
-
-\begin{code}
-sub init_FUNNY_THINGS {
- %KNOWN_FUNNY_THING = (
- '_CheckHeapCode:', 1,
- '_CommonUnderflow:', 1,
- '_Continue:', 1,
- '_EnterNodeCode:', 1,
- '_ErrorIO_call_count:', 1,
- '_ErrorIO_innards:', 1,
- '_IndUpdRetDir:', 1,
- '_IndUpdRetV0:', 1,
- '_IndUpdRetV1:', 1,
- '_IndUpdRetV2:', 1,
- '_IndUpdRetV3:', 1,
- '_IndUpdRetV4:', 1,
- '_IndUpdRetV5:', 1,
- '_IndUpdRetV6:', 1,
- '_IndUpdRetV7:', 1,
- '_PrimUnderflow:', 1,
- '_StackUnderflowEnterNode:', 1,
- '_StdErrorCode:', 1,
- '_UnderflowVect0:', 1,
- '_UnderflowVect1:', 1,
- '_UnderflowVect2:', 1,
- '_UnderflowVect3:', 1,
- '_UnderflowVect4:', 1,
- '_UnderflowVect5:', 1,
- '_UnderflowVect6:', 1,
- '_UnderflowVect7:', 1,
- '_UpdErr:', 1,
- '_UpdatePAP:', 1,
- '_WorldStateToken:', 1,
- '__Enter_Internal:', 1,
- '__PRMarking_MarkNextAStack:', 1,
- '__PRMarking_MarkNextBStack:', 1,
- '__PRMarking_MarkNextCAF:', 1,
- '__PRMarking_MarkNextGA:', 1,
- '__PRMarking_MarkNextRoot:', 1,
- '__PRMarking_MarkNextSpark:', 1,
- '__Scavenge_Forward_Ref:', 1,
- '___std_entry_error__:', 1,
- '__startMarkWorld:', 1,
- '_resumeThread:', 1,
- '_startCcRegisteringWorld:', 1,
- '_startEnterFloat:', 1,
- '_startEnterInt:', 1,
- '_startPerformIO:', 1,
- '_startStgWorld:', 1,
- '_stopPerformIO:', 1
- );
-}
-\end{code}
-
-The following table reversal is used for both info tables and return
-vectors. In both cases, we remove the first entry from the table,
-reverse the table, put the label at the end, and paste some code
-(that which is normally referred to by the first entry in the table)
-right after the table itself. (The code pasting is done elsewhere.)
-
-\begin{code}
-sub rev_tbl {
- local($symb, $tbl, $discard1) = @_;
-
- local($before) = '';
- local($label) = '';
- local(@words) = ();
- local($after) = '';
- local(@lines) = split(/\n/, $tbl);
- local($i, $extra, $words_to_pad, $j);
-
- for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t\.long\s+/; $i++) {
- $label .= $lines[$i] . "\n",
- next if $lines[$i] =~ /^[A-Za-z0-9_]+_info:$/
- || $lines[$i] =~ /^\.globl/
- || $lines[$i] =~ /^_vtbl_\S+:$/;
-
- $before .= $lines[$i] . "\n"; # otherwise...
- }
-
- for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.long\s+/; $i++) {
- push(@words, $lines[$i]);
- }
- # now throw away the first word (entry code):
- shift(@words) if $discard1;
-
- # for 486-cache-friendliness, we want our tables aligned
- # on 16-byte boundaries (.align 4). Let's pad:
- $extra = ($#words + 1) % 4;
- $words_to_pad = ($extra == 0) ? 0 : 4 - $extra;
- for ($j = 0; $j < $words_to_pad; $j++) { push(@words, "\t\.long 0"); }
-
- for (; $i <= $#lines; $i++) {
- $after .= $lines[$i] . "\n";
- }
-
- $tbl = $before . join("\n", (reverse @words)) . "\n" . $label . $after;
-
-# print STDERR "before=$before\n";
-# print STDERR "label=$label\n";
-# print STDERR "words=",(reverse @words),"\n";
-# print STDERR "after=$after\n";
-
- $tbl;
-}
-
-# make "require"r happy...
-1;
-
-\end{code}
$chk[$i] .= $_;
- } elsif ( /^_(ret_|djn_)/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
- } elsif ( /^_vtbl_([A-Za-z0-9_]+):$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'vector';
- $chksymb[$i] = $1;
-
- $vectorchk{$1} = $i;
-
- } elsif ( /^_([A-Za-z0-9_]+)DirectReturn:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'direct';
- $chksymb[$i] = $1;
-
- $directchk{$1} = $i;
-
- } elsif ( /^_[A-Za-z0-9_]+_upd:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
} elsif ( /^LC(\d+):$/ ) {
$chk[++$i] .= $_;
$chkcat[$i] = 'string';
$chkcat[$i] = 'infotbl';
$chksymb[$i] = $symb;
+ die "Info table already? $symb; $i\n" if defined($infochk{$symb});
+
$infochk{$symb} = $i;
} elsif ( /^_([A-Za-z0-9_]+)_entry:$/ ) {
$chkcat[$i] = 'data';
$chksymb[$i] = '';
+ } elsif ( /^_(ret_|djn_)/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
+ } elsif ( /^_vtbl_([A-Za-z0-9_]+):$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'vector';
+ $chksymb[$i] = $1;
+
+ $vectorchk{$1} = $i;
+
+ } elsif ( /^_([A-Za-z0-9_]+)DirectReturn:$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'direct';
+ $chksymb[$i] = $1;
+
+ $directchk{$1} = $i;
+
+ } elsif ( /^_[A-Za-z0-9_]+_upd:$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
} elsif ( /^_[A-Za-z0-9_]/ ) {
local($thing);
chop($thing = $_);
print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
# entry code will be put here!
+ # paranoia
+ if ( $chk[$infochk{$symb}] =~ /\.long\s+([A-Za-z0-9_]+_entry)$/
+ && $1 ne "_${symb}_entry" ) {
+ print STDERR "!!! entry point???\n",$chk[$infochk{$symb}];
+ }
+
$chkcat[$infochk{$symb}] = 'DONE ALREADY';
}
# teach it to drop through to the fast entry point:
$c = $chk[$slowchk{$symb}];
- $c =~ s/^\tjmp _${symb}_fast\d+.*\n\tnop\n//;
- $c =~ s/^\tjmp _${symb}_fast\d+.*\n//;
+
+ if ( defined($fastchk{$symb}) ) {
+ $c =~ s/^\tjmp _${symb}_fast\d+.*\n\tnop\n//;
+ $c =~ s/^\tjmp _${symb}_fast\d+.*\n//;
+ }
print STDERR "still has jump to fast entry point:\n$c"
- if $c =~ /_${symb}_fast/;
+ if $c =~ /_${symb}_fast/; # NB: paranoia
print OUTASM "\.text\n\t\.even\n";
print OUTASM $c;
} elsif ( /^\d+:/ ) { # a funny-looking very-local label
$chk[$i] .= $_;
- } elsif ( /^(ret_|djn_)/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
- } elsif ( /^vtbl_([A-Za-z0-9_]+):$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'vector';
- $chksymb[$i] = $1;
-
- $vectorchk{$1} = $i;
-
- } elsif ( /^([A-Za-z0-9_]+)DirectReturn:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'direct';
- $chksymb[$i] = $1;
-
- $directchk{$1} = $i;
-
- } elsif ( /^[A-Za-z0-9_]+_upd:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
} elsif ( /^\$LC(\d+):$/ ) {
$chk[++$i] .= $_;
$chkcat[$i] = 'string';
$chkcat[$i] = 'infotbl';
$chksymb[$i] = $symb;
+ die "Info table already? $symb; $i\n" if defined($infochk{$symb});
+
$infochk{$symb} = $i;
} elsif ( /^([A-Za-z0-9_]+)_entry:$/ ) {
$chkcat[$i] = 'data';
$chksymb[$i] = '';
+ } elsif ( /^(ret_|djn_)/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
+ } elsif ( /^vtbl_([A-Za-z0-9_]+):$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'vector';
+ $chksymb[$i] = $1;
+
+ $vectorchk{$1} = $i;
+
+ } elsif ( /^([A-Za-z0-9_]+)DirectReturn:$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'direct';
+ $chksymb[$i] = $1;
+
+ $directchk{$1} = $i;
+
+ } elsif ( /^[A-Za-z0-9_]+_upd:$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
} elsif ( /^[A-Za-z0-9_]/ ) {
local($thing);
chop($thing = $_);
# print out the header stuff first
$chk[0] = "\t\.file\t1 \"$ifile_root.hc\"\n" . $chk[0];
- # get rid of horrible "$Revision: 1.1 $" strings
+ # get rid of horrible "<dollar>Revision: .*$" strings
local(@lines0) = split(/\n/, $chk[0]);
local($z) = 0;
while ( $z <= $#lines0 ) {
print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
# entry code will be put here!
+ # paranoia
+ if ( $chk[$infochk{$symb}] =~ /\.word\s+([A-Za-z0-9_]+_entry)$/
+ && $1 ne "${symb}_entry" ) {
+ print STDERR "!!! entry point???\n",$chk[$infochk{$symb}];
+ }
+
$chkcat[$infochk{$symb}] = 'DONE ALREADY';
}
# teach it to drop through to the fast entry point:
$c = $chk[$slowchk{$symb}];
+
if ( defined($fastchk{$symb}) ) {
$c =~ s/^\tjmp \$31,\(\$27\),0\n\t\.align 4\n\t\.end/\t.align 4\n\t.end/;
}
+ # ToDo??? any good way to look for "dangling" references
+ # to fast-entry pt ???
+
print OUTASM "\t\.text\n\t\.align 2\n";
print OUTASM $c;
$chkcat[$slowchk{$symb}] = 'DONE ALREADY';
$chk[$i] .= $_;
- } elsif ( /^(ret_|djn_)/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
- } elsif ( /^vtbl_([A-Za-z0-9_]+):$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'vector';
- $chksymb[$i] = $1;
-
- $vectorchk{$1} = $i;
-
- } elsif ( /^([A-Za-z0-9_]+)DirectReturn:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'direct';
- $chksymb[$i] = $1;
-
- $directchk{$1} = $i;
-
- } elsif ( /^[A-Za-z0-9_]+_upd:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
} elsif ( /^\.LLC(\d+):$/ ) {
$chk[++$i] .= $_;
$chkcat[$i] = 'string';
$chkcat[$i] = 'infotbl';
$chksymb[$i] = $symb;
+ die "Info table already? $symb; $i\n" if defined($infochk{$symb});
+
$infochk{$symb} = $i;
} elsif ( /^([A-Za-z0-9_]+)_entry:$/ ) {
$chkcat[$i] = 'data';
$chksymb[$i] = '';
+ } elsif ( /^(ret_|djn_)/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
+ } elsif ( /^vtbl_([A-Za-z0-9_]+):$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'vector';
+ $chksymb[$i] = $1;
+
+ $vectorchk{$1} = $i;
+
+ } elsif ( /^([A-Za-z0-9_]+)DirectReturn:$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'direct';
+ $chksymb[$i] = $1;
+
+ $directchk{$1} = $i;
+
+ } elsif ( /^[A-Za-z0-9_]+_upd:$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
} elsif ( /^[A-Za-z0-9_]/ ) {
local($thing);
chop($thing = $_);
print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
# entry code will be put here!
+ # paranoia
+ if ( $chk[$infochk{$symb}] =~ /\.word\s+([A-Za-z0-9_]+_entry)$/
+ && $1 ne "${symb}_entry" ) {
+ print STDERR "!!! entry point???\n",$chk[$infochk{$symb}];
+ }
+
$chkcat[$infochk{$symb}] = 'DONE ALREADY';
}
# teach it to drop through to the fast entry point:
$c = $chk[$slowchk{$symb}];
- $c =~ s/^\tcall _${symb}_fast\d+,.*\n\tnop\n//;
- $c =~ s/^\tcall _${symb}_fast\d+,.*\n(\t[a-z].*\n)/\1/;
+
+ if ( defined($fastchk{$symb}) ) {
+ $c =~ s/^\tcall ${symb}_fast\d+,.*\n\tnop\n//;
+ $c =~ s/^\tcall ${symb}_fast\d+,.*\n(\t[a-z].*\n)/\1/;
+ }
print STDERR "still has jump to fast entry point:\n$c"
- if $c =~ /_${symb}_fast/;
+ if $c =~ /${symb}_fast/; # NB: paranoia
print OUTASM "\.text\n\t\.align 4\n";
print OUTASM $c;
%slowchk = (); # ditto, its regular "slow" entry code
%fastchk = (); # ditto, fast entry code
%closurechk = (); # ditto, the (static) closure
- %num_infos = (); # this symbol base has this many info tables (1-3)
%infochk = (); # given a symbol base, say what chunk its info tbl is in
%vectorchk = (); # ditto, return vector table
%directchk = (); # ditto, direct return code
$chk[$i] .= $_;
- } elsif ( /^_(ret_|djn_)/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
- } elsif ( /^_vtbl_([A-Za-z0-9_]+):$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'vector';
- $chksymb[$i] = $1;
-
- $vectorchk{$1} = $i;
-
- } elsif ( /^_([A-Za-z0-9_]+)DirectReturn:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'direct';
- $chksymb[$i] = $1;
-
- $directchk{$1} = $i;
-
- } elsif ( /^_[A-Za-z0-9_]+_upd:$/ ) {
- $chk[++$i] .= $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
-
} elsif ( /^LC(\d+):$/ ) {
$chk[++$i] .= $_;
$chkcat[$i] = 'string';
$chkcat[$i] = 'infotbl';
$chksymb[$i] = $symb;
+ die "Info table already? $symb; $i\n" if defined($infochk{$symb});
+
$infochk{$symb} = $i;
} elsif ( /^_([A-Za-z0-9_]+)_entry:$/ ) {
$chkcat[$i] = 'data';
$chksymb[$i] = '';
+ } elsif ( /^_(ret_|djn_)/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
+ } elsif ( /^_vtbl_([A-Za-z0-9_]+):$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'vector';
+ $chksymb[$i] = $1;
+
+ $vectorchk{$1} = $i;
+
+ } elsif ( /^_([A-Za-z0-9_]+)DirectReturn:$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'direct';
+ $chksymb[$i] = $1;
+
+ $directchk{$1} = $i;
+
+ } elsif ( /^_[A-Za-z0-9_]+_upd:$/ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
} elsif ( /^_[A-Za-z0-9_]/ ) {
local($thing);
chop($thing = $_);
print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
# entry code will follow, here!
+ # paranoia
+ if ( $chk[$infochk{$symb}] =~ /\.word\s+([A-Za-z0-9_]+_entry)$/
+ && $1 ne "_${symb}_entry" ) {
+ print STDERR "!!! entry point???\n",$chk[$infochk{$symb}];
+ }
+
$chkcat[$infochk{$symb}] = 'DONE ALREADY';
}
# teach it to drop through to the fast entry point:
$c = $chk[$slowchk{$symb}];
- $c =~ s/^\tcall _${symb}_fast\d+,.*\n\tnop\n//;
- $c =~ s/^\tcall _${symb}_fast\d+,.*\n(\t[a-z].*\n)/\1/;
+
+ if ( defined($fastchk{$symb}) ) {
+ $c =~ s/^\tcall _${symb}_fast\d+,.*\n\tnop\n//;
+ $c =~ s/^\tcall _${symb}_fast\d+,.*\n(\t[a-z].*\n)/\1/;
+ }
print STDERR "still has jump to fast entry point:\n$c"
- if $c =~ /_${symb}_fast/;
+ if $c =~ /_${symb}_fast/; # NB: paranoia
print OUTASM "\.text\n\t\.align 4\n";
print OUTASM $c;
--- /dev/null
+%************************************************************************
+%* *
+\section[Driver-asm-fiddling]{Fiddling with assembler files (iX86)}
+%* *
+%************************************************************************
+
+Tasks:
+\begin{itemize}
+\item
+Utterly stomp out C functions' prologues and epilogues; i.e., the
+stuff to do with the C stack.
+\item
+Any other required tidying up.
+\end{itemize}
+
+\begin{code}
+sub init_TARGET_STUFF {
+
+ if ( $TargetPlatform =~ /^i386-.*-linuxaout/ ) {
+
+ $T_STABBY = 1; # 1 iff .stab things (usually if a.out format)
+ $T_US = '_'; # _ if symbols have an underscore on the front
+ $T_DO_GC = '_PerformGC_wrapper';
+ $T_PRE_APP = '^#'; # regexp that says what comes before APP/NO_APP
+ $T_CONST_LBL = '^LC(\d+):$';
+ $T_POST_LBL = ':';
+ $T_PRE_LLBL_PAT = 'L';
+ $T_PRE_LLBL = 'L';
+ $T_X86_BADJMP = '^\tjmp [^L\*]';
+
+ $T_MOVE_DIRVS = '^\s*(\.align\s+\d+(,0x90)?\n|\.globl\s+\S+\n|\.text\n|\.data\n|\.stab[^n].*\n)';
+ $T_COPY_DIRVS = '\.(globl|stab)';
+ $T_hsc_cc_PAT = '\.ascii.*\)(hsc|cc) (.*)\\\\11"\n\t\.ascii\s+"(.*)\\\\0"';
+ $T_DOT_WORD = '\.long';
+ $T_HDR_string = "\.text\n\t\.align 4\n"; # .align 4 is 486-cache friendly
+ $T_HDR_misc = "\.text\n\t\.align 4\n";
+ $T_HDR_data = "\.data\n\t\.align 2\n"; # ToDo: change align??
+ $T_HDR_consist = "\.text\n";
+ $T_HDR_closure = "\.data\n\t\.align 2\n"; # ToDo: change align?
+ $T_HDR_info = "\.text\n\t\.align 4\n"; # NB: requires padding
+ $T_HDR_entry = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?)
+ $T_HDR_fast = "\.text\n\t\.align 4\n";
+ $T_HDR_vector = "\.text\n\t\.align 4\n"; # NB: requires padding
+ $T_HDR_direct = "\.text\n\t\.align 4\n";
+
+ } elsif ( $TargetPlatform =~ /^i386-.*-solaris2/ ) {
+
+ $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
+ $T_US = ''; # _ if symbols have an underscore on the front
+ $T_DO_GC = 'PerformGC_wrapper';
+ $T_PRE_APP = '/'; # regexp that says what comes before APP/NO_APP
+ $T_CONST_LBL = '^\.LC(\d+):$'; # regexp for what such a lbl looks like
+ $T_POST_LBL = ':';
+ $T_PRE_LLBL_PAT = '\.L';
+ $T_PRE_LLBL = '.L';
+ $T_X86_BADJMP = '^\tjmp [^\.\*]';
+
+ $T_MOVE_DIRVS = '^\s*(\.align\s+\d+(,0x90)?\n|\.globl\s+\S+\n|\.text\n|\.data\n|\.section\s+.*\n|\.type\s+.*\n|\.Lfe.*\n\t\.size\s+.*\n|\.size\s+.*\n|\.ident.*\n)';
+ $T_COPY_DIRVS = '\.(globl)';
+
+ $T_hsc_cc_PAT = '\.string.*\)(hsc|cc) (.*)\\\\t(.*)"';
+ $T_DOT_WORD = '\.long';
+ $T_HDR_string = "\.section\t\.rodata\n"; # or just use .text??? (WDP 95/11)
+ $T_HDR_misc = "\.text\n\t\.align 16\n";
+ $T_HDR_data = "\.data\n\t\.align 4\n"; # ToDo: change align??
+ $T_HDR_consist = "\.text\n";
+ $T_HDR_closure = "\.data\n\t\.align 4\n"; # ToDo: change align?
+ $T_HDR_info = "\.text\n\t\.align 16\n"; # NB: requires padding
+ $T_HDR_entry = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?)
+ $T_HDR_fast = "\.text\n\t\.align 16\n";
+ $T_HDR_vector = "\.text\n\t\.align 16\n"; # NB: requires padding
+ $T_HDR_direct = "\.text\n\t\.align 16\n";
+ }
+
+if ( 0 ) {
+print STDERR "T_STABBY: $T_STABBY\n";
+print STDERR "T_US: $T_US\n";
+print STDERR "T_DO_GC: $T_DO_GC\n";
+print STDERR "T_PRE_APP: $T_PRE_APP\n";
+print STDERR "T_CONST_LBL: $T_CONST_LBL\n";
+print STDERR "T_POST_LBL: $T_POST_LBL\n";
+print STDERR "T_PRE_LLBL_PAT: $T_PRE_LLBL_PAT\n";
+print STDERR "T_PRE_LLBL: $T_PRE_LLBL\n";
+print STDERR "T_X86_BADJMP: $T_X86_BADJMP\n";
+
+print STDERR "T_MOVE_DIRVS: $T_MOVE_DIRVS\n";
+print STDERR "T_COPY_DIRVS: $T_COPY_DIRVS\n";
+print STDERR "T_hsc_cc_PAT: $T_hsc_cc_PAT\n";
+print STDERR "T_DOT_WORD: $T_DOT_WORD\n";
+print STDERR "T_HDR_string: $T_HDR_string\n";
+print STDERR "T_HDR_misc: $T_HDR_misc\n";
+print STDERR "T_HDR_data: $T_HDR_data\n";
+print STDERR "T_HDR_consist: $T_HDR_consist\n";
+print STDERR "T_HDR_closure: $T_HDR_closure\n";
+print STDERR "T_HDR_info: $T_HDR_info\n";
+print STDERR "T_HDR_entry: $T_HDR_entry\n";
+print STDERR "T_HDR_fast: $T_HDR_fast\n";
+print STDERR "T_HDR_vector: $T_HDR_vector\n";
+print STDERR "T_HDR_direct: $T_HDR_direct\n";
+}
+
+}
+\end{code}
+
+\begin{code}
+sub mangle_asm {
+ local($in_asmf, $out_asmf) = @_;
+
+ # multi-line regexp matching:
+ local($*) = 1;
+ local($i, $c);
+ &init_TARGET_STUFF();
+ &init_FUNNY_THINGS();
+
+ open(INASM, "< $in_asmf")
+ || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n");
+ open(OUTASM,"> $out_asmf")
+ || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n");
+
+ # read whole file, divide into "chunks":
+ # record some info about what we've found...
+
+ @chk = (); # contents of the chunk
+ $numchks = 0; # number of them
+ @chkcat = (); # what category of thing in each chunk
+ @chksymb = (); # what symbol(base) is defined in this chunk
+ %slowchk = (); # ditto, its regular "slow" entry code
+ %fastchk = (); # ditto, fast entry code
+ %closurechk = (); # ditto, the (static) closure
+ %infochk = (); # given a symbol base, say what chunk its info tbl is in
+ %vectorchk = (); # ditto, return vector table
+ %directchk = (); # ditto, direct return code
+
+ $i = 0;
+ $chkcat[0] = 'misc';
+
+ while (<INASM>) {
+ next if $T_STABBY && /^\.stab.*${T_US}__stg_split_marker/o;
+ next if $T_STABBY && /^\.stab.*ghc.*c_ID/;
+ next if /${T_PRE_APP}(NO_)?APP/o;
+
+ if ( /^\s+/ ) { # most common case first -- a simple line!
+ # duplicated from the bottom
+
+ $chk[$i] .= $_;
+
+ } elsif ( /$T_CONST_LBL/o ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'string';
+ $chksymb[$i] = $1;
+
+ } elsif ( /^${T_US}__stg_split_marker(\d+)${T_POST_LBL}$/o ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'splitmarker';
+ $chksymb[$i] = $1;
+
+ } elsif ( /^${T_US}([A-Za-z0-9_]+)_info${T_POST_LBL}$/o ) {
+ $symb = $1;
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'infotbl';
+ $chksymb[$i] = $symb;
+
+ die "Info table already? $symb; $i\n" if defined($infochk{$symb});
+
+ $infochk{$symb} = $i;
+
+ } elsif ( /^${T_US}([A-Za-z0-9_]+)_entry${T_POST_LBL}$/o ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'slow';
+ $chksymb[$i] = $1;
+
+ $slowchk{$1} = $i;
+
+ } elsif ( /^${T_US}([A-Za-z0-9_]+)_fast\d+${T_POST_LBL}$/o ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'fast';
+ $chksymb[$i] = $1;
+
+ $fastchk{$1} = $i;
+
+ } elsif ( /^${T_US}([A-Za-z0-9_]+)_closure${T_POST_LBL}$/o ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'closure';
+ $chksymb[$i] = $1;
+
+ $closurechk{$1} = $i;
+
+ } elsif ( /^${T_US}ghc.*c_ID${T_POST_LBL}/o ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'consist';
+
+ } elsif ( /^(___gnu_compiled_c|gcc2_compiled\.)${T_POST_LBL}/o ) {
+ ; # toss it
+
+ } elsif ( /^${T_US}ErrorIO_call_count${T_POST_LBL}$/o # HACK!!!!
+ || /^${T_US}[A-Za-z0-9_]+\.\d+${T_POST_LBL}$/o
+ || /^${T_US}.*_CAT${T_POST_LBL}$/o # PROF: _entryname_CAT
+ || /^${T_US}CC_.*_struct${T_POST_LBL}$/o # PROF: _CC_ccident_struct
+ || /^${T_US}.*_done${T_POST_LBL}$/o # PROF: _module_done
+ || /^${T_US}_module_registered${T_POST_LBL}$/o # PROF: _module_registered
+ ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'data';
+ $chksymb[$i] = '';
+
+ } elsif ( /^${T_US}(ret_|djn_)/o ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
+ } elsif ( /^${T_US}vtbl_([A-Za-z0-9_]+)${T_POST_LBL}$/o ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'vector';
+ $chksymb[$i] = $1;
+
+ $vectorchk{$1} = $i;
+
+ } elsif ( /^${T_US}([A-Za-z0-9_]+)DirectReturn${T_POST_LBL}$/o ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'direct';
+ $chksymb[$i] = $1;
+
+ $directchk{$1} = $i;
+
+ } elsif ( /^${T_US}[A-Za-z0-9_]+_upd${T_POST_LBL}$/o ) {
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
+ } elsif ( $TargetPlatform =~ /^i386-.*-solaris2/
+ && /^(_uname|uname|stat|fstat):/ ) {
+ # for some utterly bizarre reason, this platform
+ # likes to drop little local C routines with these names
+ # into each and every .o file that #includes the
+ # relevant system .h file. Yuck. We just don't
+ # tolerate them in .hc files (which we are processing
+ # here). If you need to call one of these things from
+ # Haskell, make a call to your own C wrapper, then
+ # put that C wrapper (which calls one of these) in a
+ # plain .c file. WDP 95/12
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'toss';
+ $chksymb[$i] = $1;
+
+ } elsif ( /^${T_US}[A-Za-z0-9_]/o ) {
+ local($thing);
+ chop($thing = $_);
+ print STDERR "Funny global thing?: $_"
+ unless $KNOWN_FUNNY_THING{$thing}
+ || /^${T_US}_(PRIn|PRStart).*${T_POST_LBL}$/o # pointer reversal GC routines
+ || /^${T_US}CC_.*${T_POST_LBL}$/ # PROF: _CC_ccident
+ || /^${T_US}_reg.*${T_POST_LBL}$/; # PROF: __reg<module>
+ $chk[++$i] .= $_;
+ $chkcat[$i] = 'misc';
+ $chksymb[$i] = '';
+
+ } else { # simple line (duplicated at the top)
+
+ $chk[$i] .= $_;
+ }
+ }
+ $numchks = $#chk + 1;
+
+ # the division into chunks is imperfect;
+ # we throw some things over the fence into the next
+ # chunk.
+ #
+ # also, there are things we would like to know
+ # about the whole module before we start spitting
+ # output.
+
+ for ($i = 0; $i < $numchks; $i++) {
+ $c = $chk[$i]; # convenience copy
+
+# print STDERR "\nCHK $i (BEFORE) (",$chkcat[$i],"):\n", $c;
+
+ # toss all prologue stuff;
+ # be slightly paranoid to make sure there's
+ # nothing surprising in there
+ if ( $c =~ /--- BEGIN ---/ ) {
+ if (($p, $r) = split(/--- BEGIN ---/, $c)) {
+ $p =~ s/^\tpushl \%edi\n//;
+ $p =~ s/^\tpushl \%esi\n//;
+ $p =~ s/^\tsubl \$\d+,\%esp\n//;
+ die "Prologue junk?: $p\n" if $p =~ /^\t[^\.]/;
+
+ # glue together what's left
+ $c = $p . $r;
+ }
+ }
+
+ # toss all epilogue stuff; again, paranoidly
+ if ( $c =~ /--- END ---/ ) {
+ if (($r, $e) = split(/--- END ---/, $c)) {
+ $e =~ s/^\tret\n//;
+ $e =~ s/^\tpopl \%edi\n//;
+ $e =~ s/^\tpopl \%esi\n//;
+ $e =~ s/^\taddl \$\d+,\%esp\n//;
+ die "Epilogue junk?: $e\n" if $e =~ /^\t[^\.]/;
+
+ # glue together what's left
+ $c = $r . $e;
+ }
+ }
+
+ # toss all calls to __DISCARD__
+ $c =~ s/^\tcall ${T_US}__DISCARD__\n//go;
+
+ # pin a funny end-thing on (for easier matching):
+ $c .= 'FUNNY#END#THING';
+
+ # pick some end-things and move them to the next chunk
+
+ while ( $c =~ /${T_MOVE_DIRVS}FUNNY#END#THING/o ) {
+ $to_move = $1;
+
+ if ( $to_move =~ /${T_COPY_DIRVS}/ && $i < ($numchks - 1) ) {
+ $chk[$i + 1] = $to_move . $chk[$i + 1];
+ # otherwise they're tossed
+ }
+
+ $c =~ s/${T_MOVE_DIRVS}FUNNY#END#THING/FUNNY#END#THING/o;
+ }
+
+ $c =~ s/FUNNY#END#THING//;
+
+# print STDERR "\nCHK $i (AFTER) (",$chkcat[$i],"):\n", $c;
+
+ $chk[$i] = $c; # update w/ convenience copy
+ }
+
+ # print out all the literal strings first
+ for ($i = 0; $i < $numchks; $i++) {
+ if ( $chkcat[$i] eq 'string' ) {
+ print OUTASM $T_HDR_string, $chk[$i];
+
+ $chkcat[$i] = 'DONE ALREADY';
+ }
+ }
+
+ for ($i = 0; $i < $numchks; $i++) {
+# print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n";
+
+ next if $chkcat[$i] eq 'DONE ALREADY';
+
+ if ( $chkcat[$i] eq 'misc' ) {
+ print OUTASM $T_HDR_misc;
+ &print_doctored($chk[$i], 0);
+
+ } elsif ( $chkcat[$i] eq 'toss' ) {
+ print STDERR "*** NB: TOSSING code for $chksymb[$i] !!! ***\n";
+
+ } elsif ( $chkcat[$i] eq 'data' ) {
+ print OUTASM $T_HDR_data;
+ print OUTASM $chk[$i];
+
+ } elsif ( $chkcat[$i] eq 'consist' ) {
+ if ( $chk[$i] =~ /$T_hsc_cc_PAT/o ) {
+ local($consist) = "$1.$2.$3";
+ $consist =~ s/,/./g;
+ $consist =~ s/\//./g;
+ $consist =~ s/-/_/g;
+ $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly?
+ print OUTASM $T_HDR_consist, "${consist}${T_POST_LBL}\n";
+ } else {
+ print STDERR "Couldn't grok consistency: ", $chk[$i];
+ }
+
+ } elsif ( $chkcat[$i] eq 'splitmarker' ) {
+ # we can just re-constitute this one...
+ print OUTASM "${T_US}__stg_split_marker",$chksymb[$i],"${T_POST_LBL}\n";
+
+ } elsif ( $chkcat[$i] eq 'closure'
+ || $chkcat[$i] eq 'infotbl'
+ || $chkcat[$i] eq 'slow'
+ || $chkcat[$i] eq 'fast' ) { # do them in that order
+ $symb = $chksymb[$i];
+
+ # CLOSURE
+ if ( defined($closurechk{$symb}) ) {
+ print OUTASM $T_HDR_closure;
+ print OUTASM $chk[$closurechk{$symb}];
+ $chkcat[$closurechk{$symb}] = 'DONE ALREADY';
+ }
+
+ # INFO TABLE
+ if ( defined($infochk{$symb}) ) {
+
+ print OUTASM $T_HDR_info;
+ print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
+ # entry code will be put here!
+
+ # paranoia
+ if ( $chk[$infochk{$symb}] =~ /${T_DOT_WORD}\s+([A-Za-z0-9_]+_entry)$/o
+ && $1 ne "${T_US}${symb}_entry" ) {
+ print STDERR "!!! entry point???\n",$chk[$infochk{$symb}];
+ }
+
+ $chkcat[$infochk{$symb}] = 'DONE ALREADY';
+ }
+
+ # STD ENTRY POINT
+ if ( defined($slowchk{$symb}) ) {
+
+ # teach it to drop through to the fast entry point:
+ $c = $chk[$slowchk{$symb}];
+
+ if ( defined($fastchk{$symb}) ) {
+ $c =~ s/^\tmovl \$${T_US}${symb}_fast\d+,\%edx\n\tjmp \*\%edx\n//;
+ $c =~ s/^\tmovl \$${T_US}${symb}_fast\d+,\%eax\n\tjmp \*\%eax\n//;
+ }
+
+ print STDERR "still has jump to fast entry point:\n$c"
+ if $c =~ /${T_US}${symb}_fast/; # NB: paranoia
+
+ print OUTASM $T_HDR_entry;
+
+ &print_doctored($c, 1); # NB: the 1!!!
+
+ $chkcat[$slowchk{$symb}] = 'DONE ALREADY';
+ }
+
+ # FAST ENTRY POINT
+ if ( defined($fastchk{$symb}) ) {
+ print OUTASM $T_HDR_fast;
+ &print_doctored($chk[$fastchk{$symb}], 0);
+ $chkcat[$fastchk{$symb}] = 'DONE ALREADY';
+ }
+
+ } elsif ( $chkcat[$i] eq 'vector'
+ || $chkcat[$i] eq 'direct' ) { # do them in that order
+ $symb = $chksymb[$i];
+
+ # VECTOR TABLE
+ if ( defined($vectorchk{$symb}) ) {
+ print OUTASM $T_HDR_vector;
+ print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0);
+ # direct return code will be put here!
+ $chkcat[$vectorchk{$symb}] = 'DONE ALREADY';
+ }
+
+ # DIRECT RETURN
+ if ( defined($directchk{$symb}) ) {
+ print OUTASM $T_HDR_direct;
+ &print_doctored($chk[$directchk{$symb}], 0);
+ $chkcat[$directchk{$symb}] = 'DONE ALREADY';
+ }
+
+ } else {
+ &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm: $TargetPlatform)\n$chkcat[$i]\n$chk[$i]\n");
+ }
+ }
+ # finished
+ close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n");
+ close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n");
+}
+\end{code}
+
+\begin{code}
+sub print_doctored {
+ local($_, $need_fallthru_patch) = @_;
+
+ if ( $TargetPlatform !~ /^i386-/
+ || ! /^\t[a-z]/ ) { # no instructions in here, apparently
+ print OUTASM $_;
+ return;
+ }
+ # OK, must do some x86 **HACKING**
+
+ local($entry_patch) = '';
+ local($exit_patch) = '';
+ local($call_entry_patch)= '';
+ local($call_exit_patch) = '';
+
+#OLD: # first, convert calls to *very magic form*: (ToDo: document
+ # for real!) from
+ #
+ # pushl $768
+ # call _?PerformGC_wrapper
+ # addl $4,%esp
+ # to
+ # movl $768, %eax
+ # call _?PerformGC_wrapper
+ #
+ # The reason we do this now is to remove the apparent use of
+ # %esp, which would throw off the "what patch code do we need"
+ # decision.
+ #
+ # Special macros in ghc/includes/COptWraps.lh, used in
+ # ghc/runtime/CallWrap_C.lc, are required for this to work!
+ #
+
+ s/^\tpushl \$(\d+)\n\tcall ${T_DO_GC}\n\taddl \$4,\%esp\n/\tmovl \$$1,\%eax\n\tcall ${T_DO_GC}\n/go;
+ s/^\tpushl \%eax\n\tcall ${T_DO_GC}\n\taddl \$4,\%esp\n/\tcall ${T_DO_GC}\n/go;
+ s/^\tpushl \%edx\n\tcall ${T_DO_GC}\n\taddl \$4,\%esp\n/\tmovl \%edx,\%eax\n\tcall ${T_DO_GC}\n/go;
+
+#= if ( $StolenX86Regs <= 4 ) { # %ecx is ordinary reg
+#= s/^\tpushl \%ecx\n\tcall ${T_DO_GC}\n\taddl \$4,\%esp\n/\tmovl \%ecx,\%eax\n\tcall ${T_DO_GC}\n/go;
+#= }
+
+ # gotta watch out for weird instructions that
+ # invisibly smash various regs:
+ # rep* %ecx used for counting
+ # scas* %edi used for destination index
+ # cmps* %e[sd]i used for indices
+ # loop* %ecx used for counting
+ #
+ # SIGH.
+
+ # We cater for:
+ # * use of STG reg [ nn(%ebx) ] where no machine reg avail
+ #
+ # * GCC used an "STG reg" for its own purposes
+ #
+ # * some secret uses of machine reg, requiring STG reg
+ # to be saved/restored
+
+ # The most dangerous "GCC uses" of an "STG reg" are when
+ # the reg holds the target of a jmp -- it's tricky to
+ # insert the patch-up code before we get to the target!
+ # So here we change the jmps:
+
+ # --------------------------------------------------------
+ # it can happen that we have jumps of the form...
+ # jmp *<something involving %esp>
+ # or
+ # jmp <something involving another naughty register...>
+ #
+ # a reasonably-common case is:
+ #
+ # movl $_blah,<bad-reg>
+ # jmp *<bad-reg>
+ #
+ # which is easily fixed as:
+ #
+ # sigh! try to hack around it...
+ #
+
+ if ($StolenX86Regs <= 2 ) { # YURGH! spurious uses of esi?
+ s/^\tmovl (.*),\%esi\n\tjmp \*%esi\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/g;
+ s/^\tjmp \*(-?\d*)\((.*\%esi.*)\)\n/\tmovl $2,\%eax\n\tjmp \*$1\(\%eax\)\n/g;
+ s/^\tjmp \*\%esi\n/\tmovl \%esi,\%eax\n\tjmp \*\%eax\n/g;
+ die "$Pgm: (mangler) still have jump involving \%esi!\n$_"
+ if /(jmp|call) .*\%esi/;
+ }
+ if ($StolenX86Regs <= 3 ) { # spurious uses of edi?
+ s/^\tmovl (.*),\%edi\n\tjmp \*%edi\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/g;
+ s/^\tjmp \*(-?\d*)\((.*\%edi.*)\)\n/\tmovl $2,\%eax\n\tjmp \*$1\(\%eax\)\n/g;
+ s/^\tjmp \*\%edi\n/\tmovl \%edi,\%eax\n\tjmp \*\%eax\n/g;
+ die "$Pgm: (mangler) still have jump involving \%edi!\n$_"
+ if /(jmp|call) .*\%edi/;
+ }
+#= if ($StolenX86Regs <= 4 ) { # spurious uses of ecx?
+#= s/^\tmovl (.*),\%ecx\n\tjmp \*%ecx\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/g;
+#= s/^\tjmp \*(-?\d*)\((.*\%ecx.*)\)\n/\tmovl $2,\%eax\n\tjmp \*$1\(\%eax\)\n/g;
+#= s/^\tjmp \*\%ecx\n/\tmovl \%ecx,\%eax\n\tjmp \*\%eax\n/g;
+#= die "$Pgm: (mangler) still have jump involving \%ecx!\n$_"
+#= if /(jmp|call) .*\%ecx/;
+#= }
+
+ # OK, now we can decide what our patch-up code is going to
+ # be:
+ if ( $StolenX86Regs <= 2
+ && ( /32\(\%ebx\)/ || /\%esi/ || /^\tcmps/ ) ) { # R1 (esi)
+ $entry_patch .= "\tmovl \%esi,32(\%ebx)\n";
+ $exit_patch .= "\tmovl 32(\%ebx),\%esi\n";
+ # nothing for call_{entry,exit} because %esi is callee-save
+ }
+ if ( $StolenX86Regs <= 3
+ && ( /64\(\%ebx\)/ || /\%edi/ || /^\t(scas|cmps)/ ) ) { # SpA (edi)
+ $entry_patch .= "\tmovl \%edi,64(\%ebx)\n";
+ $exit_patch .= "\tmovl 64(\%ebx),\%edi\n";
+ # nothing for call_{entry,exit} because %edi is callee-save
+ }
+#= if ( $StolenX86Regs <= 4
+#= && ( /80\(\%ebx\)/ || /\%ecx/ || /^\t(rep|loop)/ ) ) { # Hp (ecx)
+#= $entry_patch .= "\tmovl \%ecx,80(\%ebx)\n";
+#= $exit_patch .= "\tmovl 80(\%ebx),\%ecx\n";
+#=
+#= $call_exit_patch .= "\tmovl \%ecx,108(\%ebx)\n";
+#= $call_entry_patch .= "\tmovl 108(\%ebx),\%ecx\n";
+#= # I have a really bad feeling about this if we ever
+#= # have a nested call...
+#= # NB: should just hide it somewhere in the C stack.
+#= }
+ # --------------------------------------------------------
+ # next, here we go with non-%esp patching!
+ #
+ s/^(\t[a-z])/$entry_patch$1/; # before first instruction
+ s/^(\tcall .*\n(\taddl \$\d+,\%esp\n)?)/$call_exit_patch$1$call_entry_patch/g; # _all_ calls
+
+ # fix _all_ non-local jumps:
+
+ s/^\tjmp \*${T_PRE_LLBL_PAT}/\tJMP___SL/go;
+ s/^\tjmp ${T_PRE_LLBL_PAT}/\tJMP___L/go;
+
+ s/^(\tjmp .*\n)/$exit_patch$1/g; # here's the fix...
+
+ s/^\tJMP___SL/\tjmp \*${T_PRE_LLBL}/go;
+ s/^\tJMP___L/\tjmp ${T_PRE_LLBL}/go;
+
+ # fix post-PerformGC wrapper (re-)entries ???
+
+ if ($StolenX86Regs == 2 ) {
+ die "ARGH! Jump uses \%esi or \%edi with -monly-2-regs:\n$_"
+ if /^\t(jmp|call) .*\%e(si|di)/;
+#= die "ARGH! Jump uses \%esi, \%edi, or \%ecx with -monly-2-regs:\n$_"
+#= if /^\t(jmp|call) .*\%e(si|di|cx)/;
+ } elsif ($StolenX86Regs == 3 ) {
+ die "ARGH! Jump uses \%edi with -monly-3-regs:\n$_"
+ if /^\t(jmp|call) .*\%edi/;
+#= die "ARGH! Jump uses \%edi or \%ecx with -monly-3-regs:\n$_"
+#= if /^\t(jmp|call) .*\%e(di|cx)/;
+#= } elsif ($StolenX86Regs == 4 ) {
+#= die "ARGH! Jump uses \%ecx with -monly-4-regs:\n$_"
+#= if /^\t(jmp|call) .*\%ecx/;
+ }
+
+ # final peephole fix
+
+ s/^\tmovl \%eax,36\(\%ebx\)\n\tjmp \*36\(\%ebx\)\n/\tmovl \%eax,36\(\%ebx\)\n\tjmp \*\%eax\n/;
+
+ # --------------------------------------------------------
+ # that's it -- print it
+ #
+ die "Funny jumps?\n$_" if /${T_X86_BADJMP}/o; # paranoia
+
+ print OUTASM $_;
+
+ if ( $need_fallthru_patch ) { # exit patch for end of slow entry code
+ print OUTASM $exit_patch;
+ # ToDo: make it not print if there is a "jmp" at the end
+ }
+}
+\end{code}
+
+\begin{code}
+sub init_FUNNY_THINGS {
+ %KNOWN_FUNNY_THING = (
+ "${T_US}CheckHeapCode${T_POST_LBL}", 1,
+ "${T_US}CommonUnderflow${T_POST_LBL}", 1,
+ "${T_US}Continue${T_POST_LBL}", 1,
+ "${T_US}EnterNodeCode${T_POST_LBL}", 1,
+ "${T_US}ErrorIO_call_count${T_POST_LBL}", 1,
+ "${T_US}ErrorIO_innards${T_POST_LBL}", 1,
+ "${T_US}IndUpdRetDir${T_POST_LBL}", 1,
+ "${T_US}IndUpdRetV0${T_POST_LBL}", 1,
+ "${T_US}IndUpdRetV1${T_POST_LBL}", 1,
+ "${T_US}IndUpdRetV2${T_POST_LBL}", 1,
+ "${T_US}IndUpdRetV3${T_POST_LBL}", 1,
+ "${T_US}IndUpdRetV4${T_POST_LBL}", 1,
+ "${T_US}IndUpdRetV5${T_POST_LBL}", 1,
+ "${T_US}IndUpdRetV6${T_POST_LBL}", 1,
+ "${T_US}IndUpdRetV7${T_POST_LBL}", 1,
+ "${T_US}PrimUnderflow${T_POST_LBL}", 1,
+ "${T_US}StackUnderflowEnterNode${T_POST_LBL}", 1,
+ "${T_US}StdErrorCode${T_POST_LBL}", 1,
+ "${T_US}UnderflowVect0${T_POST_LBL}", 1,
+ "${T_US}UnderflowVect1${T_POST_LBL}", 1,
+ "${T_US}UnderflowVect2${T_POST_LBL}", 1,
+ "${T_US}UnderflowVect3${T_POST_LBL}", 1,
+ "${T_US}UnderflowVect4${T_POST_LBL}", 1,
+ "${T_US}UnderflowVect5${T_POST_LBL}", 1,
+ "${T_US}UnderflowVect6${T_POST_LBL}", 1,
+ "${T_US}UnderflowVect7${T_POST_LBL}", 1,
+ "${T_US}UpdErr${T_POST_LBL}", 1,
+ "${T_US}UpdatePAP${T_POST_LBL}", 1,
+ "${T_US}WorldStateToken${T_POST_LBL}", 1,
+ "${T_US}_Enter_Internal${T_POST_LBL}", 1,
+ "${T_US}_PRMarking_MarkNextAStack${T_POST_LBL}", 1,
+ "${T_US}_PRMarking_MarkNextBStack${T_POST_LBL}", 1,
+ "${T_US}_PRMarking_MarkNextCAF${T_POST_LBL}", 1,
+ "${T_US}_PRMarking_MarkNextGA${T_POST_LBL}", 1,
+ "${T_US}_PRMarking_MarkNextRoot${T_POST_LBL}", 1,
+ "${T_US}_PRMarking_MarkNextSpark${T_POST_LBL}", 1,
+ "${T_US}_Scavenge_Forward_Ref${T_POST_LBL}", 1,
+ "${T_US}__std_entry_error__${T_POST_LBL}", 1,
+ "${T_US}_startMarkWorld${T_POST_LBL}", 1,
+ "${T_US}resumeThread${T_POST_LBL}", 1,
+ "${T_US}startCcRegisteringWorld${T_POST_LBL}", 1,
+ "${T_US}startEnterFloat${T_POST_LBL}", 1,
+ "${T_US}startEnterInt${T_POST_LBL}", 1,
+ "${T_US}startPerformIO${T_POST_LBL}", 1,
+ "${T_US}startStgWorld${T_POST_LBL}", 1,
+ "${T_US}stopPerformIO${T_POST_LBL}", 1
+ );
+}
+\end{code}
+
+The following table reversal is used for both info tables and return
+vectors. In both cases, we remove the first entry from the table,
+reverse the table, put the label at the end, and paste some code
+(that which is normally referred to by the first entry in the table)
+right after the table itself. (The code pasting is done elsewhere.)
+
+\begin{code}
+sub rev_tbl {
+ local($symb, $tbl, $discard1) = @_;
+
+ local($before) = '';
+ local($label) = '';
+ local(@words) = ();
+ local($after) = '';
+ local(@lines) = split(/\n/, $tbl);
+ local($i, $extra, $words_to_pad, $j);
+
+ for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t\.long\s+/; $i++) {
+ $label .= $lines[$i] . "\n",
+ next if $lines[$i] =~ /^[A-Za-z0-9_]+_info:$/
+ || $lines[$i] =~ /^\.globl/
+ || $lines[$i] =~ /^${T_US}vtbl_\S+:$/;
+
+ $before .= $lines[$i] . "\n"; # otherwise...
+ }
+
+ for ( ; $i <= $#lines && $lines[$i] =~ /^\t\.long\s+/; $i++) {
+ push(@words, $lines[$i]);
+ }
+ # now throw away the first word (entry code):
+ shift(@words) if $discard1;
+
+ # for 486-cache-friendliness, we want our tables aligned
+ # on 16-byte boundaries (.align 4). Let's pad:
+ $extra = ($#words + 1) % 4;
+ $words_to_pad = ($extra == 0) ? 0 : 4 - $extra;
+ for ($j = 0; $j < $words_to_pad; $j++) { push(@words, "\t\.long 0"); }
+
+ for (; $i <= $#lines; $i++) {
+ $after .= $lines[$i] . "\n";
+ }
+
+ $tbl = $before . join("\n", (reverse @words)) . "\n" . $label . $after;
+
+# print STDERR "before=$before\n";
+# print STDERR "label=$label\n";
+# print STDERR "words=",(reverse @words),"\n";
+# print STDERR "after=$after\n";
+
+ $tbl;
+}
+\end{code}
+
+\begin{code}
+sub mini_mangle_asm {
+ local($in_asmf, $out_asmf) = @_;
+
+ &init_TARGET_STUFF();
+
+ open(INASM, "< $in_asmf")
+ || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n");
+ open(OUTASM,"> $out_asmf")
+ || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n");
+
+ while (<INASM>) {
+ print OUTASM;
+
+ next unless
+ /^${T_US}(PerformGC|StackOverflow|Yield|PerformReschedule)_wrapper${T_POST_LBL}\n/o;
+ print OUTASM "\tmovl \%esp, ${T_US}__temp_esp\n";
+ print OUTASM "\tmovl \%eax, ${T_US}__temp_eax\n";
+ }
+
+ # finished:
+ close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n");
+ close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n");
+}
+
+# make "require"r happy...
+1;
+\end{code}
%LocalConstant = (); # we have to subvert C compiler's commoning-up of constants...
- $s_stuff = &ReadTMPIUpToAMarker( '' );
+ $s_stuff = &ReadTMPIUpToAMarker( '', $octr );
# that first stuff is a prologue for all .s outputs
$prologue_stuff = &process_asm_block ( $s_stuff );
# $_ already has some of the next stuff in it...
$prologue_stuff =~ s|"/tmp/ghc\d+\.c"|"$ifile_root\.hc"|g;
while ( $_ ne '' ) { # not EOF
+ $octr++;
# grab and de-mangle a section of the .s file...
- $s_stuff = &ReadTMPIUpToAMarker ( $_ );
+ $s_stuff = &ReadTMPIUpToAMarker ( $_, $octr );
$this_piece = &process_asm_block ( $s_stuff );
# output to a file of its own
# open a new output file...
- $octr++;
$ofname = "${Tmp_prefix}__${octr}.s";
open(OUTF, "> $ofname") || die "$Pgm: can't open output file: $ofname\n";
}
sub ReadTMPIUpToAMarker {
- local($str) = @_; # already read bits
+ local($str, $count) = @_; # already read bits
for ( $_ = <TMPI>; $_ ne '' && ! /_?__stg_split_marker/; $_ = <TMPI> ) {
$_ = <TMPI>;
}
- print STDERR "### BLOCK:\n$str" if $Dump_asm_splitting_info;
+ print STDERR "### BLOCK:$count:\n$str" if $Dump_asm_splitting_info;
# return str
$str;
\begin{code}
$OptLevel = 0; # no -O == 0; -O == 1; -O2 == 2; -Ofile == 3
$MinusO2ForC = 0; # set to 1 if -O2 should be given to C compiler
-$StolenX86Regs = 5; # **HACK*** of the very worst sort
-$SpX86Mangling = 1; # **EXTREME HACK*** of an even worse sort
+$StolenX86Regs = 4; # **HACK*** of the very worst sort
\end{code}
These variables represent parts of the -O/-O2/etc ``templates,''
#OLD:$Oopt_LambdaLift = '';
$Oopt_AddAutoSccs = '';
$Oopt_FinalStgProfilingMassage = '';
+$Oopt_StgStats = '';
$Oopt_SpecialiseUnboxed = '';
$Oopt_FoldrBuild = 1; # On by default!
$Oopt_FB_Support = '-fdo-new-occur-anal -fdo-arity-expand';
@As_flags = ();
$Lnkr = ''; # linker is normally the same pgm as used for C compilation
+@Ld_flags = ();
# 'nm' is used for consistency checking (ToDo: mk-world-ify)
# ToDo: check the OS or something ("alpha" is surely not the crucial question)
'_l', '$(GHC_BUILD_FLAG_l)',
'_m', '$(GHC_BUILD_FLAG_m)',
'_n', '$(GHC_BUILD_FLAG_n)',
- '_o', '$(GHC_BUILD_FLAG_o)' );
+ '_o', '$(GHC_BUILD_FLAG_o)',
+ '_A', '$(GHC_BUILD_FLAG_A)',
+ '_B', '$(GHC_BUILD_FLAG_B)' );
%BuildDescr = ('', 'normal sequential',
'_p', 'profiling',
'_l', 'user way l',
'_m', 'user way m',
'_n', 'user way n',
- '_o', 'user way o' );
+ '_o', 'user way o',
+ '_A', 'user way A',
+ '_B', 'user way B' );
# these are options that are "fed back" through the option processing loop
%UserSetupOpts = ('_a', '$(GHC_BUILD_OPTS_a)',
'_m', '$(GHC_BUILD_OPTS_m)',
'_n', '$(GHC_BUILD_OPTS_n)',
'_o', '$(GHC_BUILD_OPTS_o)',
+ '_A', '$(GHC_BUILD_OPTS_A)',
+ '_B', '$(GHC_BUILD_OPTS_B)',
# the GC ones don't have any "fed back" options
'_2s', '',
# profiled sequential
'_p', 'push(@HsC_flags, \'-fscc-profiling\');
- push(@CcBoth_flags, \'-DUSE_COST_CENTRES\');',
+ push(@CcBoth_flags, \'-DPROFILING\');',
# ticky-ticky sequential
- '_t', 'push(@HsC_flags, \'-fstg-reduction-counts\');
- push(@CcBoth_flags, \'-DDO_REDN_COUNTING\');',
+ '_t', 'push(@HsC_flags, \'-fticky-ticky\');
+ push(@CcBoth_flags, \'-DTICKY_TICKY\');',
# unregisterized (ToDo????)
'_u', '',
'_mr', '$StkChkByPageFaultOK = 0;
push(@HsC_flags, \'-fconcurrent\', \'-fscc-profiling\');
push(@HsCpp_flags,\'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\');
- push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DUSE_COST_CENTRES\');',
+ push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DPROFILING\');',
# ticky-ticky concurrent
'_mt', '$StkChkByPageFaultOK = 0;
- push(@HsC_flags, \'-fconcurrent\', \'-fstg-reduction-counts\');
+ push(@HsC_flags, \'-fconcurrent\', \'-fticky-ticky\');
push(@HsCpp_flags,\'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\');
- push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DDO_REDN_COUNTING\');',
+ push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DTICKY_TICKY\');',
# parallel
'_mp', '$StkChkByPageFaultOK = 0;
push(@HsC_flags, \'-fconcurrent\');
push(@HsCpp_flags,\'-D__PARALLEL_HASKELL__\', \'-DPAR\');
- push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DPAR\', \'-DGUM\');',
+ push(@Cpp_define, \'-D__CONCURRENT_HASKELL__\', \'-DCONCURRENT\', \'-DPAR\');',
# GranSim
'_mg', '$StkChkByPageFaultOK = 0;
'_l', '',
'_m', '',
'_n', '',
- '_o', '' );
+ '_o', '',
+ '_A', '',
+ '_B', '' );
\end{code}
Import/include directories (\tr{-I} options) are sufficiently weird to
# or if generating equiv asm code
$DEBUGging = ''; # -DDEBUG and all that it entails (um... not really)
$PROFing = ''; # set to p or e if profiling
-$PROFaging = ''; # set to a if profiling with age -- only for cc consistency
$PROFgroup = ''; # set to group if an explicit -Ggroup specified
$PROFauto = ''; # set to relevant hsc flag if -auto or -auto-all
$PROFcaf = ''; # set to relevant hsc flag if -caf-all
#UNUSED:$PROFdict = ''; # set to relevant hsc flag if -dict-all
$PROFignore_scc = ''; # set to relevant parser flag if explicit sccs ignored
$TICKYing = ''; # set to t if compiling for ticky-ticky profiling
-$PARing = ''; # set to p if compiling for PAR (ie GUM)
+$PARing = ''; # set to p if compiling for PAR
$CONCURing = ''; # set to c if compiling for CONCURRENT
$GRANing = ''; # set to g if compiling for GRAN
$StkChkByPageFaultOK = 1; # may be set to 0 (false) for some builds
/^-prof$/ && do { $PROFing = 'p'; next arg; }; # profiling -- details later!
- /^-fheap-profiling-with-age$/ && do {
- $PROFaging = 'a';
- push(@CcBoth_flags, '-DHEAP_PROF_WITH_AGE');
- next arg; };
-
/^-auto/ && do {
# generate auto SCCs on top level bindings
# -auto-all = all top level bindings
#-------------- "user ways" --------------------------------------------
- (/^-user-setup-([a-o])$/
+ (/^-user-setup-([a-oA-Z])$/
|| /^$(GHC_BUILD_FLAG_a)$/
|| /^$(GHC_BUILD_FLAG_b)$/
|| /^$(GHC_BUILD_FLAG_c)$/
|| /^$(GHC_BUILD_FLAG_m)$/
|| /^$(GHC_BUILD_FLAG_n)$/
|| /^$(GHC_BUILD_FLAG_o)$/
+ || /^$(GHC_BUILD_FLAG_A)$/
+ || /^$(GHC_BUILD_FLAG_B)$/
|| /^$(GHC_BUILD_FLAG_2s)$/ # GC ones...
|| /^$(GHC_BUILD_FLAG_1s)$/
|| /^$(GHC_BUILD_FLAG_du)$/
) && do {
- /^-user-setup-([a-o])$/ && do { $BuildTag = "_$1"; };
+ /^-user-setup-([a-oA-Z])$/ && do { $BuildTag = "_$1"; };
/^$(GHC_BUILD_FLAG_a)$/ && do { $BuildTag = '_a'; };
/^$(GHC_BUILD_FLAG_b)$/ && do { $BuildTag = '_b'; };
/^$(GHC_BUILD_FLAG_m)$/ && do { $BuildTag = '_m'; };
/^$(GHC_BUILD_FLAG_n)$/ && do { $BuildTag = '_n'; };
/^$(GHC_BUILD_FLAG_o)$/ && do { $BuildTag = '_o'; };
+ /^$(GHC_BUILD_FLAG_A)$/ && do { $BuildTag = '_A'; };
+ /^$(GHC_BUILD_FLAG_B)$/ && do { $BuildTag = '_B'; };
/^$(GHC_BUILD_FLAG_2s)$/ && do { $BuildTag = '_2s'; };
/^$(GHC_BUILD_FLAG_1s)$/ && do { $BuildTag = '_1s'; };
#---------- Haskell compiler (hsc) -------------------------------------
# possibly resurrect LATER
-# /^-fspat-profiling$/ && do { push(@HsC_flags, '-fstg-reduction-counts');
+# /^-fspat-profiling$/ && do { push(@HsC_flags, '-fticky-ticky');
# $ProduceS = ''; $ProduceC = 1; # must use C compiler
# push(@CcBoth_flags, '-DDO_SPAT_PROFILING');
# push(@CcBoth_flags, '-fno-schedule-insns'); # not essential
local($sname) = &grab_arg_arg('-split-objs', $1);
$sname =~ s/ //g; # no spaces
- if ( $TargetPlatform =~ /^(sparc|alpha|m68k|mips|i[34]86|hppa1\.1)-/ ) {
+ if ( $TargetPlatform =~ /^(alpha|hppa1\.1|i386|m68k|mips|powerpc|sparc)-/ ) {
$SplitObjFiles = 1;
push(@HsC_flags, "-fglobalise-toplev-names$sname");
push(@CcBoth_flags, '-DUSE_SPLIT_MARKERS');
/^-fdo-monad-eta-expansion$/
&& do { $Oopt_MonadEtaExpansion = $_; next arg; };
+ /^-fno-let-from-(case|app|strict-let)$/ # experimental, really (WDP 95/10)
+ && do { push(@HsC_flags, $_); next arg; };
+
+ /^(-freturn-in-regs-threshold)(.*)$/
+ && do { local($what) = $1;
+ local($num) = &grab_arg_arg($what, $2);
+ if ($num < 2 || $num > 8) {
+ die "Bad experimental flag: $_\n";
+ } else {
+ $ProduceS = ''; $ProduceC = 1; # force using C compiler
+ push(@HsC_flags, "$what$num");
+ push(@CcRegd_flags, "-D__STG_REGS_AVAIL__=$num");
+ }
+ next arg; };
+
# /^-flambda-lift$/ # so Simon can do some testing; ToDo:rm
# && do { $Oopt_LambdaLift = $_; next arg; };
# ---------------
- /^-mlong-calls/ && do { # for GCC for HP-PA boxes
- unshift(@CcBoth_flags, ('-mlong-calls'));
+ /^-mlong-calls$/ && do { # for GCC for HP-PA boxes
+ unshift(@CcBoth_flags, ( $_ ));
+ next arg; };
+
+ /^-m(v8|sparclite|cypress|supersparc|cpu=(cypress|supersparc))$/
+ && do { # for GCC for SPARCs
+ unshift(@CcBoth_flags, ( $_ ));
next arg; };
/^-monly-([432])-regs/ && do { # for iX86 boxes only; no effect otherwise
next arg; };
/^-mtoggle-sp-mangling/ && do { # for iX86 boxes only; for RTS only
- $SpX86Mangling = 1 - $SpX86Mangling;
+ print STDERR "$Pgm: warning: -mtoggle-sp-mangling is no longer supported\n";
+# $SpX86Mangling = 1 - $SpX86Mangling;
next arg; };
#*************** ... and lots of debugging ones (form: -d* )
/^-d(dump|ppr)-/ && do { push(@HsC_flags, $_); next arg; };
/^-dverbose-(simpl|stg)/ && do { push(@HsC_flags, $_); next arg; };
/^-dsimplifier-stats/ && do { push(@HsC_flags, $_); next arg; };
+ /^-dstg-stats/ && do { $Oopt_StgStats = $_; next arg; };
#*************** ... and now all these -R* ones for its runtime system...
# in the consistency info
$DEBUGging = 'd';
next arg; };
-# OLD: do it another way
-# /^-dgc-debug$/ && do { push(@CcBoth_flags, '-D_GC_DEBUG'); next arg; };
#---------- catch unrecognized flags -----------------------------------
= ( '-fsimplify',
'\(',
"$Oopt_FB_Support",
- '-falways-float-lets-from-lets',
+# '-falways-float-lets-from-lets', # no idea why this was here (WDP 95/09)
'-ffloat-lets-exposing-whnf',
'-ffloat-primops-ok',
'-fcase-of-case',
'-fupdate-analysis',
'-flambda-lift',
$Oopt_FinalStgProfilingMassage,
+ $Oopt_StgStats,
# flags for stg2stg
'-flet-no-escape',
\begin{code}
$RegisteriseC = ( $GccAvailable
&& $RegisteriseC ne 'no' # not explicitly *un*set...
- && ($TargetPlatform =~ /^(alpha|hppa1\.1|i[34]86|m68k|mips|sparc)-/)
+ && ($TargetPlatform =~ /^(alpha|hppa1\.1|i386|m68k|mips|powerpc|sparc)-/)
) ? 'o' : '';
\end{code}
Note: a few ``always apply'' flags were set at the very beginning.
\begin{code}
-if ($TargetPlatform =~ /^m68k-/) {
+if ($TargetPlatform =~ /^alpha-/) {
+ # we know how to *mangle* asm for alpha
+ unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__'));
+ unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK;
+ unshift(@CcBoth_flags, ('-static')) if $GccAvailable;
+
+} elsif ($TargetPlatform =~ /^hppa/) {
+ # we know how to *mangle* asm for hppa
+ unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__'));
+ unshift(@CcBoth_flags, ('-static')) if $GccAvailable;
+ # We don't put in '-mlong-calls', because it's only
+ # needed for very big modules (sigh), and we don't want
+ # to hobble ourselves further on all the other modules
+ # (most of them).
+ unshift(@CcBoth_flags, ('-D_HPUX_SOURCE')) if $GccAvailable;
+ # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
+ # (very nice, but too bad the HP /usr/include files don't agree.)
+
+} elsif ($TargetPlatform =~ /^i386-/) {
+ # we know how to *mangle* asm for X86
+ unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__'));
+ unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1'))
+ if $StkChkByPageFaultOK && $TargetPlatform !~ /linux/;
+ # NB: cannot do required signal magic on Linux for such stk chks */
+
+ unshift(@CcRegd_flags, ('-m486')); # not worth not doing
+
+ # -fno-defer-pop : basically the same game as for m68k
+ #
+ # -fomit-frame-pointer : *must* ; because we're stealing
+ # the fp (%ebp) for our register maps. *All* register
+ # maps (in MachRegs.lh) must steal it.
+
+ unshift(@CcRegd_flags_hc, '-fno-defer-pop');
+ unshift(@CcRegd_flags, '-fomit-frame-pointer');
+ unshift(@CcRegd_flags, "-DSTOLEN_X86_REGS=$StolenX86Regs");
+
+ unshift(@CcBoth_flags, ('-static')) if $GccAvailable; # maybe unnecessary???
+
+} elsif ($TargetPlatform =~ /^m68k-/) {
# we know how to *mangle* asm for m68k
unshift (@CcRegd_flags, ('-D__STG_REV_TBLS__'));
unshift (@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK;
# maybe gives reg alloc a better time
# also: -fno-defer-pop is not sufficiently well-behaved without it
-} elsif ($TargetPlatform =~ /^i[34]86-/) {
- # we know how to *mangle* asm for X86
+} elsif ($TargetPlatform =~ /^powerpc-/) {
+ # we know how to *mangle* asm for PowerPC
unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__'));
unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK;
- unshift(@CcRegd_flags, ('-m486')); # not worth not doing
-
- # -fno-defer-pop : basically the same game as for m68k
- #
- # -fomit-frame-pointer : *must* ; because we're stealing
- # the fp (%ebp) for our register maps. *All* register
- # maps (in MachRegs.lh) must steal it.
-
- unshift(@CcRegd_flags_hc, '-fno-defer-pop');
- unshift(@CcRegd_flags, '-fomit-frame-pointer');
- unshift(@CcRegd_flags, "-DSTOLEN_X86_REGS=$StolenX86Regs");
- unshift(@CcRegd_flags_hc, "-DMANGLING_X86_SP=$SpX86Mangling"); # only used for checking
- # the mangler will insert patch-up code if $StolenX86Regs != 5.
- # *** HACK *** of the worst sort.
- unshift(@CcBoth_flags, ('-static')) if $GccAvailable; # maybe unnecessary???
} elsif ($TargetPlatform =~ /^sparc-/) {
# we know how to *mangle* asm for SPARC
unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__'));
unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK;
-} elsif ($TargetPlatform =~ /^alpha-/) {
- # we know how to *mangle* asm for alpha
- unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__'));
- unshift(@CcRegd_flags, ('-DSTACK_CHECK_BY_PAGE_FAULT=1')) if $StkChkByPageFaultOK;
- unshift(@CcBoth_flags, ('-static')) if $GccAvailable;
-
-} elsif ($TargetPlatform =~ /^hppa/) {
- # we know how to *mangle* asm for hppa
- unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__'));
- unshift(@CcBoth_flags, ('-static')) if $GccAvailable;
- # We don't put in '-mlong-calls', because it's only
- # needed for very big modules (sigh), and we don't want
- # to hobble ourselves further on all the other modules
- # (most of them).
- unshift(@CcBoth_flags, ('-D_HPUX_SOURCE')) if $GccAvailable;
- # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
- # (very nice, but too bad the HP /usr/include files don't agree.)
-
} elsif ($TargetPlatform =~ /^mips-/) {
# we (hope to) know how to *mangle* asm for MIPSen
unshift(@CcRegd_flags, ('-D__STG_REV_TBLS__'));
\begin{code}
unshift(@Ld_flags,
( $TargetPlatform =~ /^alpha-/
- || $TargetPlatform =~ /^mips-sgi-irix/
|| $TargetPlatform =~ /^hppa/
+ || $TargetPlatform =~ /^mips-sgi-irix/
+ || $TargetPlatform =~ /^powerpc-/
|| $TargetPlatform =~ /-solaris/
)
? ('-u', 'unsafePerformPrimIO_fast1',
'-u', 'IZh_static_info',
'-u', 'False_inregs_info',
'-u', 'True_inregs_info',
- '-u', 'CZh_static_info')
+ '-u', 'CZh_static_info',
+ '-u', 'DEBUG_REGS') # just for fun, now...
- # non-Alphas:
+ # nice friendly a.out machines...
: ('-u', '_unsafePerformPrimIO_fast1',
'-u', '_Nil_closure',
'-u', '_IZh_static_info',
'-u', '_False_inregs_info',
'-u', '_True_inregs_info',
- '-u', '_CZh_static_info')
+ '-u', '_CZh_static_info',
+ '-u', '_DEBUG_REGS')
);
\end{code}
print EXEC <<\EOSCRIPT2;
# first, some magical shortcuts to run "commands" on the binary
# (which is hidden)
-if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--(size|file|strip|rm)/ ) {
+if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {
local($cmd) = $1;
system("$cmd $pvm_executable");
exit(0); # all done
local($ddebug_flag) = ( $DEBUGging ) ? '-DDEBUG' : '';
if ($RegisteriseC) {
$cc = $CcRegd;
- $s_output = ($is_hc_file || $TargetPlatform =~ /^hppa/) ? $cc_as_o : $cc_as;
+ $s_output = ($is_hc_file || $TargetPlatform =~ /^(hppa|i386)/) ? $cc_as_o : $cc_as;
$c_flags .= " @CcRegd_flags";
$c_flags .= ($is_hc_file) ? " @CcRegd_flags_hc" : " @CcRegd_flags_c";
} else {
|| $Dump_asm_insn_counts
|| $Dump_asm_globals_info ) {
# dynamically load assembler-fiddling code, which we are about to use
- local($target) = '';
- $target = 'alpha' if $TargetPlatform =~ /^alpha-/;
- $target = 'hppa' if $TargetPlatform =~ /^hppa/;
- $target = 'iX86' if $TargetPlatform =~ /^i[34]86-/;
- $target = 'm68k' if $TargetPlatform =~ /^m68k-/;
- $target = 'mips' if $TargetPlatform =~ /^mips-/;
- $target = 'solaris' if $TargetPlatform =~ /^sparc-sun-solaris2/;
- $target = 'sparc' if $TargetPlatform =~ /^sparc-sun-sunos4/;
- $target ne ''
+ local($target) = 'oops';
+ $target = '-alpha' if $TargetPlatform =~ /^alpha-/;
+ $target = '-hppa' if $TargetPlatform =~ /^hppa/;
+ $target = '' if $TargetPlatform =~ /^i386-/;
+ $target = '-m68k' if $TargetPlatform =~ /^m68k-/;
+ $target = '-mips' if $TargetPlatform =~ /^mips-/;
+ $target = '' if $TargetPlatform =~ /^powerpc-/;
+ $target = '-solaris' if $TargetPlatform =~ /^sparc-sun-solaris2/;
+ $target = '-sparc' if $TargetPlatform =~ /^sparc-sun-sunos4/;
+
+ $target ne 'oops'
|| &tidy_up_and_die(1,"$Pgm: panic: can't decipher $TargetPlatform!\n");
- require("ghc-asm-$target.prl")
- || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-asm-$target.prl!\n");
+ require("ghc-asm$target.prl")
+ || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-asm$target.prl!\n");
}
if ( $Dump_raw_asm ) { # to stderr, before mangling
if ($is_hc_file) {
# post-process the assembler [.hc files only]
&mangle_asm($cc_as_o, $cc_as);
+
} elsif ($TargetPlatform =~ /^hppa/) {
# minor mangling of non-threaded files for hp-pa only
- require("ghc-asm-hppa.prl")
+ require('ghc-asm-hppa.prl')
|| &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-asm-hppa.prl!\n");
&mini_mangle_asm($cc_as_o, $cc_as);
+
+ } elsif ($TargetPlatform =~ /^i386/) {
+ # extremely-minor OFFENSIVE mangling of non-threaded just one file
+ require('ghc-asm.prl')
+ || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-asm.prl!\n");
+ &mini_mangle_asm($cc_as_o, $cc_as);
}
}
while ( <CCOUT> ) {
next if /attribute directive ignored/;
next if /call-clobbered/;
- next if /In file included .*stgdefs/;
- next if /from .*rtsdefs.h:/;
+ next if /from .*COptRegs\.lh/;
+ next if /from .*(stg|rts)defs\.h:/;
next if /from ghc\d+.c:\d+:/;
next if /from .*\.lc/;
next if /from .*SMinternal\.lh/;
local($SysSpecificTiming) = 'ghc';
open(STATS, $StatsFile) || die "Failed when opening $StatsFile\n";
+ local($tot_live) = 0; # for calculating avg residency
+
while (<STATS>) {
+ $tot_live += $1 if /^\s*\d+\s+\d+\s+\d+\.\d+\%\s+(\d+)\s+\d+\.\d+\%/;
+
$BytesAlloc = $1 if /^\s*([0-9,]+) bytes allocated in the heap/;
if ( /^\s*([0-9,]+) bytes maximum residency .* (\d+) sample/ ) {
}
}
close(STATS) || die "Failed when closing $StatsFile\n";
+ if ( defined($ResidencySamples) && $ResidencySamples > 0 ) {
+ $AvgResidency = int ($tot_live / $ResidencySamples) ;
+ }
# warn about what we didn't find
print STDERR "Warning: BytesAlloc not found in stats file\n" unless defined($BytesAlloc);
# things we didn't necessarily expect to find
$MaxResidency = 0 unless defined($MaxResidency);
+ $AvgResidency = 0 unless defined($AvgResidency);
$ResidencySamples = 0 unless defined($ResidencySamples);
# a bit of tidying
# print out what we found
print STDERR "<<$SysSpecificTiming: ",
- "$BytesAlloc bytes, $GCs GCs, $MaxResidency bytes residency ($ResidencySamples samples), $InitTime INIT ($InitElapsed elapsed), $MutTime MUT ($MutElapsed elapsed), $GcTime GC ($GcElapsed elapsed)",
+ "$BytesAlloc bytes, $GCs GCs, $AvgResidency/$MaxResidency avg/max bytes residency ($ResidencySamples samples), $InitTime INIT ($InitElapsed elapsed), $MutTime MUT ($MutElapsed elapsed), $GcTime GC ($GcElapsed elapsed)",
" :$SysSpecificTiming>>\n";
# OK, party over
+++ /dev/null
-%************************************************************************
-%* *
-\subsection[AgeProfile.lh]{Age Profiling Definitions for Heap and Lifetime Profiling}
-%* *
-%************************************************************************
-
-Multi-slurp protection:
-\begin{code}
-#ifndef LifeProfile_H
-#define LifeProfile_H
-\end{code}
-
-Definitions relating to the life field in fixed header:
-
-\begin{code}
-#define AGE_FIXED_HDR (AGE_HDR_SIZE)
-#define AGE_HDR_POSN AFTER_PROF_HDR
-#define AFTER_AGE_HDR (AGE_FIXED_HDR+AGE_HDR_POSN)
-\end{code}
-
-We have age header in closure if @LIFE_PROFILE@ or
-@HEAP_PROF_WITH_AGE@ defined.
-
-\begin{code}
-
-#if defined(HEAP_PROF_WITH_AGE) || defined(LIFE_PROFILE) || defined(UPDATES_ENTERED_COUNT)
-
-#define AGE_HDR_SIZE 1
-#define AGE_HDR(closure) (((P_)(closure))[AGE_HDR_POSN])
-#define SET_STATIC_AGE_HDR() ,0
-
-#if defined (HEAP_PROF_WITH_AGE) || defined(UPDATES_ENTERED_COUNT)
-#define SET_AGE_HDR(closure) AGE_HDR(closure) = 0
-#endif
-
-/* SET_AGE_HDR(closure) defined below if LIFE_PROFILE required */
-
-
-#else /* ! LIFE_PROFILE && ! HEAP_PROF_WITH_AGE && ! UPDATES_ENTERED */
-
-#define AGE_HDR_SIZE 0
-#define SET_AGE_HDR(closure)
-#define SET_STATIC_AGE_HDR()
-
-#endif /* ! LIFE_PROFILE && ! HEAP_PROF_WITH_AGE */
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[lifetime-profiling]{Declarations For Lifetime Profiling}
-%* *
-%************************************************************************
-
-The SM is responsible for:
-\begin{itemize}
-\item
-Ensuring that the \tr{HpLim} increment will be ok by ALWAYS setting \tr{HpLim}
-lower than the end of the heap (halving the free space suffices).
-\item
-If the user has requested a lifetime profile the storage manager must
-arrange for a garbage collection to occur after \tr{LifeInterval}
-words allocated (excluding age words which will be fudged with the
-\tr{HpLim} increment). Additional collections are possible with
-\tr{part_interval} being returned to indicate what is left.
-\item
-Calling \tr{life_profile_setup} and \tr{life_profile_done} during each
-garbage collection. These can be avoided if the user has not requested
-a lifetime profile.
-\item
-Calling \tr{life_profile_closure} for every closure collected during a
-garbage collection.
-\end{itemize}
-
-The RTS is responsible for:
-\begin{itemize}
-\item
-Allocating extra age word in closures.
-\item
-Initialising closure age to \tr{CurrentTime} using
-\tr{SET_AGE_HDR(closure)}. This increments the heap limit pointer to
-avoid collecting too soon as a result of distortion from the extra
-word in closures.
-\item
-Calling \tr{life_profile_init} and \tr{life_profile_finish} routines.
-\item
-Calling \tr{update_profile_closure} for every closure updated.
-\end{itemize}
-
-
-\begin{code}
-#if defined(LIFE_PROFILE)
-
-extern W_ closures_alloced;
-#define SET_AGE_HDR(closure) do { AGE_HDR(closure) = (W_)CurrentTime; \
- closures_alloced++; HpLim++; } while(0)
-
-/* When we allocate a closure we increment HpLim so that age word will
- not be included in the allocation before the next profiling interupt.
-*/
-
-
-/* start of execution -- looks for -l flag */
-extern I_ life_profile_init PROTO((StgChar *rts_argv[], StgChar *prog_argv[]));
-
-/* end of execution -- produce report if -l flag */
-extern void life_profile_finish PROTO((I_ alloc, StgChar *prog_argv[]));
-
-extern I_ do_life_prof; /* Are we liftime profiling ? */
-extern I_ CurrentTime; /* Current time (LifeIntervals) */
-extern I_ LifeInterval; /* Lifetime resolution (in words allocated) */
-
-#define DEFAULT_LIFE_INTERVAL 250 /* 1k -- report 10k */
-#define INTERVALS 100000 /* Intervals recoded */
-#define GROUPED 10 /* No of intervals grouped oin results */
-
-/* START of gc profile */
-extern void life_profile_setup(STG_NO_ARGS);
-
-/* END of gc profile -- returns next alloc interval */
-/* passed alloc since last (inc age words) and req size */
-
-extern I_ life_profile_done PROTO((I_ alloc, I_ reqsize));
-
-/* LIFE PROFILE function called for every closure collected */
-/* records info if part_interval == 0, indicating a profile reqd */
-
-extern void life_profile_closure PROTO((P_ closure, I_ size));
-
-/* UPDATE PROFILE function called for every closure updated */
-/* records info if the user requested a lifetime profiling */
-
-extern void update_profile_closure PROTO((P_ closure));
-
-#define LIFE_PROFILE_CLOSURE(closure,size) \
- STGCALL2(void,(void *, P_, I_),life_profile_closure,closure,size)
-#define UPDATE_PROFILE_CLOSURE(closure) \
- STGCALL1(void,(void *, P_),update_profile_closure,closure)
-
-#else /* ! LIFE_PROFILE */
-
-#define LIFE_PROFILE_CLOSURE(closure,size)
-#define UPDATE_PROFILE_CLOSURE(closure)
-
-#endif /* ! LIFE_PROFILE */
-\end{code}
-
-End multi-slurp protection:
-\begin{code}
-#endif /* LifeProfile_H */
-\end{code}
%************************************************************************
\begin{code}
-#if i386_TARGET_ARCH || i486_TARGET_ARCH
+#if i386_TARGET_ARCH
+
+#ifdef solaris2_TARGET_OS
+#define MINI_INTERPRET_END "miniInterpretEnd"
+#else
+#define MINI_INTERPRET_END "_miniInterpretEnd"
+#endif
/* do FUNBEGIN/END the easy way */
#define FUNBEGIN __asm__ volatile ("--- BEGIN ---");
/* The safe part of the stack frame is near the top */
-extern P_ SP_stack[];
-extern I_ SP_stack_ptr;
-
#define MINI_INTERPRETER_SETUP \
StgChar space[RESERVED_C_STACK_BYTES+4*sizeof(long)]; \
__asm__ volatile ("leal %c0(%%esp),%%eax\n" \
"\tmovl %%esi,4(%%eax)\n" \
"\tmovl %%edi,8(%%eax)\n" \
"\tmovl %%ebp,12(%%eax)\n" \
- "\tmovl %%esp,_MainRegTable+100" \
: : "n" (RESERVED_C_STACK_BYTES) \
- : "%eax"); \
- __asm__ volatile ("movl %%esp,%0" \
- : "=r" (SP_stack[++SP_stack_ptr]));
+ : "%eax");
+
+/* the initial "addl $f,%esp" in ..._END compensates for
+ the "call" (rather than a jump) in miniInterpret.
+*/
#define MINI_INTERPRETER_END \
__asm__ volatile (".align 4\n" \
- ".globl _miniInterpretEnd\n" \
- "_miniInterpretEnd:\n" \
+ ".globl " MINI_INTERPRET_END "\n" \
+ MINI_INTERPRET_END ":\n" \
"\tnop" \
: : : "memory" ); \
- __asm__ volatile ("movl %0,%%esp\n" \
- "\tmovl %%esp,_MainRegTable+100" \
- : : "m" (SP_stack[SP_stack_ptr--]) ); \
- __asm__ volatile ("leal %c0(%%esp),%%eax\n" \
+ __asm__ volatile ("addl $4,%%esp\n" \
+ "\tleal %c0(%%esp),%%eax\n" \
"\tmovl 0(%%eax),%%ebx\n" \
"\tmovl 4(%%eax),%%esi\n" \
"\tmovl 8(%%eax),%%edi\n" \
%************************************************************************
%* *
-\subsubsection[COptJumps-RS6000]{Tail-jumping on an IBM RS6000 running AIX}
+\subsubsection[COptJumps-powerpc]{Tail-jumping on an IBM PowerPC running AIX}
%* *
%************************************************************************
\begin{code}
-#if rs6000_ibm_aix_TARGET
+#if powerpc_TARGET_ARCH
-#define JMP_(cont) ((F_) (cont))()
-/* partain: untested */
+/* do FUNBEGIN/END the easy way */
+#define FUNBEGIN __asm__ volatile ("--- BEGIN ---");
+#define FUNEND __asm__ volatile ("--- END ---");
+
+/* try "m68k-style" for now */
+extern void __DISCARD__(STG_NO_ARGS);
+
+/* this is "alpha-style" */
+#define JMP_(cont) \
+ do { void *_procedure = (void *)(cont); \
+ goto *_procedure; \
+ } while(0)
+
+#define RESUME_(target) JMP_(target)
+
+/* _All_ callee-saved regs, whether we steal them or not, must be saved
+ (and restored).
+*/
+
+#define MINI_INTERPRETER_SETUP \
+ StgChar space[RESERVED_C_STACK_BYTES+6*sizeof(double)+9*sizeof(long)]; \
+ __asm__ volatile ("addu $2,$sp,%0\n" \
+ "\ts.d $f20,0($2)\n" \
+ "\ts.d $f22,8($2)\n" \
+ "\ts.d $f24,16($2)\n" \
+ "\ts.d $f26,24($2)\n" \
+ "\ts.d $f28,32($2)\n" \
+ "\ts.d $f30,40($2)\n" \
+ "\tsw $16,48($2)\n" \
+ "\tsw $17,52($2)\n" \
+ "\tsw $18,56($2)\n" \
+ "\tsw $19,60($2)\n" \
+ "\tsw $20,64($2)\n" \
+ "\tsw $21,68($2)\n" \
+ "\tsw $22,72($2)\n" \
+ "\tsw $23,76($2)\n" \
+ "\tsw $fp,80($2)\n" \
+ : : "I" (RESERVED_C_STACK_BYTES+16) : "$2" );
+
+ /* the 16 bytes is for the argument-register save-area above $sp */
+
+#define MINI_INTERPRETER_END \
+ __asm__ volatile (".align 2\n" \
+ ".globl miniInterpretEnd\n" \
+ "miniInterpretEnd:\n" \
+ "\taddu $2,$sp,%0\n" \
+ "\tl.d $f20,0($2)\n" \
+ "\tl.d $f22,8($2)\n" \
+ "\tl.d $f24,16($2)\n" \
+ "\tl.d $f26,24($2)\n" \
+ "\tl.d $f28,32($2)\n" \
+ "\tl.d $f30,40($2)\n" \
+ "\tlw $16,48($2)\n" \
+ "\tlw $17,52($2)\n" \
+ "\tlw $18,56($2)\n" \
+ "\tlw $19,60($2)\n" \
+ "\tlw $20,64($2)\n" \
+ "\tlw $21,68($2)\n" \
+ "\tlw $22,72($2)\n" \
+ "\tlw $23,76($2)\n" \
+ "\tlw $fp,80($2)\n" \
+ : : "I" (RESERVED_C_STACK_BYTES+16) : "$2" );
-#endif /* rs6000-ibm-aix* */
+#endif /* powerpc */
\end{code}
%************************************************************************
P_ rHpLim;
I_ rTag;
StgRetAddr rRet;
- I_ rActivity;
+ I_ rActivity; /* NB: UNUSED */
P_ rCstkptr; /* used for iX86 registerizing only! offset=100 */
P_ rWrapReturn; /* ditto; offset=104 */
P_ rSaveECX; /* ditto; offset=108 */
#define MAIN_Dbl1 (MainRegTable.rDbl[0])
#define MAIN_Dbl2 (MainRegTable.rDbl[1])
+#define MAIN_Hp (MainRegTable.rHp)
+#define MAIN_HpLim (MainRegTable.rHpLim)
#define MAIN_Tag (MainRegTable.rTag)
#define MAIN_Ret (MainRegTable.rRet)
-#define MAIN_Activity (MainRegTable.rActivity)
#define MAIN_StkO (MainStkO)
#define MAIN_Liveness (MainRegTable.rLiveness)
#define SAVE_Tag MAIN_Tag
#define SAVE_Ret MAIN_Ret
-#define SAVE_Activity MAIN_Activity
#else
#define SAVE_Tag (CurrentRegTable->rTag)
#define SAVE_Ret (CurrentRegTable->rRet)
-#define SAVE_Activity (CurrentRegTable->rActivity)
#define SAVE_StkO (CurrentRegTable->rStkO)
#define SAVE_Liveness (CurrentRegTable->rLiveness)
Liveness (CONCURRENT)
-Activity g5 (DO_SPAT_PROFILING)
-
StdUpdRetVec#
StkStub# i7 $23
\end{verbatim}
#define RTBL_HpLim (BaseReg->rHpLim)
#define RTBL_Tag (BaseReg->rTag)
#define RTBL_Ret (BaseReg->rRet)
-#define RTBL_Activity (BaseReg->rActivity)
#define RTBL_StkO (BaseReg->rStkO)
#define RTBL_Liveness (BaseReg->rLiveness)
#define StkOReg RTBL_StkO
#endif
+#ifndef __STG_REGS_AVAIL__ /* driver ensures it is 2 or more */
+# define __STG_REGS_AVAIL__ 8 /* R1 to R8 */
+/* this would only be non-8 if doing weird experiments (WDP 95/11) */
+/* or it might be set lower for a particular arch... */
+#endif
+
/* R1 is used for Node */
#ifdef REG_R1
GLOBAL_REG_DECL(StgUnion,R1,REG_R1)
#ifdef REG_R3
GLOBAL_REG_DECL(StgUnion,R3,REG_R3)
#else
-#define R3 RTBL_R3
+# define R3 RTBL_R3
#endif
#ifdef REG_R4
GLOBAL_REG_DECL(StgUnion,R4,REG_R4)
#else
-#define R4 RTBL_R4
+# define R4 RTBL_R4
#endif
#ifdef REG_R5
GLOBAL_REG_DECL(StgUnion,R5,REG_R5)
#else
-#define R5 RTBL_R5
+# define R5 RTBL_R5
#endif
#ifdef REG_R6
GLOBAL_REG_DECL(StgUnion,R6,REG_R6)
#else
-#define R6 RTBL_R6
+# define R6 RTBL_R6
#endif
#ifdef REG_R7
GLOBAL_REG_DECL(StgUnion,R7,REG_R7)
#else
-#define R7 RTBL_R7
+# define R7 RTBL_R7
#endif
#ifdef REG_R8
GLOBAL_REG_DECL(StgUnion,R8,REG_R8)
#else
-#define R8 RTBL_R8
+# define R8 RTBL_R8
#endif
#ifdef REG_Flt1
#define LivenessReg RTBL_Liveness
#endif
-#ifdef REG_Activity
-GLOBAL_REG_DECL(I_,ActivityReg,REG_Activity)
-#else
-#define ActivityReg RTBL_Activity
-#endif
-
#ifdef REG_StdUpdRetVec
GLOBAL_REG_DECL(D_,StdUpdRetVecReg,REG_StdUpdRetVec)
#else
#define CALLER_RESTORE_Liveness /* nothing */
#endif
-#ifdef CALLER_SAVES_Activity
-#define CALLER_SAVE_Activity SAVE_Activity = ActivityReg;
-#define CALLER_RESTORE_Activity ActivityReg = SAVE_Activity;
-#else
-#define CALLER_SAVE_Activity /* nothing */
-#define CALLER_RESTORE_Activity /* nothing */
-#endif
-
#ifdef CALLER_SAVES_Base
#ifndef CONCURRENT
#define CALLER_SAVE_Base /* nothing, ever (it holds a fixed value) */
-#define CALLER_RESTORE_Base BaseReg = MainRegTable;
+#define CALLER_RESTORE_Base BaseReg = &MainRegTable;
#else
#define CALLER_SAVE_Base /* nothing */
#define CALLER_RESTORE_Base BaseReg = CurrentRegTable;
Call wrappers need to be able to call arbitrary functions, regardless of
their arguments and return types. (Okay, we actually only allow up to
-five arguments, because on the sparc it gets more complicated to handle
+five arguments, because on the SPARC it gets more complicated to handle
any more.) The nasty bit is that the return value can be in either an
integer register or a floating point register, and we don't know which.
(We {\em don't} handle structure returns, and we don't want to.)
results, and @MAGIC_RETURN@, which collects all possible results back
up again.
-For example, in the sparc version, the @SETUP@ guarantees that we
+For example, in the SPARC version, the @SETUP@ guarantees that we
have enough space to store all of our argument registers for a wee
bit, and it gives a `C' name to the register that we're going to use
for the call. (It helps to do the call in actual `C' fashion, so that
#if defined(__GNUC__) && defined(__STG_GCC_REGS__)
-#if alpha_dec_osf1_TARGET
- /* Is this too specific */
+#if alpha_TARGET_ARCH
#define MAGIC_CALL_SETUP \
long WeNeedThisSpace[7]; \
#define SET_RETADDR(loc) { register StgFunPtrFunPtr ra __asm__ ("$26"); loc = ra; }
-#define WRAPPER_SETUP(f) SaveAllStgContext();
+#define WRAPPER_SETUP(f,ignore1,ignore2) SaveAllStgContext();
#define WRAPPER_RETURN(x) \
do {RestoreAllStgRegs(); if(x) JMP_(EnterNodeCode);} while(0);
\begin{code}
-#if hppa1_1_hp_hpux_TARGET
- /* Is this too specific */
+#if hppa1_1_TARGET_ARCH
#define MAGIC_CALL_SETUP \
long SavedIntArgRegs[4]; \
#define SET_RETADDR(loc) __asm__ volatile ("stw %%r2, %0" : "=m" ((void *)(loc)));
-#define WRAPPER_SETUP(f) SaveAllStgContext();
+#define WRAPPER_SETUP(f,ignore1,ignore2) SaveAllStgContext();
#define WRAPPER_RETURN(x) \
do {RestoreAllStgRegs(); if(x) JMP_(EnterNodeCode);} while(0);
%************************************************************************
\begin{code}
-
-#if i386_TARGET_ARCH || i486_TARGET_ARCH
+#if i386_TARGET_ARCH
/* modelled loosely on SPARC stuff */
/* NB: no MAGIC_CALL_SETUP, MAGIC_CALL, or MAGIC_RETURN! */
-#define WRAPPER_NAME(f) __asm__("L" #f "_wrapper")
+#define WRAPPER_NAME(f) /*nothing*/
+#ifdef solaris2_TARGET_OS
+#define REAL_NAME(f) #f
+#else
#define REAL_NAME(f) "_" #f
+#endif
-/* when we come into PerformGC_wrapper:
+/*
+ Threaded code needs to be able to grab the return address, in case we have
+ an intervening context switch.
+ */
- - %esp holds Hp (!); get it into 80(%ebx) -- quick!
+#define SET_RETADDR(loc,val) loc = val;
- - %esp needs to be bumped by (at least) 4, because
- C thinks an argument was passed on the stack
- (use 64 just for fun)
+/* the grab-%eax-quickly HACK is here because we use a VERY SPECIAL
+ calling convention on iX86 just for calling PerformGC_wrapper.
+ (WDP 95/09)
- - %eax holds the argument for PerformGC
+ NB: mangler makes sure that __temp_{eax,esp} get loaded.
+ (This is about as ugly as it can get.)
+*/
- - 104(%ebx) hold the return address -- address we want to
- go back to
+#define WRAPPER_SETUP(f,ret_addr,args) \
+ __asm__ volatile ( \
+ "movl " REAL_NAME(__temp_esp) ",%%edx\n" \
+ "\tmovl (%%edx),%0\n" \
+ "\tmovl " REAL_NAME(__temp_eax) ",%1" \
+ : "=r" (ret_addr), "=r" (args) ); \
+ SaveAllStgContext(ret_addr);
- - 100(%ebx) holds a %esp value that we can re-load with
- if need be
+/* Note re WRAPPER_SETUP: we have special code just for PerformGC_wrapper;
+ pls see its definition. WDP 95/09
+ Also note the EXTREMELY UGLY slamming in of an "sp_offset"; the
+ return address *is* on the stack, but it is hard to get there
+ before GCC has moved the sp pointer... WDP 95/11
*/
-#define WRAPPER_SETUP(f) \
- __asm__ volatile ( \
- ".globl " REAL_NAME(f) "_wrapper\n" \
- REAL_NAME(f) "_wrapper:\n" \
- "\tmovl %%esp,80(%%ebx)\n" \
- "\tmovl 100(%%ebx),%%esp\n" \
- "\tmovl %%eax,%0\n" \
- "\tincl _SP_stack_ptr\n" \
- "\tmovl _SP_stack_ptr,%%eax\n" \
- "\tmovl %%esp,_SP_stack(,%%eax,4)\n" \
- "\tsubl $64,%%esp" \
- : "=r" (args)); \
- SaveAllStgContext();
-
-#define WRAPPER_RETURN(x) \
- do {P_ foo; \
- RestoreAllStgRegs(); \
- if(x) JMP_(EnterNodeCode); /* never used? */ \
- __asm__ volatile ( \
- "movl %1,%0\n" \
- "\tmovl %0,_MainRegTable+100" \
- : "=r" (foo) : "m" (SP_stack[SP_stack_ptr--]) ); \
- __asm__ volatile ( \
- "movl 80(%ebx),%esp\n" \
- "\tjmp *104(%ebx)" ); \
- } while(0);
+
+#define WRAPPER_RETURN(x) \
+ do {RestoreAllStgRegs(); if(x) JMP_(EnterNodeCode);} while(0);
#define SEPARATE_WRAPPER_RESTORE /* none */
#endif /* iX86 */
-
\end{code}
%************************************************************************
#define WRAPPER_NAME(f) /* nothing */
-#define WRAPPER_SETUP(f) SaveAllStgContext();
+#define WRAPPER_SETUP(f,ignore1,ignore2) SaveAllStgContext();
#define WRAPPER_RETURN(x) \
do {RestoreAllStgRegs(); if(x) JMP_(EnterNodeCode);} while(0);
#define WRAPPER_NAME(f) /* nothing */
-#define WRAPPER_SETUP(f) SaveAllStgContext();
+#define WRAPPER_SETUP(f,ignore1,ignore2) SaveAllStgContext();
#define WRAPPER_RETURN(x) \
do {RestoreAllStgRegs(); if(x) JMP_(EnterNodeCode);} while(0);
%************************************************************************
%* *
+\subsubsection[powerpc-magic]{Call-wrapper MAGIC for PowerPC}
+%* *
+%************************************************************************
+
+\begin{code}
+#if powerpc_TARGET_ARCH
+
+/* shift 4 arg registers down one */
+
+#define MAGIC_CALL_SETUP \
+ register void (*f)() __asm__("$2"); \
+ __asm__ volatile ( \
+ "move $2,$4\n" \
+ "\tmove $4,$5\n" \
+ "\tmove $5,$6\n" \
+ "\tmove $6,$7\n" \
+ "\tlw $7,16($sp)\n" \
+ "\taddu $sp,$sp,4\n" \
+ : : : "$2" );
+
+#define MAGIC_CALL \
+ (*f)(); \
+ __asm__ volatile ( \
+ "subu $sp,$sp,4\n" \
+ "\ts.d $f0, -8($sp)\n" \
+ "\tsw $2, -12($sp)");
+
+#define MAGIC_RETURN \
+ __asm__ volatile ( \
+ "l.d $f0, -8($sp)\n" \
+ "\tlw $2, -12($sp)");
+
+#define WRAPPER_NAME(f) /* nothing */
+
+#define WRAPPER_SETUP(f,ignore1,ignore2) SaveAllStgContext();
+
+#define WRAPPER_RETURN(x) \
+ do {RestoreAllStgRegs(); if(x) JMP_(EnterNodeCode);} while(0);
+
+#define SEPARATE_WRAPPER_RESTORE /* none */
+
+#endif /* powerpc */
+\end{code}
+
+%************************************************************************
+%* *
\subsubsection[sparc-magic]{Call-wrapper MAGIC for SPARC}
%* *
%************************************************************************
"\tldd [%fp-32],%i0");
/*
- We rename the entry points for wrappers so that we can
- introduce a new entry point after the prologue. We want to ensure
- that the register window does not slide! However, we insert a
- call to abort() to make gcc _believe_ that the window slid.
+ We rename the entry points for wrappers so that we can introduce a
+ new entry point after the prologue. We want to ensure that the
+ register window does not slide! However, we insert a call to
+ abort() to make gcc _believe_ that the window slid.
*/
#define WRAPPER_NAME(f) __asm__("L" #f "_wrapper")
#define REAL_NAME(f) "_" #f
#endif
-#define WRAPPER_SETUP(f) \
+#define WRAPPER_SETUP(f,ignore1,ignore2) \
__asm__ volatile ( \
".global " REAL_NAME(f) "_wrapper\n"\
REAL_NAME(f) "_wrapper:\n" \
"\tmov %i0,%o0\n" \
"\tmov %i1,%o1");
/*
- * In the above, we want to ensure that the arguments are both in the %i registers
- * and the %o registers, with the assumption that gcc will expect them now to be in
- * one or the other. This is a terrible hack.
+ * In the above, we want to ensure that the arguments are both in the
+ * %i registers and the %o registers, with the assumption that gcc
+ * will expect them now to be in one or the other. This is a terrible
+ * hack.
*/
/*
- Threaded code needs to be able to grab the return address, in case we have
- an intervening context switch. Note that we want the address of the next
- instruction to be executed, so we add 8 to the link address.
+ Threaded code needs to be able to grab the return address, in case
+ we have an intervening context switch. Note that we want the
+ address of the next instruction to be executed, so we add 8 to the
+ link address.
*/
#define SET_RETADDR(loc) \
fields in closures.
\begin{code}
-#if defined(USE_COST_CENTRES) || defined(CONCURRENT)
+#if defined(PROFILING) || defined(CONCURRENT)
# define CC_EXTERN(cc_ident) \
extern struct cc CAT2(cc_ident,_struct); \
CC_EXTERN(CC_MAIN); /* initial MAIN cost centre */
CC_EXTERN(CC_GC); /* Garbage Collection cost center */
-# ifdef GUM
+# ifdef PAR
CC_EXTERN(CC_MSG); /* Communications cost center */
CC_EXTERN(CC_IDLE); /* Idle-time cost centre */
# endif
subsumed, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}; \
is_local CostCentre cc_ident = STATIC_CC_REF(cc_ident)
-#endif /* defined(USE_COST_CENTRES) || defined(CONCURRENT) */
+#endif /* defined(PROFILING) || defined(CONCURRENT) */
\end{code}
Definitions relating to the profiling field as a whole.
%************************************************************************
The cost-centre profiling is only on if the driver turns on
-@USE_COST_CENTRES@.
+@PROFILING@.
These are the {\em dummy} definitions in force if we do {\em NOT}
-turn on @USE_COST_CENTRES@. Get them out of the way....
+turn on @PROFILING@. Get them out of the way....
\begin{code}
-#if !defined(USE_COST_CENTRES)
+#if !defined(PROFILING)
/*** Declaration Definitions ***/
# define CC_ALLOC(cc, size, kind)
# define HEAP_PROFILE_CLOSURE(closure,size)
-# ifndef GUM
+# ifndef PAR
# define START_TIME_PROFILER
# define RESTART_TIME_PROFILER
# define STOP_TIME_PROFILER
# endif
-#endif /* !defined(USE_COST_CENTRES) */
+#endif /* !defined(PROFILING) */
\end{code}
%************************************************************************
closures. This is adjacent to the info pointer.
\begin{code}
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
CC_EXTERN(CC_SUBSUMED); /* top level fns SUBSUMED cost centre */
CC_EXTERN(CC_OVERHEAD); /* costs due only to profiling machinery */
# define ENTER_CC_PAP_CL(closure) \
ENTER_CC_PAP(CC_HDR(closure))
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING */
\end{code}
%************************************************************************
the register stack.
\begin{code}
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
extern F_ _regMain (STG_NO_ARGS);
extern F_ *register_stack;
# define POP_REGISTER_STACK \
*(--register_stack)
-extern I_ SM_trace;
-
# define START_REGISTER_CCS(reg_mod_name) \
static int _module_registered = 0; \
STGFUN(reg_mod_name) { \
} while(0); \
FUNEND; }
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING */
\end{code}
We don't want to attribute costs to an unregistered cost-centre:
\begin{code}
-#if !defined(USE_COST_CENTRES) || !defined(DEBUG)
+#if !defined(PROFILING) || !defined(DEBUG)
# define ASSERT_IS_REGISTERED(cc,chk_not_overhead) /*nothing*/
#else
# define ASSERT_IS_REGISTERED(cc,chk_not_overhead) \
@INTERNAL_KIND@.
\begin{code}
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
# define CON_K 1
# define FN_K 2
# define CAT_DECLARE(base_name, kind, descr, type) \
static struct ClCat MK_CAT_IDENT(base_name) = {UNHASHED,-1,kind,descr,type};
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING */
\end{code}
%************************************************************************
Stuff to do with timer signals:
\begin{code}
-#if defined(USE_COST_CENTRES) || defined(GUM)
+#if defined(PROFILING) || defined(PAR)
extern I_ time_profiling; /* Flag indicating if timer/serial profiling is required */
# define TICK_FREQUENCY 50 /* ticks per second */
# define TICK_MILLISECS (1000/TICK_FREQUENCY) /* milli-seconds per tick */
-# ifdef CONCURRENT
-extern I_ profilerTicks;
-extern I_ tick_millisecs;
-# endif
-
# define DEFAULT_INTERVAL TICK_FREQUENCY /* 1 second */
/* These are never called directly from threaded code */
# define RESTART_TIME_PROFILER ULTRASAFESTGCALL0(void,(void *),restart_time_profiler) /*R StgOverflow.lc */
# define STOP_TIME_PROFILER ULTRASAFESTGCALL0(void,(void *),stop_time_profiler) /*R StgOverflow.lc */
-# if defined(USE_COST_CENTRES)
+# if defined(PROFILING)
# define OR_INTERVAL_EXPIRED || (interval_expired) /*R StgMacros.h */
# endif
\end{code}
value(s).
\begin{code}
-# if defined(USE_COST_CENTRES)
+# if defined(PROFILING)
# define DEFAULT_MAX_CC 4096
# define DEFAULT_MAX_MOD 256
extern hash_t init_index_type(STG_NO_ARGS);
extern hash_t index_type PROTO((ClCategory clcat));
-# endif /* USE_COST_CENTRES */
+# endif /* PROFILING */
\end{code}
centre->time_ticks += 1; \
} while(0)
-# if defined(USE_COST_CENTRES)
+# if defined(PROFILING)
# define CC_ALLOC(cc, size, kind) \
do { CostCentre cc_ = (CostCentre) (cc); \
ASSERT_IS_REGISTERED(cc_,0/*OK if OVERHEAD*/); \
cc_->mem_allocs += 1; \
- cc_->mem_alloc += (size) - (PROF_FIXED_HDR + AGE_FIXED_HDR); \
+ cc_->mem_alloc += (size) - (PROF_FIXED_HDR + TICKY_FIXED_HDR); \
} while(0) /* beware name-capture by ASSERT_IS...! */
# endif
\end{code}
%************************************************************************
\begin{code}
-extern I_ cc_profiling; /* Are we performing/reporting cc profiling? */
-extern I_ heap_profiling_reqd; /* Are we performing heap profiling? */
+I_ init_cc_profiling PROTO((I_ rts_argc, char *rts_argv[], char *prog_argv[]));
+void report_cc_profiling PROTO((I_ final));
-# define SORTCC_LABEL 'C'
-# define SORTCC_TIME 'T'
-# define SORTCC_ALLOC 'A'
-extern char cc_profiling_sort; /* How to sort cost centre report */
-
-extern I_ init_cc_profiling PROTO((I_ rts_argc, char *rts_argv[], char *prog_argv[]));
-extern void report_cc_profiling PROTO((I_ final));
-
-extern void cc_register(STG_NO_ARGS);
-extern void cc_sort PROTO((CostCentre *sort, char sort_on));
+void cc_register(STG_NO_ARGS);
+void cc_sort PROTO((CostCentre *sort, char sort_on));
+rtsBool cc_to_ignore PROTO((CostCentre));
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-# define HEAP_NO_PROFILING 0 /* N.B. Used as indexes into arrays */
-
-# if defined(USE_COST_CENTRES)
-
-# define HEAP_BY_CC 1
-# define HEAP_BY_MOD 2
-# define HEAP_BY_GRP 3
-# define HEAP_BY_DESCR 4
-# define HEAP_BY_TYPE 5
-# define HEAP_BY_TIME 6
-
-# define CCchar 'C'
-# define MODchar 'M'
-# define GRPchar 'G'
-# define DESCRchar 'D'
-# define TYPEchar 'Y'
-# define TIMEchar 'T'
-
-extern I_ heap_profile_init PROTO((I_ prof,
- char *select_cc_str,
+# if defined(PROFILING)
+
+extern I_ heap_profile_init PROTO((char *select_cc_str,
char *select_mod_str,
char *select_grp_str,
char *select_descr_str,
char *select_typ_str,
char *select_kind_str,
- I_ select_age,
char *argv[]));
extern void heap_profile_finish(STG_NO_ARGS);
# define HEAP_PROFILE_CLOSURE(closure,size) \
STGCALL2(void,(void *, P_, I_),(*heap_profile_fn),closure,size) /*R SM2s.lh */
-# endif /* USE_COST_CENTRES */
+# endif /* PROFILING */
\end{code}
End multi-slurp protection:
\begin{code}
-#endif /* USE_COST_CENTRES || GUM */
+#endif /* PROFILING || PAR */
#endif /* CostCentre_H */
\end{code}
+++ /dev/null
-%************************************************************************
-%* *
-\subsection[Force_GC.lh]{}
-%* *
-%************************************************************************
-
-Multi-slurp protection:
-\begin{code}
-#ifndef Force_GC_H
-#define Force_GC_H
-
-#ifdef FORCE_GC
-extern I_ force_GC; /* Are we forcing GC ? */
-extern I_ GCInterval; /* GC resolution (in words allocated) */
-extern I_ alloc_since_last_major_GC; /* words allocated since last major GC */
-
-#define DEFAULT_GC_INTERVAL 5000000
-
-#endif /* FORCE_GC */
-\end{code}
-
-End multi-slurp protection:
-\begin{code}
-#endif /* ! Force_GC_H */
-\end{code}
%************************************************************************
%* *
-\subsection[string-size]{Maximum size of cost centre and description strings}
-%* *
-%************************************************************************
-
-This is the maximum identifier length that can be used for a cost
-centre or description string. It includes the terminating null
-character.
-
-WDP 95/07: I think this STRING_SIZE thing is completely redundant.
-
-The printf formats are here, so we are less likely to make overly-long
-filenames (with disastrous results). No more than 128 chars, please!
-
-\begin{code}
-#define STRING_SIZE 128
-
-#define STATS_FILENAME_MAXLEN 128
-
-#define GR_FILENAME_FMT "%0.124s.gr"
-#define GR_FILENAME_FMT_GUM "%0.120s.%03d.gr"
-#define HP_FILENAME_FMT "%0.124s.hp"
-#define LIFE_FILENAME_FMT "%0.122s.life"
-#define PROF_FILENAME_FMT "%0.122s.prof"
-#define PROF_FILENAME_FMT_GUM "%0.118s.%03d.prof"
-#define QP_FILENAME_FMT "%0.124s.qp"
-#define STAT_FILENAME_FMT "%0.122s.stat"
-#define TICKY_FILENAME_FMT "%0.121s.ticky"
-#define TIME_FILENAME_FMT "%0.122s.time"
-#define TIME_FILENAME_FMT_GUM "%0.118s.%03d.time"
-\end{code}
-
-%************************************************************************
-%* *
\subsection[update-frame-size]{Update frame size}
%* *
%************************************************************************
If we are compiling C code the use of cost centres is determined at
compile time so we use conditional macro definitions.
\begin{code}
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
#define STD_UF_SIZE SCC_STD_UF_SIZE
#define CON_UF_SIZE SCC_CON_UF_SIZE
#else
Tags for indirection nodes and ``other'' (probably unevaluated) nodes;
normal-form values of algebraic data types will have tags 0, 1, ...
+@INFO_IND_TAG@ is different from @INFO_OTHER_TAG@ just so we can count
+how often we bang into indirection nodes; that's all. (WDP 95/11)
+
\begin{code}
#define INFO_OTHER_TAG (-1)
-#define INFO_IND_TAG (-1)
+#define INFO_IND_TAG (-2)
#define INFO_FIRST_TAG 0
\end{code}
LH_FILES = \
-rtsTypes.lh /* runtime system */ \
+RtsTypes.lh /* runtime system */ \
+RtsFlags.lh \
\
SMinterface.lh /* storage-management related */ \
SMClosures.lh \
\
GhcConstants.lh \
\
-RednCounts.lh /* "ticky-ticky" profiling */ \
+Ticky.lh /* "ticky-ticky" profiling */ \
\
Info.lh /* Info pointer definitions */ \
\
CostCentre.lh /* for cost centre profiling */ \
-AgeProfile.lh /* age stuff for heap and lifetime profiling */ \
-Force_GC.lh /* for forcing GC */ \
\
GranSim.lh \
Parallel.lh /* for PAR build */ \
hence they get trashed across ccalls and are caller saves. \tr{%ebx},
\tr{%esi}, \tr{%edi}, \tr{%ebp} are all callee-saves.
-We only steal \tr{%ebx} for base registers. SIGH. SimonM also took
-\tr{%esi} for SpA and \tr{%edi} for SpB. Maybe later.
-
\begin{code}
#if i386_TARGET_ARCH
#define REG_Scav ebx
#define REG_ToHp ebp
#if defined(GCap) || defined(GCgn)
+/* NO: -concurrent croaks on SMevac.lc with this
#define REG_OldGen esi
+*/
#endif /* GCap || GCgn */
#else /* default: MAIN_REG_MAP */
- give back ebp
*/
-/* SpB and R1 are the two heaviest hitters, followed by SpA */
+/* SpB and R1 are the two heaviest hitters, followed by SpA.
+ Hp comes next, followed closely by R2;
+ then RetReg, then R3 and R4.
+ At least based on some static counts.
+ SIGH. WDP 95/09
+*/
#define REG_Base ebx
#define REG_SpB ebp
#if STOLEN_X86_REGS >= 3
# define REG_SpA edi
# define CALLEE_SAVES_SpA
#endif
-/* the mangler will put Hp in %esp!!! */
-#if defined(MANGLING_X86_SP) && MANGLING_X86_SP == 0
-Oops! You should not be here if not mangling %esp!
-#endif
#if STOLEN_X86_REGS >= 5
-# define REG_R2 ecx
-# define CALLER_SAVES_R2
+/*
+# define REG_Hp ecx
+# define CALLER_SAVES_Hp
+# define CALLER_SAVES_SYSTEM
+*/
+/* because we *might* have Hp in a caller-saves register */
#endif
+
#endif /* SCAV_REG_MAP */
#endif /* SCAN_REG_MAP */
#endif /* MARK_REG_MAP */
%************************************************************************
%* *
-\subsubsection[mapping-rs6000]{The IBM RS6000 register mapping}
+\subsubsection[mapping-powerpc]{The PowerPC register mapping}
%* *
%************************************************************************
I think we can do the Whole Business with callee-save registers only!
-UTTERLY UNTESTED
-
\begin{code}
-#if rs6000_TARGET_ARCH
-
-#define REG_Base ????
-#define REG_R1
-#define REG_SpA
-#define REG_SpB
-#define REG_Hp
-
-#define REG_Flt1
-#define REG_Flt2
-#define REG_Flt3
-#define REG_Flt4
-#define REG_Dbl1
-#define REG_Dbl2
-
-#endif /* rs6000 */
+#if powerpc_TARGET_ARCH
+
+#define REG(x) __asm__("%" #x)
+
+#if defined(MARK_REG_MAP)
+#define REG_Mark r13
+#define REG_MStack r14
+#define REG_MRoot r15
+#define REG_BitArray r16
+#define REG_HeapBase r17
+#define REG_HeapLim r18
+#else
+#if defined(SCAN_REG_MAP)
+#define REG_Scan r13
+#define REG_New r14
+#define REG_LinkLim r15
+#else
+#if defined(SCAV_REG_MAP)
+#define REG_Scav r13
+#define REG_ToHp r14
+#if defined(GCap) || defined(GCgn)
+#define REG_OldGen r15
+#endif /* GCap || GCgn */
+#else /* default: MAIN_REG_MAP */
+
+/* callee saves */
+#define CALLEE_SAVES_FltReg1
+#define CALLEE_SAVES_FltReg2
+#define CALLEE_SAVES_FltReg3
+#define CALLEE_SAVES_FltReg4
+#define CALLEE_SAVES_DblReg1
+#define CALLEE_SAVES_DblReg2
+#define CALLEE_SAVES_SpA
+#define CALLEE_SAVES_SuA
+#define CALLEE_SAVES_SpB
+#define CALLEE_SAVES_SuB
+#define CALLEE_SAVES_Hp
+#define CALLEE_SAVES_HpLim
+
+#define CALLEE_SAVES_Ret
+
+#define CALLEE_SAVES_R1
+#define CALLEE_SAVES_R2
+#define CALLEE_SAVES_R3
+#define CALLEE_SAVES_R4
+#define CALLEE_SAVES_R5
+#define CALLEE_SAVES_R6
+#define CALLEE_SAVES_R7
+#define CALLEE_SAVES_R8
+
+#define REG_R1 r13
+#define REG_R2 r14
+#define REG_R3 r15
+#define REG_R4 r16
+#define REG_R5 r17
+#define REG_R6 r18
+#define REG_R7 r19
+#define REG_R8 r20
+
+#define REG_Flt1 fr14
+#define REG_Flt2 fr15
+#define REG_Flt3 fr16
+#define REG_Flt4 fr17
+
+#define REG_Dbl1 fr18
+#define REG_Dbl2 fr19
+
+#define REG_SpA r21
+#define REG_SuA r22
+#define REG_SpB r23
+#define REG_SuB r24
+
+#define REG_Hp r25
+#define REG_HpLim r26
+
+#define REG_Ret r27
+
+#define REG_StkStub r28
+
+#endif /* SCAV_REG_MAP */
+#endif /* SCAN_REG_MAP */
+#endif /* MARK_REG_MAP */
+
+#endif /* powerpc */
\end{code}
%************************************************************************
#else
#if defined(SCAN_REG_MAP)
#define REG_ScanBase g4
+/* NB: *not* defining this (so that everything is done w/ global variables)
+ does *not* work; I suspect that the Sca[nv]RegTable is not being
+ initialised somewhere... WDP 95/10
+*/
#else
#if defined(SCAV_REG_MAP)
#define REG_ScavBase g4
+/* see comment above */
#else /* default: MAIN_REG_MAP */
/* callee saves (nothing) */
-/* caller saves (fp registers and maybe Activity) */
-
-#if defined(DO_SPAT_PROFILING)
-#define CALLER_SAVES_SYSTEM
-#define CALLER_SAVES_Activity
-#endif
+/* caller saves (fp registers) */
#define CALLER_SAVES_USER
#define REG_Dbl1 f6
#define REG_Dbl2 f8
-#if defined(DO_SPAT_PROFILING)
-#define REG_Activity g5
-#endif
-
#define REG_SpA i0
#define REG_SuA i1
#define REG_SpB i2
\begin{code}
# ifdef PAR
-# define MAX_PES 128 /* Maximum number of processors */
+# define MAX_PES 256 /* Maximum number of processors */
+ /* MAX_PES is enforced by SysMan, which does not
+ allow more than this many "processors".
+ This is important because PackGA [GlobAddr.lc]
+ **assumes** that a PE# can fit in 8+ bits.
+ */
-extern I_ do_gr_profile;
extern I_ do_sp_profile;
-extern I_ do_gr_binary;
extern P_ PendingFetches;
extern GLOBAL_TASK_ID *PEs;
# define MAX_GA_WEIGHT 0 /* Treat as 2^n */
-# define PACK_GA(pe,slot) ((((W_)(pe)) << (BITS_IN(W_)/2)) | ((W_)(slot)))
-
+W_ PackGA PROTO((W_, int));
+ /* There was a PACK_GA macro here; but we turned it into the PackGA
+ routine [GlobAddr.lc] (because it needs to do quite a bit of
+ paranoia checking. Phil & Will (95/08)
+ */
\end{code}
At the moment, there is no activity profiling for GUM. This may change.
packet in the parallel (GUM) system.
\begin{code}
-# ifdef GUM
+# ifdef PAR
+void InitPackBuffer(STG_NO_ARGS);
P_ PackNearbyGraph PROTO((P_ closure,W_ *size));
P_ PackTSO PROTO((P_ tso, W_ *size));
P_ PackStkO PROTO((P_ stko, W_ *size));
P_ UnpackGraph PROTO((W_ *buffer, globalAddr **gamap, W_ *nGAs));
# endif
-# define PACK_BUFFER_SIZE 1024
-# define PACK_HEAP_REQUIRED \
- ((PACK_BUFFER_SIZE - PACK_HDR_SIZE) / (PACK_GA_SIZE + _FHS) * (SPEC_HS + 2))
-
\end{code}
\begin{code}
+# define PACK_HEAP_REQUIRED \
+ ((RTSflags.ParFlags.packBufferSize - PACK_HDR_SIZE) / (PACK_GA_SIZE + _FHS) * (SPEC_HS + 2))
+
+extern W_ *PackBuffer; /* size: can be set via option */
+extern long *buffer; /* HWL_ */
+extern W_ *freeBuffer; /* HWL_ */
+extern W_ *packBuffer; /* HWL_ */
+
+extern void InitPackBuffer(STG_NO_ARGS);
+extern void InitMoreBuffers(STG_NO_ARGS);
+extern void InitPendingGABuffer(W_ size);
+extern void AllocClosureQueue(W_ size);
+
+# define MAX_GAS (RTSflags.ParFlags.packBufferSize / PACK_GA_SIZE)
+
+
# define PACK_GA_SIZE 3 /* Size of a packed GA in words */
/* Size of a packed fetch-me in words */
# define PACK_FETCHME_SIZE (PACK_GA_SIZE + FIXED_HS)
# define PACK_PLC_SIZE 2 /* Size of a packed PLC in words */
-# define MAX_GAS (PACK_BUFFER_SIZE / PACK_GA_SIZE)
-
\end{code}
End multi-slurp protection:
\begin{code}
--- /dev/null
+\begin{code}
+#ifndef RTSFLAGS_H
+#define RTSFLAGS_H
+\end{code}
+
+For defaults, see the @initRtsFlagsDefaults@ routine.
+
+\begin{code}
+struct GC_FLAGS {
+ FILE *statsFile;
+ I_ giveStats; /* ToDo: replace with enum type? */
+#define NO_GC_STATS 0
+#define VERBOSE_GC_STATS 1
+
+ I_ stksSize; /* this size is stored to record number of *words* */
+ I_ heapSize; /* this size is stored to record number of *words* */
+ I_ allocAreaSize;
+ rtsBool allocAreaSizeGiven;
+ I_ specifiedOldGenSize; /* zero => use the rest of the heap */
+ double pcFreeHeap;
+ I_ minAllocAreaSize; /* derived from: pcFreeHeap, heap-size */
+
+ rtsBool force2s; /* force the use of 2-space copying collection;
+ forced to rtsTrue if we do *heap* profiling.
+ */
+ rtsBool forceGC; /* force a major GC every <interval> bytes */
+ I_ forcingInterval; /* actually, stored as a number of *words* */
+ rtsBool ringBell;
+ W_ trace;
+ /* bit 1 set: chatty GC summaries
+ 2 set: details of minor collections
+ 4 set: details of major collections, except marking
+ 8 set: ditto, but marking this time
+ 16 set: GC of MallocPtrs
+ 32 set: GC of Concurrent things
+ */
+#define DEBUG_TRACE_MINOR_GC 2
+#define DEBUG_TRACE_MAJOR_GC 4
+#define DEBUG_TRACE_MARKING 8
+#define DEBUG_TRACE_MALLOCPTRS 16
+#define DEBUG_TRACE_CONCURRENT 32
+
+ rtsBool lazyBlackHoling;
+ rtsBool doSelectorsAtGC;
+ rtsBool squeezeUpdFrames;
+};
+
+struct DEBUG_FLAGS {
+};
+
+#if defined(PROFILING) || defined(PAR)
+ /* with PROFILING, full cost-centre stuff (also PROFILING_FLAGS);
+ with PAR, just the four fixed cost-centres.
+ */
+struct COST_CENTRE_FLAGS {
+ W_ doCostCentres;
+# define COST_CENTRES_SUMMARY 1
+# define COST_CENTRES_VERBOSE 2 /* incl. serial time profile */
+# define COST_CENTRES_ALL 3
+
+ char sortBy;
+# define SORTCC_LABEL 'C'
+# define SORTCC_TIME 'T'
+# define SORTCC_ALLOC 'A'
+
+ I_ ctxtSwitchTicks; /* derived */
+ I_ profilerTicks; /* derived */
+ I_ msecsPerTick; /* derived */
+};
+#endif
+
+#ifdef PROFILING
+struct PROFILING_FLAGS {
+ W_ doHeapProfile;
+# define NO_HEAP_PROFILING 0 /* N.B. Used as indexes into arrays */
+# define HEAP_BY_CC 1
+# define HEAP_BY_MOD 2
+# define HEAP_BY_GRP 3
+# define HEAP_BY_DESCR 4
+# define HEAP_BY_TYPE 5
+# define HEAP_BY_TIME 6
+
+# define CCchar 'C'
+# define MODchar 'M'
+# define GRPchar 'G'
+# define DESCRchar 'D'
+# define TYPEchar 'Y'
+# define TIMEchar 'T'
+};
+#endif
+
+#ifdef CONCURRENT
+struct CONCURRENT_FLAGS {
+ I_ ctxtSwitchTime; /* in milliseconds */
+ I_ maxThreads;
+ I_ stkChunkSize;
+ I_ maxLocalSparks;
+};
+#endif /* CONCURRENT */
+
+#ifdef PAR
+struct PAR_FLAGS {
+ rtsBool parallelStats; /* Gather parallel statistics */
+ rtsBool granSimStats; /* Full .gr profile (rtsTrue) or only END events? */
+ rtsBool granSimStats_Binary;
+
+ rtsBool outputDisabled; /* Disable output for performance purposes */
+
+ W_ packBufferSize;
+};
+
+#endif /* PAR */
+
+#ifdef GRAN
+struct GRAN_FLAGS {
+};
+#endif /* GRAN */
+
+#ifdef TICKY_TICKY
+struct TICKY_FLAGS {
+ rtsBool showTickyStats;
+ FILE *tickyFile;
+
+ /* see also: doUpdEntryCounts in AllFlags */
+};
+#endif /* TICKY_TICKY */
+\end{code}
+
+Put them together:
+\begin{code}
+struct RTS_FLAGS {
+ struct GC_FLAGS GcFlags;
+ struct DEBUG_FLAGS DebugFlags; /* unused at present */
+
+#if defined(PROFILING) || defined(PAR)
+ struct COST_CENTRE_FLAGS CcFlags;
+#endif
+#ifdef PROFILING
+ struct PROFILING_FLAGS ProfFlags;
+#endif
+#ifdef CONCURRENT
+ struct CONCURRENT_FLAGS ConcFlags;
+#endif
+#ifdef PAR
+ struct PAR_FLAGS ParFlags;
+#endif
+#ifdef GRAN
+ struct GRAN_FLAGS GranFlags;
+#endif
+#ifdef TICKY_TICKY
+ struct TICKY_FLAGS TickyFlags;
+#endif
+};
+
+extern struct RTS_FLAGS RTSflags;
+\end{code}
+
+Routines that operate-on/to-do-with RTS flags:
+\begin{code}
+void initRtsFlagsDefaults (STG_NO_ARGS);
+void setupRtsFlags PROTO((int *argc, char *argv[],
+ int *rts_argc, char *rts_argv[]));
+\end{code}
+
+OLD: This is the maximum identifier length that can be used for a cost
+centre or description string. It includes the terminating null
+character.
+
+The printf formats are here, so we are less likely to make overly-long
+filenames (with disastrous results). No more than 128 chars, please!
+
+\begin{code}
+#define STATS_FILENAME_MAXLEN 128
+
+#define GR_FILENAME_FMT "%0.124s.gr"
+#define GR_FILENAME_FMT_GUM "%0.120s.%03d.%s"
+#define HP_FILENAME_FMT "%0.124s.hp"
+#define LIFE_FILENAME_FMT "%0.122s.life"
+#define PROF_FILENAME_FMT "%0.122s.prof"
+#define PROF_FILENAME_FMT_GUM "%0.118s.%03d.prof"
+#define QP_FILENAME_FMT "%0.124s.qp"
+#define STAT_FILENAME_FMT "%0.122s.stat"
+#define TICKY_FILENAME_FMT "%0.121s.ticky"
+#define TIME_FILENAME_FMT "%0.122s.time"
+#define TIME_FILENAME_FMT_GUM "%0.118s.%03d.time"
+\end{code}
+
+Multi-slurp protection:
+\begin{code}
+#endif /* RTSFLAGS_H */
+\end{code}
The same goes for hash list cells.
\begin{code}
-#ifdef GUM
+#ifdef PAR
typedef struct hashtable HashTable;
typedef struct hashlist HashList;
we are collecting.
\begin{code}
-#if defined(USE_COST_CENTRES) || defined(CONCURRENT)
+#if defined(PROFILING) || defined(CONCURRENT)
typedef struct cc {
struct cc *registered; /* list of registered cost centres */
} *CostCentre;
-#endif /* defined(USE_COST_CENTRES) || defined(CONCURRENT) */
+#endif /* defined(PROFILING) || defined(CONCURRENT) */
\end{code}
This structure will need to be expanded change as the statistics we
\begin{code}
-#define FIXED_HS (INFO_FIXED_HDR + PAR_FIXED_HDR + PROF_FIXED_HDR + AGE_FIXED_HDR)
+#define FIXED_HS (INFO_FIXED_HDR + PAR_FIXED_HDR + PROF_FIXED_HDR + TICKY_FIXED_HDR)
/* NB: this *defines* the intended order for the pieces of
the fixed header. Care should be taken to ensure that this
SET_GRAN_HDR(closure,ThisPE); \
SET_PAR_HDR(closure,LOCAL_GA); \
SET_PROF_HDR(closure,costcentre); \
- SET_AGE_HDR(closure)
+ SET_TICKY_HDR(closure,0)
#define UPD_FIXED_HDR(closure,infolbl,costcentre) \
SET_INFO_PTR(closure,infolbl); \
- SET_PROF_HDR(closure,costcentre)
+ SET_PROF_HDR(closure,costcentre); \
+ SET_TICKY_HDR(closure,1)
/* fiddling SET_PAR_HDR would be a bug (says Patrick) */
- /* no SET_AGE_HDR for inplace updates */
+ /* We set ticky-hdr to 1 because the only place we
+ use this macro is when we have just done an update
+ (WDP 96/01)
+ */
/* These items are comma-separated */
SET_STATIC_PROCS(closure) \
SET_STATIC_PAR_HDR(closure) \
SET_STATIC_PROF_HDR(cc_ident) \
- SET_STATIC_AGE_HDR()
+ SET_STATIC_TICKY_HDR()
\end{code}
they will hear about it soon enough (WDP 95/05).
\begin{code}
-#define SPEC_HS (FIXED_HS)
+#define SPEC_HS (FIXED_HS)
+
+#define SPEC_SIZE(fields) (FIXED_HS + (fields))
+ /*notational convenience; in SMscan.lc + elsewhere */
#define SPEC_CLOSURE_PTR(closure, no) (((P_)(closure))[SPEC_HS + (no) - 1])
#define SPEC_CLOSURE_SIZE(closure) ((W_)INFO_SIZE(INFO_PTR(closure)))
} while (0)
EXTDATA_RO(StablePointerTable_info);
-EXTDATA_RO(EmptyStablePointerTable_static_info);
+EXTDATA_RO(EmptyStablePointerTable_info);
EXTDATA(EmptySPTable_closure);
extern int ValidateSPTable PROTO(( P_ SPTable ));
# define CHECK_SPT_InfoTable( closure ) \
- ASSERT( (*((PP_) (closure)) == EmptyStablePointerTable_static_info && (closure == EmptySPTable_closure) ) || \
+ ASSERT( (*((PP_) (closure)) == EmptyStablePointerTable_info && (closure == EmptySPTable_closure) ) || \
(*((PP_) (closure)) == StablePointerTable_info) )
# define CHECK_SPT_Size( closure ) \
#define IND_CLOSURE_SIZE(closure) (MIN_UPD_SIZE)
#define IND_CLOSURE_NoPTRS(closure) 1
-#define IND_CLOSURE_NoNONPTRS(closure) (IND_CLOSURE_SIZE(closure)-IND_CLOSURE_NoPTRS(closure)-IND_VHS)
+#define IND_CLOSURE_NoNONPTRS(closure) \
+ (IND_CLOSURE_SIZE(closure)-IND_CLOSURE_NoPTRS(closure)-IND_VHS)
\end{code}
Indirections must store a pointer to the closure which is the target
of the indirection:
\begin{code}
-#define IND_CLOSURE_PTR(closure) (((P_)(closure))[IND_HS])
+#define IND_CLOSURE_PTR(closure) (((P_)(closure))[IND_HS])
+#define IND_CLOSURE_LINK(closure) (((P_)(closure))[FIXED_HS])
\end{code}
-\begin{code}
-#define IND_CLOSURE_LINK(closure) (((P_)(closure))[FIXED_HS])
-\end{code}
+When we are profiling, we occasionally use ``permanent indirections''
+to store cost centres associated in some way with PAPs. Don't ask me
+why. For now, a permanent indirection must have the same shape as a
+regular indirection. The only difference is that it is, well,
+permanent. That is to say, it is never short-circuited. (What is the
+point, anyway?)
-When we are profiling, we occasionally use ``permanent indirections'' to
-store cost centres associated in some way with PAPs. Don't ask me why.
-For now, a permanent indirection must have the same shape as a regular
-indirection. The only difference is that it is, well, permanent. That is
-to say, it is never short-circuited. (What is the point, anyway?)
-
-Presumably, such objects could shrink as they moved into the old generation,
-but then their header size would change as well (the word that they get to
-lose is the VHS word of a standard indirection), and I just don't feel up
-to it today. --JSM.
+Presumably, such objects could shrink as they moved into the old
+generation, but then their header size would change as well (the word
+that they get to lose is the VHS word of a standard indirection), and
+I just don't feel up to it today. --JSM.
\begin{code}
-#ifdef USE_COST_CENTRES
-
-#define PERM_IND_CLOSURE_PTR(closure,dummy) IND_CLOSURE_PTR(closure)
+#if defined(PROFILING) || defined(TICKY_TICKY)
+#define PERM_IND_CLOSURE_PTR(closure,dummy) IND_CLOSURE_PTR(closure)
+ /* really *must* be the same as IND_CLOSURE_PTR; it is
+ merely a "two-argument" variant, to fit in with the
+ bizarre goings-on in SMmark.lhc and friends. WDP 95/12
+ */
#endif
\end{code}
@CAF@.
\begin{code}
-#define BH_HS (FIXED_HS)
-#define BH_VHS 0L
+#define BH_HS (FIXED_HS)
+#define BH_VHS 0L
+
+#define BH_U_SIZE MIN_UPD_SIZE
+#define BH_N_SIZE MIN_NONUPD_SIZE
#define BH_CLOSURE_SIZE(closure) ((W_)INFO_SIZE(INFO_PTR(closure)))
#define BH_CLOSURE_NoPTRS(closure) 0L
%************************************************************************
%* *
-\subsubsection[RBH-closures]{@RBH@ (revertable black hole) closure macros}
+\subsubsection[RBH-closures]{@RBH@ (revertible black hole) closure macros}
%* *
%************************************************************************
-There are two kinds of revertable black holes, produced from GEN or
+There are two kinds of revertible black holes, produced from GEN or
SPEC closures, respectively. There's no @SET_RBH_HDR@ macro -- use
-@TurnIntoRBH@ instead!!
+@convertToRBH@ instead!!
Note that the NoPTRS and NoNONPTRS macros refer to the *original* closure.
#define SPEC_RBH_CLOSURE_PTR(closure, no) (((P_)(closure))[SPEC_RBH_HS + (no) - 1])
#define SPEC_RBH_CLOSURE_SIZE(closure) ((W_)INFO_SIZE(REVERT_INFOPTR(INFO_PTR(closure))))
#define SPEC_RBH_CLOSURE_NoPTRS(closure) ((W_)INFO_NoPTRS(REVERT_INFOPTR(INFO_PTR(closure))))
-#define SPEC_RBH_CLOSURE_NoNONPTRS(closure) (SPEC_RBH_CLOSURE_SIZE(closure)-SPEC_RBH_CLOSURE_NoPTRS(closure)/*-SPEC_VHS*/)
+#define SPEC_RBH_CLOSURE_NoNONPTRS(closure) (SPEC_RBH_CLOSURE_SIZE(closure)-SPEC_RBH_CLOSURE_NoPTRS(closure))
#define SPEC_RBH_BQ_LOCN (SPEC_RBH_HS)
#define SPEC_RBH_BQ(closure) (((P_)(closure))[SPEC_RBH_BQ_LOCN])
\begin{code}
#define PROFILING_INFO_OFFSET (FIXED_INFO_WORDS)
-#if !defined(USE_COST_CENTRES)
+#if !defined(PROFILING)
# define PROFILING_INFO_WORDS 0
# define INCLUDE_PROFILING_INFO(base_name)
# define INREGS_PROFILING_INFO
# define INFO_EVAC_2S(infoptr) (((FP_)(INFO_RTBL(infoptr)))[COPY_INFO_OFFSET])
# define INFO_SCAV_2S(infoptr) (((FP_)(INFO_RTBL(infoptr)))[COPY_INFO_OFFSET + 1])
-# if defined(UPDATES_ENTERED_COUNT)
-
-/* Don't commmon up CONST CHARLIKE and INTLIKE treat as SPEC 1_0 closure */
-/* This broke it -- turning it off. Use LARGE heap so no GC needed */
-# if 0
-# define INCLUDE_COPYING_INFO_CONST(evac, scav) \
- INCLUDE_COPYING_INFO(_Evacuate_1,_Scavenge_1_0)
-# endif /* 0 */
-
-# define INCLUDE_COPYING_INFO_CONST(evac, scav) \
- INCLUDE_COPYING_INFO(evac, scav)
-# else
-# define INCLUDE_COPYING_INFO_CONST(evac, scav) \
- INCLUDE_COPYING_INFO(evac, scav)
-# endif
-
#else /* ! _INFO_COPYING */
# define COPY_INFO_WORDS 0
# define INCLUDE_COPYING_INFO(evac, scav)
-# define INCLUDE_COPYING_INFO_CONST(evac, scav)
#endif /* ! _INFO_COPYING */
\end{code}
code.
\begin{code}
-
#define STATIC_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) \
CAT_DECLARE(infolbl,kind,descr,type) \
entry_localness(entry_code); \
INCLUDE_TYPE_INFO(STATIC) \
INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) /* NB: in info table! */ \
INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_Static,_Scavenge_Static) \
+ INCLUDE_COPYING_INFO(_Evacuate_Static,_Dummy_Static_entry) \
INCLUDE_COMPACTING_INFO(_Dummy_Static_entry,_PRStart_Static, \
_Dummy_Static_entry,_Dummy_Static_entry) \
}
-
\end{code}
%************************************************************************
MAYBE_DECLARE_RTBL(BH,U,)
MAYBE_DECLARE_RTBL(BH,N,)
-#define BH_U_SIZE MIN_UPD_SIZE
-#define BH_N_SIZE MIN_NONUPD_SIZE
#define BH_RTBL(kind) \
const W_ MK_REP_LBL(BH,kind,)[] = { \
INCLUDE_TYPE_INFO(BH) \
An indirection simply extracts the pointer from the
@IND_CLOSURE_PTR(closure)@ field. The garbage collection routines will
-short out the indirection.
+short out the indirection (normally).
\begin{code}
#define IND_ITBL(infolbl,ind_code,localness,entry_localness) \
on garbage collection.
\begin{code}
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING) || defined(TICKY_TICKY)
# define PERM_IND_ITBL(infolbl,ind_code,localness,entry_localness) \
entry_localness(ind_code); \
@CAF@'s evacuation code to be called before the @CAF@ has been
evacuated, returning an unevacuated pointer.
-Another scheme leaves updating the @CAF@ indirections to the end
-of the garbage collection.
-All the references are evacuated and scavenged as usual (including the
-@CAFlist@). Once collection is complete the @CAFlist@ is traversed
-updating the @CAF@ references with the result of evacuating the
-referenced closure again. This will immediately return as it must be a
-forward reference, a static closure, or a @CAF@ which will indirect by
-evacuating its reference.
+Another scheme leaves updating the @CAF@ indirections to the end of
+the garbage collection. All the references are evacuated and
+scavenged as usual (including the @CAFlist@). Once collection is
+complete the @CAFlist@ is traversed updating the @CAF@ references with
+the result of evacuating the referenced closure again. This will
+immediately return as it must be a forward reference, a static
+closure, or a @CAF@ which will indirect by evacuating its reference.
The crux of the problem is that the @CAF@ evacuation code needs to
-know if its reference has already been evacuated and updated. If not, then
-the reference can be evacuated, updated and returned safely (possibly
-evacuating another @CAF@). If it has, then the updated reference can be
-returned. This can be done using two @CAF@ info-tables. At the start
-of a collection the @CAFlist@ is traversed and set to an internal {\em
-evacuate and update} info-table. During collection, evacution of such a
-@CAF@ also results in the info-table being reset back to the standard
-@CAF@ {\em return reference} info-table. Thus subsequent evacuations
-will simply return the updated reference. On completion of the
-collection all @CAF@s will have {\em return reference} info-tables
+know if its reference has already been evacuated and updated. If not,
+then the reference can be evacuated, updated and returned safely
+(possibly evacuating another @CAF@). If it has, then the updated
+reference can be returned. This can be done using two @CAF@
+info-tables. At the start of a collection the @CAFlist@ is traversed
+and set to an internal {\em evacuate and update} info-table. During
+collection, evacution of such a @CAF@ also results in the info-table
+being reset back to the standard @CAF@ info-table. Thus subsequent
+evacuations will simply return the updated reference. On completion of
+the collection all @CAF@s will have {\em return reference} info-tables
again.
This is the scheme we adopt. A @CAF@ indirection has evacuation code
which returns the evacuated and updated reference. During garbage
-collection all the @CAF@s are overwritten with an internal @CAF@ info
+collection, all the @CAF@s are overwritten with an internal @CAF@ info
table which has evacuation code which performs this evacuate and
update and restores the original @CAF@ code. At some point during the
-collection we must ensure that all the @CAF@s are indeed
-evacuated.
+collection we must ensure that all the @CAF@s are indeed evacuated.
The only potential problem with this scheme is a cyclic list of @CAF@s
all directly referencing (possibly via indirections) another @CAF@!
@CAF@ which will reference itself! Construction of such a structure
indicates the program must be in an infinite loop.
-
\subsubsection{Compacting Collector}
-When shorting out a @CAF@, its reference must be marked. A first attempt
-might explicitly mark the @CAF@s, updating the reference with the
-marked reference (possibly short circuting indirections). The actual
-@CAF@ marking code can indicate that they have already been marked
-(though this might not have actually been done yet) and return the
-indirection pointer so it is shorted out. Unfortunately the @CAF@
+When shorting out a @CAF@, its reference must be marked. A first
+attempt might explicitly mark the @CAF@s, updating the reference with
+the marked reference (possibly short circuting indirections). The
+actual @CAF@ marking code can indicate that they have already been
+marked (though this might not have actually been done yet) and return
+the indirection pointer so it is shorted out. Unfortunately the @CAF@
reference might point to an indirection which will be subsequently
shorted out. Rather than returning the @CAF@ reference we treat the
@CAF@ as an indirection, calling the mark code of the reference, which
%* *
%************************************************************************
-This declares an info table for @CONST@ closures (size 0).
-It is the info table for a dynamicaly-allocated closure which
-will redirect references to the corresponding
-static closure @<infolbl>_closure@ during garbage collection.
-A pointer to the static closure is kept in the info table. (It is
-assumed that this closure is declared elsewhere.)
+This declares an info table for @CONST@ closures (size 0). It is the
+info table for a dynamicaly-allocated closure which will redirect
+references to the corresponding static closure @<infolbl>_closure@
+during garbage collection. A pointer to the static closure is kept in
+the info table. (It is assumed that this closure is declared
+elsewhere.)
-Why do such @CONST@ objects ever exist? Why don't we just use the static
-object in the first place? @CONST@ objects are used only for updating
-existing objects. We could use an indirection, but that risks costing
-extra run-time indirections until the next gc shorts it out. So
-we update with a @CONST@, and the next gc gets rid of it.
+Why do such @CONST@ objects ever exist? Why don't we just use the
+static object in the first place? @CONST@ objects are used only for
+updating existing objects. We could use an indirection, but that
+risks costing extra run-time indirections until the next GC shorts it
+out. So we update with a @CONST@, and the next GC gets rid of it.
\begin{code}
-
#define CONST_ITBL(infolbl,closurelbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) /*size,ptrs unused*/ \
CAT_DECLARE(infolbl,kind,descr,type) \
entry_localness(entry_code); \
MAYBE_DECLARE_RTBL(Const,,)
-#define CONST_RTBL() \
- const W_ MK_REP_LBL(Const,,)[] = { \
- INCLUDE_TYPE_INFO(CONST) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO_CONST(_Evacuate_Const,_Scavenge_Const) \
- INCLUDE_COMPACTING_INFO(_Dummy_Const_entry,_PRStart_Const, \
- _Dummy_Const_entry,_Dummy_Const_entry) \
- }
+#ifdef TICKY_TICKY
+ /* we need real routines if we may not be commoning up */
+#define CONST_Scav _Scavenge_0_0
+#define CONST_Link _ScanLink_0_0
+#define CONST_Move _ScanMove_0
+#else
+#define CONST_Scav _Dummy_Const_entry
+#define CONST_Link _Dummy_Const_entry
+#define CONST_Move _Dummy_Const_entry
+#endif
+#define CONST_RTBL() \
+ const W_ MK_REP_LBL(Const,,)[] = { \
+ INCLUDE_TYPE_INFO(CONST) \
+ INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
+ INCLUDE_PAR_INFO \
+ INCLUDE_COPYING_INFO(_Evacuate_Const,CONST_Scav) \
+ INCLUDE_COMPACTING_INFO(CONST_Link,_PRStart_Const, \
+ CONST_Move,_Dummy_Const_entry) \
+ }
\end{code}
This builds an info-table which will have pointers to the closure
@CHARLIKE_closures@ array.
\begin{code}
-
#define CHARLIKE_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) /*tag,size,ptrs unused*/ \
CAT_DECLARE(infolbl,kind,descr,type) \
entry_localness(entry_code); \
MAYBE_DECLARE_RTBL(CharLike,,)
-#define CHARLIKE_RTBL() \
- const W_ MK_REP_LBL(CharLike,,)[] = { \
- INCLUDE_TYPE_INFO(CHARLIKE) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO_CONST(_Evacuate_CharLike,_Scavenge_CharLike) \
- INCLUDE_COMPACTING_INFO(_Dummy_CharLike_entry,_PRStart_CharLike, \
- _Dummy_CharLike_entry,_Dummy_CharLike_entry) \
- }
+#ifdef TICKY_TICKY
+ /* we need real routines if we may not be commoning up */
+#define CHARLIKE_Scav _Scavenge_1_0
+#define CHARLIKE_Link _ScanLink_1_0
+#define CHARLIKE_Move _ScanMove_1
+#else
+#define CHARLIKE_Scav _Dummy_CharLike_entry
+#define CHARLIKE_Link _Dummy_CharLike_entry
+#define CHARLIKE_Move _Dummy_CharLike_entry
+#endif
+#define CHARLIKE_RTBL() \
+ const W_ MK_REP_LBL(CharLike,,)[] = { \
+ INCLUDE_TYPE_INFO(CHARLIKE) \
+ INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
+ INCLUDE_PAR_INFO \
+ INCLUDE_COPYING_INFO(_Evacuate_CharLike,CHARLIKE_Scav) \
+ INCLUDE_COMPACTING_INFO(CHARLIKE_Link,_PRStart_CharLike, \
+ CHARLIKE_Move,_PRIn_Error) \
+ }
\end{code}
-
Int-like: this builds the info-table required for intlike closures.
The normal heap-allocated info-table for fixed-size integers (size
-@1@); it is used for updates too.
-At GC, this is redirected to a static intlike closure if one is
-available.
-
-Note again the sneaky hiding of a reference to the real info-table in
-the part of the info-table that normally holds the size of the
-closure.
-THIS CHANGES IN THE COMMONED INFO-TABLE WORLD.
+@1@); it is used for updates too. At GC, this is redirected to a
+static intlike closure if one is available.
\begin{code}
-
#define INTLIKE_ITBL(infolbl,entry_code,upd_code,liveness,tag,size,ptrs,localness,entry_localness,kind,descr,type) /*tag,size,ptrs unused*/ \
CAT_DECLARE(infolbl,kind,descr,type) \
entry_localness(entry_code); \
INCLUDE_TYPE_INFO(INTLIKE) \
INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO_CONST(_Evacuate_IntLike,_Scavenge_1_0) \
+ INCLUDE_COPYING_INFO(_Evacuate_IntLike,_Scavenge_1_0) \
INCLUDE_COMPACTING_INFO(_ScanLink_1_0,_PRStart_IntLike, \
_ScanMove_1,_PRIn_Error) \
}
-
\end{code}
%************************************************************************
typedef I_ (StgScanFun)(STG_NO_ARGS);
typedef I_ (*StgScanPtr)(STG_NO_ARGS);
+#ifdef TICKY_TICKY
+extern StgScanFun _ScanLink_0_0;
+#endif
extern StgScanFun _ScanLink_1_0;
extern StgScanFun _ScanLink_2_0;
extern StgScanFun _ScanLink_3_0;
extern StgScanFun _ScanLink_Data;
extern StgScanFun _ScanLink_MuTuple;
-#ifdef USE_COST_CENTRES
+#if defined(PROFILING) || defined(TICKY_TICKY)
extern StgScanFun _ScanLink_PI;
#endif
extern StgScanFun _ScanLink_BQ;
#endif
+#ifdef TICKY_TICKY
+extern StgScanFun _ScanMove_0;
+#endif
extern StgScanFun _ScanMove_1;
extern StgScanFun _ScanMove_2;
extern StgScanFun _ScanMove_3;
extern StgScanFun _ScanMove_Data;
extern StgScanFun _ScanMove_MuTuple;
-#ifdef USE_COST_CENTRES
+#if defined(PROFILING) || defined(TICKY_TICKY)
extern StgScanFun _ScanMove_PI;
#endif
extern StgEvacFun _EvacuateSelector_11;
extern StgEvacFun _EvacuateSelector_12;
+#ifdef TICKY_TICKY
+extern StgScavFun _Scavenge_0_0;
+#endif
extern StgScavFun _Scavenge_1_0;
extern StgScavFun _Scavenge_2_0;
extern StgScavFun _Scavenge_3_0;
extern StgScavFun _Scavenge_BH_U;
extern StgEvacFun _Evacuate_Static;
-extern StgScavFun _Scavenge_Static;
extern StgEvacFun _Evacuate_Ind;
extern StgScavFun _Scavenge_Ind;
extern StgEvacFun _Evacuate_Caf;
extern StgScavFun _Scavenge_Caf;
-#ifdef USE_COST_CENTRES
+#if defined(PROFILING) || defined(TICKY_TICKY)
extern StgEvacFun _Evacuate_PI;
extern StgScavFun _Scavenge_PI;
#endif
extern StgEvacFun _Evacuate_Const;
-extern StgScavFun _Scavenge_Const;
extern StgEvacFun _Evacuate_CharLike;
-extern StgScavFun _Scavenge_CharLike;
extern StgEvacFun _Evacuate_IntLike;
-extern StgScavFun _Scavenge_IntLike;
#ifdef CONCURRENT
extern StgEvacFun _Evacuate_BQ;
extern StgEvacFun _Evacuate_StkO;
extern StgScavFun _Scavenge_StkO;
#endif
-
\end{code}
\begin{code}
The storage manager is accessed exclusively through these routines:
\begin{code}
-IF_RTS(I_ initSM PROTO((I_ rts_argc, char **rts_argv, FILE *statsfile));)
-IF_RTS(I_ exitSM PROTO((smInfo *sm));)
-IF_RTS(I_ initStacks PROTO((smInfo *sm));)
-IF_RTS(I_ initHeap PROTO((smInfo *sm));)
+IF_RTS(void initSM (STG_NO_ARGS);)
+IF_RTS(rtsBool exitSM PROTO((smInfo *sm));)
+IF_RTS(rtsBool initStacks PROTO((smInfo *sm));)
+IF_RTS(rtsBool initHeap PROTO((smInfo *sm));)
#ifdef CONCURRENT
-IF_RTS(rtsBool initThreadPool PROTO((I_ size));)
+IF_RTS(rtsBool initThreadPools (STG_NO_ARGS);)
#endif
#ifdef PAR
IF_RTS(void init_gr_profiling PROTO((int, char **, int, char **));)
IF_RTS(void unmapMiddleStackPage PROTO((char *, int));) /* char * == caddr_t ? */
-#if defined(USE_COST_CENTRES) || defined(GUM)
+#if defined(PROFILING) || defined(PAR)
IF_RTS(void handle_tick_serial(STG_NO_ARGS);)
IF_RTS(void handle_tick_noserial(STG_NO_ARGS);)
#endif
\end{code}
-@initSM@ processes any runtime parameters directed towards the storage
-manager. The @statsfile@ parameter is an open file, which will contain
-any garbage collection statistics requested by the user. This file
-must be opened for writing.
+@initSM@ finalizes any runtime parameters of the storage manager.
@exitSM@ does any cleaning up required by the storage manager before
the program is executed. Its main purpose is to print any summary
extern F_ _PRStart_Data(STG_NO_ARGS);
extern F_ _PRStart_MuTuple(STG_NO_ARGS);
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING) || defined(TICKY_TICKY)
extern F_ _PRStart_PI(STG_NO_ARGS);
#endif
extern F_ _PRIn_Error(STG_NO_ARGS);
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING) || defined(TICKY_TICKY)
extern F_ _PRIn_PI(STG_NO_ARGS);
#endif
#define PUSH_SuB(frame, sub) (frame)[BREL(UF_SUB)] = (W_)(sub)
#define PUSH_SuA(frame, sua) (frame)[BREL(UF_SUA)] = (W_)(sua)
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
#define PUSH_STD_CCC(frame) (frame)[BREL(UF_COST_CENTRE)] = (W_)(CCC)
#else
#define PUSH_STD_CCC(frame)
/* BHed on entry -- GC cant do it */
\end{code}
-Finally we indicate to the storage manager if it is required to trace
-closures on the B stack and overwrite them with black holes.
-
-\begin{code}
-/* define SM_DO_BH_UPDATE if B stack closures to be BHed by GC */
-#if !defined(CONCURRENT)
-#define SM_DO_BH_UPDATE
-#endif
-\end{code}
-
-
%************************************************************************
%* *
\subsubsection[caf-update]{Entering CAFs}
%* *
%************************************************************************
-When we enter a CAF we update it with an indirection to a heap
-allocated black hole. The @UPD_CAF@ macro updates the CAF with an
-@CAF@ indirection to the heap allocated closure and adds the updated
+When we enter a CAF, we update it with an indirection to a
+heap-allocated black hole. The @UPD_CAF@ macro updates the CAF with an
+@CAF@ indirection to the heap-allocated closure and adds the updated
CAF to the list of CAFs. It is up to the entry code to allocate the
black hole.
-The @CAF@ info table used is the @Caf_Return@ table. It will be
+The @CAF@ info table used is the @Caf_info@ table. It will be
overwritten at the start of garbage collection with the @Caf_Evac_Upd@
-and then reset to @Caf_Return@ during garbage collection.
+and then reset to @Caf_info@ during garbage collection.
In the parallel case, the new black hole will be a local node
(with a GA of 0). This means that the code to update indirections
etc.
\begin{code}
-
EXTDATA_RO(Caf_info);
EXTFUN(Caf_entry);
#define UPD_CAF(cafptr, bhptr) \
do { \
SET_INFO_PTR(cafptr, Caf_info); \
- IND_CLOSURE_PTR(cafptr) = (W_) (bhptr); \
+ IND_CLOSURE_PTR(cafptr) = (W_) (bhptr); \
IND_CLOSURE_LINK(cafptr) = (W_) StorageMgrInfo.CAFlist; \
- StorageMgrInfo.CAFlist = (P_) (cafptr); \
+ StorageMgrInfo.CAFlist = (P_) (cafptr); \
} while(0)
-
\end{code}
@heapptr@.
\item[@UPD_INPLACE_NOPTRS(updclosure, livemask)@]\ \\
-This prepares the closure pointed to by @updclosure@ to be updated in-place
-with a closure of size @MIN_UPD_SIZE@ containing no pointers.
+This prepares the closure pointed to by @updclosure@ to be updated
+in-place with a closure of size @MIN_UPD_SIZE@ containing no pointers.
\item[@UPD_INPLACE_PTRS(updclosure, livemask)@]\ \\
-This prepares the closure pointed to by @updclosure@ to be updated in-place
-with a closure of size @MIN_UPD_SIZE@ which may contain pointers. It checks
-whether @updclosure@ is allowed to be updated inplace. If it is not
-it:
+This prepares the closure pointed to by @updclosure@ to be updated
+in-place with a closure of size @MIN_UPD_SIZE@ which may contain
+pointers. It checks whether @updclosure@ is allowed to be updated
+inplace. If it is not it:
\begin{enumerate}
\item Allocates space for a new closure of size @MIN_UPD_SIZE@ (by
calling @HEAP_CHK_RETRY@);
The @UPD_IND@ and @UPDATE_INPLACE@ macros may have different
definitions depending on the garbage collection schemes in use.
-First we have the declarations which trace updates. These are calls to
-tracing routines inserted if @DO_RUNTIME_TRACE_UPDATES@ is defined and
-printed if @traceUpdates@ is true.
-
-\begin{code}
-#if defined(DO_RUNTIME_TRACE_UPDATES)
-
-extern I_ traceUpdates;
-extern void TRACE_UPDATE_Ind();
-extern void TRACE_UPDATE_Inplace_NoPtrs();
-extern void TRACE_UPDATE_Inplace_Ptrs();
-
-#define TRACE_UPDATE(_trace) _trace
-#else
-#define TRACE_UPDATE(_trace) /* nothing */
-#endif
-\end{code}
-
Before describing the update macros we declare the partial application
entry and update code (See \tr{StgUpdate.lhc}).
\begin{code}
#ifdef CONCURRENT
+/* In the concurrent world, the targed of an update might
+ be a black hole with a blocking queue attached. If so,
+ it will already be on the mutables list, and we have to be careful
+ not to put it on twice else it screws up the list. */
#define ALREADY_LINKED(closure) \
(IS_MUTABLE(INFO_PTR(closure)) && MUT_LINK(closure) != MUT_NOT_LINKED)
-#if defined(GRAN)
+# if defined(GRAN)
extern I_ AwakenBlockingQueue PROTO((P_));
-#else
+# else
extern void AwakenBlockingQueue PROTO((P_));
-#endif
+# endif
-#ifdef MAIN_REG_MAP
-#define AWAKEN_BQ(updatee) \
+# ifdef MAIN_REG_MAP
+# define AWAKEN_BQ(updatee) \
do { if (IS_BQ_CLOSURE(updatee)) \
STGCALL1(void,(void *, P_), AwakenBlockingQueue, (P_) BQ_ENTRIES(updatee)); \
} while(0);
-#endif
+# endif
-#ifdef NULL_REG_MAP
-#define AWAKEN_BQ(updatee) \
+# ifdef NULL_REG_MAP
+# define AWAKEN_BQ(updatee) \
do { if (IS_BQ_CLOSURE(updatee)) \
AwakenBlockingQueue((P_)BQ_ENTRIES(updatee)); \
} while(0);
-#endif
+# endif
-#define AWAKEN_INPLACE_BQ()
+# define AWAKEN_INPLACE_BQ()
-#else
+#else /* !CONCURRENT */
-#define ALREADY_LINKED(closure) 0
+# define ALREADY_LINKED(closure) 0 /* NB: see note above in CONCURRENT */
-#define AWAKEN_BQ(updatee)
-#define AWAKEN_INPLACE_BQ()
+# define AWAKEN_BQ(updatee)
+# define AWAKEN_INPLACE_BQ()
-#endif
+#endif /* CONCURRENT */
EXTDATA_RO(Ind_info);
EXTFUN(Ind_entry);
+#ifndef TICKY_TICKY
+# define Ind_info_TO_USE Ind_info
+#else
+EXTDATA_RO(Perm_Ind_info);
+EXTFUN(Perm_Ind_entry);
+
+# define Ind_info_TO_USE ((AllFlags.doUpdEntryCounts) ? Perm_Ind_info : Ind_info)
+#endif
#if defined(GC2s) || defined(GC1s) || defined(GCdu)
+#define INPLACE_UPD_HDR(closure,infolbl,cc,size,ptrs) \
+ UPD_FIXED_HDR(closure,infolbl,cc)
+
#define UPD_IND(updclosure, heapptr) \
- TRACE_UPDATE(TRACE_UPDATE_Ind(updclosure,heapptr)); \
- UPDATED_SET_UPDATED(updclosure); /* subs entry count */ \
- UPDATE_PROFILE_CLOSURE((P_)updclosure); \
+ UPDATED_SET_UPDATED(updclosure); /* ticky */ \
AWAKEN_BQ(updclosure); \
- SET_INFO_PTR(updclosure, Ind_info); \
+ SET_INFO_PTR(updclosure, Ind_info_TO_USE); \
IND_CLOSURE_PTR(updclosure) = (W_)(heapptr)
#define UPD_INPLACE_NOPTRS(livemask) \
- TRACE_UPDATE(TRACE_UPDATE_Inplace_NoPtrs(Node)); \
- UPDATED_SET_UPDATED(Node); /* subs entry count */ \
- UPDATE_PROFILE_CLOSURE(Node); \
+ UPDATED_SET_UPDATED(Node); /* ticky */ \
AWAKEN_BQ(Node);
#define UPD_INPLACE_PTRS(livemask) \
- TRACE_UPDATE(TRACE_UPDATE_Inplace_Ptrs(Node,hp)); \
- UPDATED_SET_UPDATED(Node); /* subs entry count */ \
- UPDATE_PROFILE_CLOSURE(Node); \
+ UPDATED_SET_UPDATED(Node); /* ticky */ \
AWAKEN_BQ(Node);
-
-#define INPLACE_UPD_HDR(closure,infolbl,cc,size,ptrs) \
- UPD_FIXED_HDR(closure,infolbl,cc)
\end{code}
%************************************************************************
onto the list of old generation closures.
\begin{code}
-#else
-#if defined(GCap) || defined(GCgn)
-
-#define UPD_IND(updclosure, heapptr) \
-{ TRACE_UPDATE(TRACE_UPDATE_Ind(updclosure,heapptr)); \
- if ( ((P_)(updclosure)) <= StorageMgrInfo.OldLim) { \
- UPD_OLD_IND(); \
- if(!ALREADY_LINKED(updclosure)) { \
- MUT_LINK(updclosure) \
- = (W_) StorageMgrInfo.OldMutables; \
- StorageMgrInfo.OldMutables = (P_) (updclosure); \
- } \
- } else { \
- UPD_NEW_IND(); \
- } \
- AWAKEN_BQ(updclosure); \
- SET_INFO_PTR(updclosure, Ind_info); \
- IND_CLOSURE_PTR(updclosure) = (W_)(heapptr); \
+#else /* !(2s/1s/du) */
+# if defined(GCap) || defined(GCgn)
+
+/* same as before */
+#define INPLACE_UPD_HDR(closure,infolbl,cc,size,ptrs) \
+ UPD_FIXED_HDR(closure,infolbl,cc)
+
+/* updclosure is the updatee, heapptr is what to update it with */
+#define UPD_IND(updclosure, heapptr) \
+{ UPDATED_SET_UPDATED(updclosure); /* ticky */ \
+ if ( ((P_)(updclosure)) > StorageMgrInfo.OldLim ) { \
+ UPD_NEW_IND(); /*ticky*/ \
+ } else { \
+ UPD_OLD_IND(); /*ticky*/ \
+ if(!ALREADY_LINKED(updclosure)) { \
+ MUT_LINK(updclosure) = (W_) StorageMgrInfo.OldMutables; \
+ StorageMgrInfo.OldMutables = (P_) (updclosure); \
+ } \
+ } \
+ AWAKEN_BQ(updclosure); \
+ SET_INFO_PTR(updclosure, Ind_info_TO_USE); \
+ IND_CLOSURE_PTR(updclosure) = (W_)(heapptr); \
}
/*
* In threaded-land, we have to do the same nonsense as UPD_INPLACE_PTRS if
* we were a blocking queue on the old mutables list.
*/
-#define UPD_INPLACE_NOPTRS(live_regs_mask) \
- TRACE_UPDATE(TRACE_UPDATE_Inplace_NoPtrs(Node)); \
- if ( Node <= StorageMgrInfo.OldLim) { \
- UPD_OLD_IN_PLACE_NOPTRS(); \
- if(ALREADY_LINKED(Node)) { \
- /* We are already on the old mutables list, so we \
- can't update in place any more */ \
- HEAP_CHK(live_regs_mask, _FHS+MIN_UPD_SIZE, 0); \
- /* ticky-ticky (NB: was ALLOC_UPD_CON) */ \
- ALLOC_CON(_FHS,1,MIN_UPD_SIZE-1,_FHS+MIN_UPD_SIZE); \
- CC_ALLOC(CCC,_FHS+MIN_UPD_SIZE,CON_K); \
- /* must awaken after any possible GC */ \
- AWAKEN_BQ(Node); \
- SET_INFO_PTR(Node, Ind_info); \
- IND_CLOSURE_PTR(Node) = \
- (W_)(Hp-(_FHS+MIN_UPD_SIZE-1)); \
- Node = Hp-(_FHS+MIN_UPD_SIZE-1); \
- } \
- } else { \
- UPD_NEW_IN_PLACE_NOPTRS(); \
- AWAKEN_BQ(Node); \
+#define UPD_INPLACE_NOPTRS(live_regs_mask) \
+ UPDATED_SET_UPDATED(Node); /* ticky */ \
+ if ( Node > StorageMgrInfo.OldLim) { \
+ UPD_NEW_IN_PLACE_NOPTRS(); /*ticky*/ \
+ AWAKEN_BQ(Node); \
+ } else { \
+ UPD_OLD_IN_PLACE_NOPTRS(); /*ticky*/ \
+ if(ALREADY_LINKED(Node)) { \
+ /* We are already on the old mutables list, so we \
+ can't update in place any more */ \
+ HEAP_CHK(live_regs_mask, _FHS+MIN_UPD_SIZE, 0); \
+ /* ticky-ticky (NB: was ALLOC_UPD_CON) */ \
+ ALLOC_CON(_FHS,1,MIN_UPD_SIZE-1,_FHS+MIN_UPD_SIZE); \
+ CC_ALLOC(CCC,_FHS+MIN_UPD_SIZE,CON_K); \
+ /* must awaken after any possible GC */ \
+ AWAKEN_BQ(Node); \
+ SET_INFO_PTR(Node, Ind_info_TO_USE); \
+ IND_CLOSURE_PTR(Node) = (W_)(Hp-(_FHS+MIN_UPD_SIZE-1)); \
+ Node = Hp-(_FHS+MIN_UPD_SIZE-1); \
+ } \
}
-#define UPD_INPLACE_PTRS(live_regs_mask) \
- TRACE_UPDATE(TRACE_UPDATE_Inplace_Ptrs(Node,hp)); \
- if ( Node <= StorageMgrInfo.OldLim) { \
- /* redirect update with indirection */ \
- UPD_OLD_IN_PLACE_PTRS(); \
- /* Allocate */ \
- HEAP_CHK(live_regs_mask, _FHS+MIN_UPD_SIZE, 0); \
- /* ticky-ticky (NB: was ALLOC_UPD_CON) */ \
- ALLOC_CON(_FHS,1,MIN_UPD_SIZE-1,_FHS+MIN_UPD_SIZE); \
- CC_ALLOC(CCC,_FHS+MIN_UPD_SIZE,CON_K); \
- \
- if (!ALREADY_LINKED(Node)) { \
- MUT_LINK(Node) \
- = (W_) StorageMgrInfo.OldMutables; \
- StorageMgrInfo.OldMutables = (P_) (Node); \
- } \
- /* must awaken after any possible GC */ \
- AWAKEN_BQ(Node); \
- SET_INFO_PTR(Node, Ind_info); \
- IND_CLOSURE_PTR(Node) \
- = (W_)(Hp-(_FHS+MIN_UPD_SIZE-1)); \
- Node = Hp-(_FHS+MIN_UPD_SIZE-1); \
- } else { \
- UPD_NEW_IN_PLACE_PTRS(); \
- AWAKEN_BQ(Node); \
- } \
-
-
-/* same as before */
-#define INPLACE_UPD_HDR(closure,infolbl,cc,size,ptrs) \
- UPD_FIXED_HDR(closure,infolbl,cc)
-
-#endif /* GCap || GCgn */
+#define UPD_INPLACE_PTRS(live_regs_mask) \
+ UPDATED_SET_UPDATED(Node); /* ticky */ \
+ if ( Node > StorageMgrInfo.OldLim) { \
+ UPD_NEW_IN_PLACE_PTRS(); /*ticky*/ \
+ AWAKEN_BQ(Node); \
+ } else { \
+ /* redirect update with indirection */ \
+ UPD_OLD_IN_PLACE_PTRS(); /*ticky*/ \
+ /* Allocate */ \
+ HEAP_CHK(live_regs_mask, _FHS+MIN_UPD_SIZE, 0); \
+ /* ticky-ticky (NB: was ALLOC_UPD_CON) */ \
+ ALLOC_CON(_FHS,1,MIN_UPD_SIZE-1,_FHS+MIN_UPD_SIZE); \
+ CC_ALLOC(CCC,_FHS+MIN_UPD_SIZE,CON_K); \
+ \
+ if (!ALREADY_LINKED(Node)) { \
+ MUT_LINK(Node) = (W_) StorageMgrInfo.OldMutables; \
+ StorageMgrInfo.OldMutables = (P_) (Node); \
+ } \
+ /* must awaken after any possible GC */ \
+ AWAKEN_BQ(Node); \
+ SET_INFO_PTR(Node, Ind_info_TO_USE); \
+ IND_CLOSURE_PTR(Node) = (W_)(Hp-(_FHS+MIN_UPD_SIZE-1)); \
+ Node = Hp-(_FHS+MIN_UPD_SIZE-1); \
+ }
+# endif /* GCap || GCgn */
#endif
\end{code}
SET_INFO_PTR(freezeclosure, immutinfo)
#endif
-
#endif /* SMUPDATE_H */
\end{code}
\begin{code}
#define ARGS_CHK_A(n) \
- SET_ACTIVITY(ACT_ARGS_CHK); /* SPAT counting */ \
if (SuA /*SUBTRACT_A_STK( SpA, SuA )*/ < (SpA+(n))) { \
JMP_( UpdatePAP ); \
- } \
- SET_ACTIVITY(ACT_TAILCALL)
+ }
#define ARGS_CHK_A_LOAD_NODE(n, closure_addr) \
- SET_ACTIVITY(ACT_ARGS_CHK); /* SPAT counting */ \
if (SuA /*SUBTRACT_A_STK( SpA, SuA )*/ < (SpA+(n))) { \
Node = (P_) closure_addr; \
JMP_( UpdatePAP ); \
- } \
- SET_ACTIVITY(ACT_TAILCALL)
-
+ }
#define ARGS_CHK_B(n) \
- SET_ACTIVITY(ACT_ARGS_CHK); /* SPAT counting */ \
if (SpB /*SUBTRACT_B_STK( SpB, SuB )*/ < (SuB-(n))) { \
JMP_( UpdatePAP ); \
- } \
- SET_ACTIVITY(ACT_TAILCALL)
+ }
#define ARGS_CHK_B_LOAD_NODE(n, closure_addr) \
- SET_ACTIVITY(ACT_ARGS_CHK); /* SPAT counting */ \
if (SpB /*SUBTRACT_B_STK( SpB, SuB )*/ < (SuB-(n))) { \
Node = (P_) closure_addr; \
JMP_( UpdatePAP ); \
- } \
- SET_ACTIVITY(ACT_TAILCALL)
-
+ }
\end{code}
%************************************************************************
NB: args @a@ and @b@ are pre-direction-ified!
\begin{code}
extern I_ SqueezeUpdateFrames PROTO((P_, P_, P_));
+int sanityChk_StkO (P_ stko); /* ToDo: move to a sane place */
#if ! defined(CONCURRENT)
do { \
DO_ASTK_HWM(); /* ticky-ticky profiling */ \
DO_BSTK_HWM(); \
- /* SET_ACTIVITY(ACT_STK_CHK); /? SPAT counting -- no, using page faulting */ \
if (STKS_OVERFLOW_OP((a_headroom) + 1, (b_headroom) + 1)) { \
STACK_OVERFLOW(liveness_mask,a_headroom,b_headroom,spa,spb,ret_type,reenter);\
} \
#define HEAP_OVERFLOW(liveness,n,reenter) \
do { \
- SET_ACTIVITY(ACT_GC); /* SPAT profiling */ \
DO_GC((((W_)n)<<8)|(liveness)); \
- SET_ACTIVITY(ACT_GC_STOP); \
} while (0)
#define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 8 + 1))) - 1)
#define HEAP_OVERFLOW(liveness,n,reenter) \
do { \
- SET_ACTIVITY(ACT_GC); /* SPAT profiling */ \
DO_GC((((W_)(n))<<9)|((reenter)<<8)|(liveness)); \
- SET_ACTIVITY(ACT_GC_STOP); \
} while (0)
#define REQSIZE_BITMASK ((1L << ((BITS_IN(W_) - 9 + 1))) - 1)
/* THREAD_CONTEXT_SWITCH(liveness_mask,reenter); */ \
ALLOC_HEAP(n); /* ticky profiling */ \
GRAN_ALLOC_HEAP(n,liveness_mask); /* Granularity Simulation */ \
- SET_ACTIVITY(ACT_HEAP_CHK); /* SPAT counting */ \
if (((Hp = Hp + (n)) > HpLim)) { \
/* Old: STGCALL3_GC(PerformGC,liveness_mask,n,StgFalse); */\
HEAP_OVERFLOW(liveness_mask,n,StgFalse); \
- } \
- SET_ACTIVITY(ACT_REDN); /* back to normal reduction */ \
- }while(0)
+ }}while(0)
#else
/* TICKY_PARANOIA(__FILE__, __LINE__); */ \
PRE_FETCH(n); \
ALLOC_HEAP(n); /* ticky profiling */ \
- SET_ACTIVITY(ACT_HEAP_CHK); /* SPAT counting */ \
if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
HEAP_OVERFLOW(liveness_mask,n,reenter); \
} \
/* TICKY_PARANOIA(__FILE__, __LINE__); */ \
PRE_FETCH(n); \
ALLOC_HEAP(n); /* ticky profiling */ \
- SET_ACTIVITY(ACT_HEAP_CHK); /* SPAT counting */ \
if (((Hp = Hp + (n)) > HpLim) OR_INTERVAL_EXPIRED OR_CONTEXT_SWITCH OR_MSG_PENDING) { \
HEAP_OVERFLOW(liveness_mask,n,reenter); \
n = TSO_ARG1(CurrentTSO); \
- } \
- SET_ACTIVITY(ACT_REDN); /* back to normal reduction */\
-} while(0)
+ }} while(0)
#else
UN_ALLOC_HEAP(n); /* Undo ticky-ticky */ \
SAVE_Hp = Hp; /* Hand over the hp */ \
DEBUG_SetGMPAllocBudget(n) \
- OptSaveHpLimRegister() \
}while(0)
#define GMP_HEAP_HANDBACK() \
Hp = SAVE_Hp; \
- DEBUG_ResetGMPAllocBudget() \
- OptRestoreHpLimRegister()
+ DEBUG_ResetGMPAllocBudget()
\end{code}
\begin{code}
#endif
\end{code}
-\begin{code}
-#if defined (LIFE_PROFILE)
-
-#define OptSaveHpLimRegister() \
- SAVE_HpLim = HpLim
-#define OptRestoreHpLimRegister() \
- HpLim = SAVE_HpLim
-
-#else /* ! LIFE_PROFILE */
-
-#define OptSaveHpLimRegister() /* nothing */
-#define OptRestoreHpLimRegister() /* nothing */
-
-#endif /* ! LIFE_PROFILE */
-\end{code}
-
The real business (defining Integer primops):
\begin{code}
#define negateIntegerZh(ar,sr,dr, liveness, aa,sa,da) \
|| alpha_TARGET_ARCH \
|| hppa1_1_TARGET_ARCH \
|| i386_TARGET_ARCH \
- || i486_TARGET_ARCH \
|| m68k_TARGET_ARCH \
|| mipsel_TARGET_ARCH \
|| mipseb_TARGET_ARCH \
- || rs6000_TARGET_ARCH
+ || powerpc_TARGET_ARCH
/* yes, it is IEEE floating point */
#include "ieee-flpt.h"
#if alpha_dec_osf1_TARGET \
|| i386_TARGET_ARCH \
- || i486_TARGET_ARCH \
|| mipsel_TARGET_ARCH
#undef BIGENDIAN /* little-endian weirdos... */
\begin{code}
#if alpha_TARGET_ARCH \
|| i386_TARGET_ARCH \
- || i486_TARGET_ARCH \
|| m68k_TARGET_ARCH
#define ASSIGN_FLT(dst, src) *(StgFloat *)(dst) = (src);
OK, the easy ops first: (all except \tr{newArr*}:
-VERY IMPORTANT! The read/write/index primitive ops
+(OLD:) VERY IMPORTANT! The read/write/index primitive ops
on @ByteArray#@s index the array using a {\em BYTE} offset, even
if the thing begin gotten out is a multi-byte @Int#@, @Float#@ etc.
This is because you might be trying to take apart a C struct, where
the offset from the start of the struct isn't a multiple of the
size of the thing you're getting. Hence the @(char *)@ casts.
+EVEN MORE IMPORTANT! The above is a lie. The offsets for BlahArrays
+are in Blahs. WDP 95/08
+
In the case of messing with @StgAddrs@ (@A_@), which are really \tr{void *},
we cast to @P_@, because you can't index off an uncast \tr{void *}.
for (p = result+MUTUPLE_HS; p < (result+MUTUPLE_HS+(n)); p++) { \
*p = (W_) (init); \
} \
- SET_ACTIVITY(ACT_REDN); /* back to normal reduction */\
\
r = result; \
}
void unblockUserSignals(STG_NO_ARGS);
IF_RTS(void blockVtAlrmSignal(STG_NO_ARGS);)
IF_RTS(void unblockVtAlrmSignal(STG_NO_ARGS);)
+IF_RTS(void AwaitEvent(I_ delta);)
#ifdef _POSIX_SOURCE
extern I_ sig_install PROTO((I_, I_, sigset_t *));
IF_RTS(I_ getSoftHeapOverflowHandler(STG_NO_ARGS);)
IF_RTS(extern StgStablePtr softHeapOverflowHandler;)
IF_RTS(void shutdownHaskell(STG_NO_ARGS);)
-IF_RTS(extern I_ noBlackHoles;)
-IF_RTS(extern I_ SM_word_stk_size;)
EXTFUN(stopPerformIODirectReturn);
EXTFUN(startPerformIO);
if (SHOULD_SPARK(node) && \
PendingSparksTl[ADVISORY_POOL] < PendingSparksLim[ADVISORY_POOL]) { \
*PendingSparksTl[ADVISORY_POOL]++ = (P_)(node); \
- } else if (DO_QP_PROF) { \
- I_ tid = threadId++; \
- SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
+ } else { \
+ sparksIgnored++; \
+ if (DO_QP_PROF) { \
+ I_ tid = threadId++; \
+ SAFESTGCALL2(void,(I_, P_),QP_Event0,tid,node); \
+ } \
} \
r = 1; /* Should not be necessary */ \
}
Question: what's this "SET_ACTIVITY" stuff - should I be doing this
too? (It's if you want to use the SPAT profiling tools to
characterize program behavior by ``activity'' -- tail-calling,
-heap-checking, etc. -- see RednCounts.lh. It is quite specialized.
+heap-checking, etc. -- see Ticky.lh. It is quite specialized.
WDP 95/1)
\begin{code}
/* Keep -Wmissing-prototypes from complaining */
void SaveAllStgRegs(STG_NO_ARGS);
+#if i386_TARGET_ARCH
+void SaveAllStgContext(void * /*return address*/);
+#else
void SaveAllStgContext(STG_NO_ARGS);
+#endif
void SaveStgStackRegs(STG_NO_ARGS);
void RestoreAllStgRegs(STG_NO_ARGS);
void RestoreStackStgRegs(STG_NO_ARGS);
extern STG_INLINE
void SaveAllStgRegs(STG_NO_ARGS)
{
+#ifdef REG_Base
+# ifdef CONCURRENT
+ /* I do not think so: CurrentRegTable will not have changed
+ between entry to and exit from "Haskell land" (WDP 95/12)
+ */
+ /* CurrentRegTable = BaseReg; */
+# endif
+#endif
+
#ifdef REG_R1
SAVE_R1 = R1;
#endif
SAVE_Hp = Hp; /* always! */
SAVE_HpLim = HpLim; /* ditto! */
-
-#if defined(DO_INSTR_COUNTING)
-#ifdef REG_Activity
- SAVE_Activity = ActivityReg;
-#endif
-#endif
}
extern STG_INLINE
-void SaveAllStgContext(STG_NO_ARGS)
+void
+#if i386_TARGET_ARCH
+SaveAllStgContext(void * ret_addr)
+#else
+SaveAllStgContext(STG_NO_ARGS)
+#endif
{
SaveAllStgRegs();
#ifdef CONCURRENT
+# ifdef PAR
TSO_CCC(CurrentTSO) = CCC;
CCC = (CostCentre)STATIC_CC_REF(CC_MAIN);
+# endif
+# if i386_TARGET_ARCH
+ SET_RETADDR(TSO_PC2(CurrentTSO), ret_addr)
+# else
SET_RETADDR(TSO_PC2(CurrentTSO))
+# endif
#endif
}
{
#ifdef REG_Base
/* Re-initialise the register table pointer */
+# ifdef CONCURRENT
+ BaseReg = CurrentRegTable;
+# else
BaseReg = &MainRegTable;
+# endif
#endif
#ifdef REG_R1
StkStubReg = STK_STUB_closure;
#endif
-#if defined(DO_INSTR_COUNTING) && defined(REG_Activity)
- ActivityReg = SAVE_Activity;
-#endif
-
-#ifdef CONCURRENT
+#ifdef PAR
CCC = TSO_CCC(CurrentTSO);
#endif
}
\begin{code}
-#include "rtsTypes.h"
+#include "RtsTypes.h"
#endif /* ! STGTYPES_H */
\end{code}
#else
-#define DEFAULT_MAX_THREADS (32)
-
extern I_ do_gr_sim; /* Are we simulating granularity? */
extern FILE *gr_file;
#define DO_QP_PROF do_qp_prof
#endif
-extern I_ MaxThreads;
-
extern I_ context_switch; /* Flag set by signal handler */
-extern I_ contextSwitchTime;
-#if defined(USE_COST_CENTRES) || defined(GUM)
-extern I_ contextSwitchTicks;
-#endif
-#define CS_MAX_FREQUENCY 100 /* context switches per second */
-#define CS_MIN_MILLISECS (1000/CS_MAX_FREQUENCY) /* milliseconds per slice */
+#define CS_MAX_FREQUENCY 100 /* context switches per second */
+#define CS_MIN_MILLISECS (1000/CS_MAX_FREQUENCY)/* milliseconds per slice */
#ifdef __STG_GCC_REGS__
#define OR_CONTEXT_SWITCH || context_switch
extern P_ RunnableThreadsHd, RunnableThreadsTl;
extern P_ WaitingThreadsHd, WaitingThreadsTl;
-#define DEFAULT_MAX_LOCAL_SPARKS 100
-
-extern I_ MaxLocalSparks;
+extern I_ sparksIgnored;
IF_RTS(extern void AwaitEvent(I_);)
extern I_ nUPDs, nUPDs_old, nUPDs_new, nUPDs_BQ, nPAPs, BQ_lens;
#endif
-extern I_ do_gr_binary;
-extern I_ do_gr_profile;
extern I_ no_gr_profile;
extern I_ do_sp_profile;
extern I_ GranSimFetch PROTO((P_));
extern void GranSimExec PROTO((W_,W_,W_,W_,W_));
extern void GranSimSpark PROTO((W_,P_));
-extern void GranSimBlock PROTO(());
+extern void GranSimBlock (STG_NO_ARGS);
extern void PerformReschedule PROTO((W_, W_));
#if 0 /* 'ngo Dochmey */
\begin{code}
#define TSO_INFO_WORDS 10
-#ifdef DO_REDN_COUNTING
+#ifdef TICKY_TICKY
#define TSO_REDN_WORDS 2
#else
#define TSO_REDN_WORDS 0
#define TSO_SWITCH_LOCN (TSO_INFO_START + 9)
#define TSO_REDN_START (TSO_INFO_START + TSO_INFO_WORDS)
-#ifdef DO_REDN_COUNTING
+#ifdef TICKY_TICKY
#define TSO_AHWM_LOCN (TSO_REDN_START + 0)
#define TSO_BHWM_LOCN (TSO_REDN_START + 1)
#endif
The total space required to start a new thread (See NewThread in
Threads.lc):
\begin{code}
-#define THREAD_SPACE_REQUIRED (TSO_HS + TSO_CTS_SIZE + STKO_HS + StkOChunkSize)
+#define THREAD_SPACE_REQUIRED (TSO_HS + TSO_CTS_SIZE + STKO_HS + RTSflags.ConcFlags.stkChunkSize)
\end{code}
Here are the various queues for GrAnSim-type events.
%************************************************************************
\begin{code}
-#ifdef GUM
+#ifdef PAR
P_ FindLocalSpark PROTO((rtsBool forexport));
void DisposeSpark PROTO((P_ spark));
rtsBool Spark PROTO((P_ closure, rtsBool required));
-#endif /*GUM*/
+#endif /*PAR*/
#ifdef GRAN /* For GrAnSim sparks are currently mallocated -- HWL */
objects.
\begin{code}
-#ifdef DO_REDN_COUNTING
+#ifdef TICKY_TICKY
#define STKO_VHS (GC_MUT_RESERVED_WORDS + 9)
#else
#define STKO_VHS (GC_MUT_RESERVED_WORDS + 7)
#endif
#define STKO_HS (FIXED_HS + STKO_VHS)
-#define DEFAULT_STKO_CHUNK_SIZE 1024
-
#define MIN_STKO_CHUNK_SIZE 16 /* Rather arbitrary */
-extern I_ StkOChunkSize;
-
#define STKO_CLOSURE_SIZE(closure) STKO_SIZE(closure)
#define STKO_CLOSURE_CTS_SIZE(closure) (STKO_CLOSURE_SIZE(closure) - STKO_VHS)
to debug things.
*/
-#ifdef DO_REDN_COUNTING
+#ifdef TICKY_TICKY
#define STKO_ADEP_LOCN (STKO_HS - 9)
#define STKO_BDEP_LOCN (STKO_HS - 8)
#endif
INCLUDE_TYPE_INFO(STKO_STATIC) \
INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(_Evacuate_Static,_Scavenge_Static) \
+ INCLUDE_COPYING_INFO(_Evacuate_Static,_Dummy_Static_entry) \
INCLUDE_COMPACTING_INFO(_Dummy_Static_entry,_PRStart_Static, \
_Dummy_Static_entry,_PRIn_Error) \
}
%
%************************************************************************
%* *
-\section[RednCounts.lh]{Interface (and macros) for reduction-count statistics}
+\section[Ticky.lh]{Interface (and macros) for reduction-count statistics}
%* *
%************************************************************************
Multi-slurp protection:
\begin{code}
-#ifndef REDNCOUNTS_H
-#define REDNCOUNTS_H
+#ifndef TICKY_H
+#define TICKY_H
\end{code}
There are macros in here for:
\begin{enumerate}
\item
-``SPAT-profiling'' (\tr{DO_SPAT_PROFILING}), counting instructions
-per ``activity,'' using the SPAT instruction-trace analysis tools.
-\item
-``Ticky-ticky profiling'' (\tr{DO_REDN_COUNTING}), counting the
+``Ticky-ticky profiling'' (\tr{TICKY_TICKY}), counting the
number of various STG-events (updates, enters, etc.)
-This file goes with \tr{RednCounts.lc}, which initialises the counters
+This file goes with \tr{Ticky.lc}, which initialises the counters
and does the printing [ticky-ticky only].
%************************************************************************
%* *
-\subsection[SPAT-macros]{Macros for SPAT instruction counting}
+\subsection{Macros for using the `ticky' field in the fixed header}
%* *
%************************************************************************
-These definitions are for instruction tracing, e.g. using SPAT on the
-SPARC.
+\begin{code}
+#define TICKY_FIXED_HDR (TICKY_HDR_SIZE)
+#define TICKY_HDR_POSN AFTER_PROF_HDR
+#define AFTER_TICKY_HDR (TICKY_FIXED_HDR+TICKY_HDR_POSN)
+\end{code}
\begin{code}
-#ifdef DO_SPAT_PROFILING
-
-#define ACT_BASE 0x000000ab /* random; to fit in 13 bits */
-
-#define ACT_UNKNOWN (0+ACT_BASE)
-#define ACT_GC (1+ACT_BASE)
-#define ACT_REDN (2+ACT_BASE)
-#define ACT_ASTK_STUB (3+ACT_BASE)
-#define ACT_FILL_IN_HEAP (4+ACT_BASE)
-#define ACT_HEAP_CHK (5+ACT_BASE)
-#define ACT_RETURN (6+ACT_BASE)
-#define ACT_UPDATE (7+ACT_BASE)
-#define ACT_PUSH_UPDF (8+ACT_BASE)
-#define ACT_ARGS_CHK (9+ACT_BASE)
-#define ACT_UPDATE_PAP (10+ACT_BASE)
-#define ACT_INDIRECT (11+ACT_BASE)
-#define ACT_PRIM (12+ACT_BASE)
-
-#define ACT_OVERHEAD (14+ACT_BASE) /* only used in analyser */
-#define ACT_TAILCALL (15+ACT_BASE)
- /* Note: quite a lot gets lumped under TAILCALL; the analyser
- untangles it with other info. WDP 95/01
- */
-
-#define ACTIVITIES 16
-
-#define ACT_GC_STOP (ACTIVITIES+1)
-#define ACT_PRIM_STOP (ACTIVITIES+2)
-
-/* values that "signal" the start/stop of something,
- thus suggesting to the analyser that it stop/start something.
-
- I do not think they are used (WDP 95/01)
-*/
+#ifndef TICKY_TICKY
-#define ACT_SIGNAL_BASE 0xbababa00 /* pretty random; yes */
-
-#define ACT_START_GOING (1+ACT_SIGNAL_BASE)
-#define ACT_STOP_GOING (2+ACT_SIGNAL_BASE)
-#define ACT_START_GC (3+ACT_SIGNAL_BASE)
-#define ACT_STOP_GC (4+ACT_SIGNAL_BASE)
-
-#define SET_ACTIVITY(act) do { /* ActivityReg = (act) */ \
- __asm__ volatile ("or %%g0,%1,%0" \
- : "=r" (ActivityReg) \
- : "I" (act)); \
- } while(0)
-
-#define ALLOC_HEAP(n) /* nothing */
-#define UN_ALLOC_HEAP(n) /* nothing */
-#define DO_ASTK_HWM() /* nothing */
-#define DO_BSTK_HWM() /* nothing */
-
-#define A_STK_STUB(n) /* nothing */
-#define A_STK_REUSE(n) /* not used at all */
-#define B_STK_REUSE(n) /* ditto */
-
-#define ALLOC_FUN(a,g,s,t) SET_ACTIVITY(ACT_FILL_IN_HEAP)
-#define ALLOC_THK(a,g,s,t) SET_ACTIVITY(ACT_FILL_IN_HEAP)
-#define ALLOC_CON(a,g,s,t) SET_ACTIVITY(ACT_FILL_IN_HEAP)
-#define ALLOC_TUP(a,g,s,t) SET_ACTIVITY(ACT_FILL_IN_HEAP)
-#define ALLOC_BH(a,g,s,t) SET_ACTIVITY(ACT_FILL_IN_HEAP)
-/*#define ALLOC_PAP(a,g,s,t) SET_ACTIVITY(ACT_FILL_IN_HEAP)*/
-#define ALLOC_UPD_PAP(a,g,s,t) SET_ACTIVITY(ACT_UPDATE_PAP) /* NB */
-/*#define ALLOC_UPD_CON(a,g,s,t) SET_ACTIVITY(ACT_FILL_IN_HEAP) */
-#define ALLOC_PRIM(a,g,s,t) SET_ACTIVITY(ACT_FILL_IN_HEAP)
-#define ALLOC_PRIM2(w) SET_ACTIVITY(ACT_FILL_IN_HEAP)
-#define ALLOC_STK(a,g,s) SET_ACTIVITY(ACT_FILL_IN_HEAP)
-#define ALLOC_TSO(a,g,s) SET_ACTIVITY(ACT_FILL_IN_HEAP)
-#define ALLOC_FMBQ(a,g,s) SET_ACTIVITY(ACT_FILL_IN_HEAP)
-#define ALLOC_FME(a,g,s) SET_ACTIVITY(ACT_FILL_IN_HEAP)
-#define ALLOC_BF(a,g,s) SET_ACTIVITY(ACT_FILL_IN_HEAP)
-
-/* we only use the ENT_ macros to be sure activity is set to "reduction" */
-#define ENT_VIA_NODE() /* nothing */
-#define ENT_THK() SET_ACTIVITY(ACT_REDN)
-#define ENT_FUN_STD() SET_ACTIVITY(ACT_REDN)
-#define ENT_FUN_DIRECT(f,f_str,f_arity,Aargs,Bargs,arg_kinds,wrap,wrap_kinds) \
- SET_ACTIVITY(ACT_REDN)
-#define ENT_CON(n) SET_ACTIVITY(ACT_REDN)
-#define ENT_IND(n) SET_ACTIVITY(ACT_REDN)
-#define ENT_PAP(n) SET_ACTIVITY(ACT_UPDATE_PAP) /* NB */
-
-#define RET_NEW_IN_HEAP() SET_ACTIVITY(ACT_RETURN)
-#define RET_NEW_IN_REGS() SET_ACTIVITY(ACT_RETURN)
-#define RET_OLD_IN_HEAP() SET_ACTIVITY(ACT_RETURN)
-#define RET_OLD_IN_REGS() SET_ACTIVITY(ACT_RETURN)
-#define RET_SEMI_BY_DEFAULT() SET_ACTIVITY(ACT_RETURN)
-#define RET_SEMI_IN_HEAP() SET_ACTIVITY(ACT_RETURN)
-#define RET_SEMI_IN_REGS() SET_ACTIVITY(ACT_RETURN)
-#define VEC_RETURN() /* nothing */
-
-#define UPDF_OMITTED() /* nothing (set directly by PUSH_STD_UPD_FRAME) */
-#define UPDF_STD_PUSHED() SET_ACTIVITY(ACT_PUSH_UPDF)
-#define UPDF_CON_PUSHED() /* nothing */
-#define UPDF_HOLE_PUSHED() /* nothing */
-#define UPDF_RCC_PUSHED() /* nothing */
-#define UPDF_RCC_OMITTED() /* nothing */
+#define TICKY_HDR_SIZE 0
+#define TICKY_HDR(closure)
+#define SET_TICKY_HDR(closure,to)
+#define SET_STATIC_TICKY_HDR()
+
+#else
+
+#define TICKY_HDR_SIZE 1
+#define TICKY_HDR(closure) (((P_)(closure))[TICKY_HDR_POSN])
+#define SET_TICKY_HDR(closure,to) TICKY_HDR(closure) = (to)
+#define SET_STATIC_TICKY_HDR() ,0
-#define UPD_EXISTING() /* nothing -- used in .lc code */
-#define UPD_CON_W_NODE() SET_ACTIVITY(ACT_UPDATE)
-#define UPD_CON_IN_PLACE() SET_ACTIVITY(ACT_UPDATE)
-#define UPD_PAP_IN_PLACE() /* nothing -- UpdatePAP has its own activity */
-#define UPD_CON_IN_NEW() SET_ACTIVITY(ACT_UPDATE)
-#define UPD_PAP_IN_NEW() /* nothing -- UpdatePAP has its own activity */
+#endif /* TICKY_TICKY */
\end{code}
-For special subsequent enter counting:
+Here, we add the Ticky word to the fixed-header part of closures.
+This is used to record indicate if a closure has been updated but not
+yet entered. It is set when the closure is updated and cleared when
+subsequently entered.
+
+NB: It is {\em not} an ``entry count'', it is an
+``entries-after-update count.''
+
+The commoning up of @CONST@, @CHARLIKE@ and @INTLIKE@ closures is
+turned off(?) if this is required. This has only been done for 2s
+collection. It is done using a nasty hack which defines the
+@_Evacuate@ and @_Scavenge@ code for @CONST@, @CHARLIKE@ and @INTLIKE@
+info tables to be @_Evacuate_1@ and @_Scavenge_1_0@.
+
\begin{code}
+#ifndef TICKY_TICKY
+
#define UPDATED_SET_UPDATED(n) /* nothing */
#define ENTERED_CHECK_UPDATED(n) /* nothing */
-\end{code}
-For a generational collector:
-\begin{code}
-#define UPD_NEW_IND() /* nothing (set elsewhere [?]) */
-#define UPD_NEW_IN_PLACE_PTRS() /* nothing */
-#define UPD_NEW_IN_PLACE_NOPTRS() /* nothing */
-#define UPD_OLD_IND() /* nothing */
-#define UPD_OLD_IN_PLACE_PTRS() /* nothing */
-#define UPD_OLD_IN_PLACE_NOPTRS() /* nothing */
+#else
+
+#define UPDATED_SET_UPDATED(n) do { TICKY_HDR(n) = 1; } while(0)
+
+#define ENT_UPD_HISTO(n) \
+ do { I_ __idx; \
+ __idx = (n) - 1; \
+ \
+ /* once 9th enter is recorded, we do not tick anymore;*/\
+ /* we want "TotUpdates - <all 9 cols>" to equal */ \
+ /* "updates that were never entered" */ \
+ if ( __idx <= 8 ) \
+ UPD_ENTERED_hst[__idx] += 1; \
+ \
+ /* now undo tick in previous histo slot ... */ \
+ if ( __idx >= 1 && __idx <= 8 ) \
+ UPD_ENTERED_hst[(__idx - 1)] -= 1; \
+ } while(0)
+
+#define ENTERED_CHECK_UPDATED(n) \
+ do { \
+ I_ t_hdr = TICKY_HDR(n); \
+ \
+ if (t_hdr != 0 && AllFlags.doUpdEntryCounts) { \
+ ENT_UPD_HISTO(t_hdr); \
+ TICKY_HDR(n) += 1; \
+ }} while(0)
-#endif /* DO_SPAT_PROFILING */
+#endif /* TICKY_TICKY */
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-#ifdef DO_REDN_COUNTING
-
-#define SET_ACTIVITY(act) /* quickly: make this do NOTHING */
+#ifdef TICKY_TICKY
\end{code}
Measure what proportion of ...:
\end{display}
\begin{code}
-#define RET_NEW_IN_HEAP() RET_NEW_IN_HEAP_ctr++
-#define RET_OLD_IN_HEAP() RET_OLD_IN_HEAP_ctr++
+#define RET_HISTO(categ,n,offset) \
+ { I_ __idx; \
+ __idx = (n) - (offset); \
+ CAT3(RET_,categ,_hst)[((__idx > 8) ? 8 : __idx)] += 1;}
-#define RET_NEW_IN_REGS() RET_NEW_IN_REGS_ctr++; \
- ReturnInRegsNodeValid = 0
-#define RET_OLD_IN_REGS() RET_OLD_IN_REGS_ctr++; \
- ReturnInRegsNodeValid = 1
+/* "slide" histogramming by (__STG_REGS_AVAIL__ - 1) -- usually 7 --
+ so we do not collect lots and lots of useless zeros for _IN_HEAP.
+ WDP 95/11
+*/
+#define RET_NEW_IN_HEAP(n) RET_NEW_IN_HEAP_ctr++; \
+ RET_HISTO(NEW_IN_HEAP,n,__STG_REGS_AVAIL__ - 1)
+#define RET_OLD_IN_HEAP(n) RET_OLD_IN_HEAP_ctr++; \
+ RET_HISTO(OLD_IN_HEAP,n,__STG_REGS_AVAIL__ - 1)
+#define RET_SEMI_IN_HEAP(n) RET_SEMI_IN_HEAP_ctr++; \
+ RET_HISTO(SEMI_IN_HEAP,n,__STG_REGS_AVAIL__ - 1)
+
+#define RET_NEW_IN_REGS(n) RET_NEW_IN_REGS_ctr++; \
+ ReturnInRegsNodeValid = 0; \
+ RET_HISTO(NEW_IN_REGS,n,0)
+#define RET_OLD_IN_REGS(n) RET_OLD_IN_REGS_ctr++; \
+ ReturnInRegsNodeValid = 1; \
+ RET_HISTO(OLD_IN_REGS,n,0)
+#define RET_SEMI_IN_REGS(n,u) RET_SEMI_IN_REGS_ctr++; \
+ RET_SEMI_loads_avoided += ((n) - (u)); \
+ RET_HISTO(SEMI_IN_REGS,u,0)
+
+#define RET_SEMI_BY_DEFAULT()/*???*/ RET_SEMI_BY_DEFAULT_ctr++
+
+#define RET_SEMI_FAILED(tag) do { \
+ if ((tag) == INFO_IND_TAG) \
+ RET_SEMI_FAILED_IND_ctr++; \
+ else \
+ RET_SEMI_FAILED_UNEVAL_ctr++; \
+ } while (0)
-#define RET_SEMI_BY_DEFAULT() RET_SEMI_BY_DEFAULT_ctr++
-#define RET_SEMI_IN_HEAP() RET_SEMI_IN_HEAP_ctr++
-#define RET_SEMI_IN_REGS() RET_SEMI_IN_REGS_ctr++
\end{code}
Of all the returns (sum of four categories above), how many were
vectored? (The rest were obviously unvectored).
\begin{code}
-#define VEC_RETURN() VEC_RETURN_ctr++
+#define VEC_RETURN(n) VEC_RETURN_ctr++; \
+ RET_HISTO(VEC_RETURN,n,0)
\end{code}
%************************************************************************
& \\
\tr{UPD_EXISTING} & Updating with an indirection to something \\
& already in the heap \\
-
+\tr{UPD_SQUEEZED} & Same as \tr{UPD_EXISTING} but because \\
+ & of stack-squeezing \\
\tr{UPD_CON_W_NODE} & Updating with a CON: by indirecting to Node \\
-
\tr{UPD_CON_IN_PLACE} & Ditto, but in place \\
\tr{UPD_CON_IN_NEW} & Ditto, but allocating the object \\
-
\tr{UPD_PAP_IN_PLACE} & Same, but updating w/ a PAP \\
\tr{UPD_PAP_IN_NEW} & \\\hline
\end{tabular}
%partain:\end{center}
\begin{code}
+#define UPD_HISTO(categ,n) \
+ { I_ __idx; \
+ __idx = (n); \
+ CAT3(UPD_,categ,_hst)[((__idx > 8) ? 8 : __idx)] += 1;}
+
#define UPD_EXISTING() UPD_EXISTING_ctr++
+#define UPD_SQUEEZED() UPD_SQUEEZED_ctr++
#define UPD_CON_W_NODE() UPD_CON_W_NODE_ctr++
-#define UPD_CON_IN_NEW() UPD_CON_IN_NEW_ctr++
-#define UPD_PAP_IN_NEW() UPD_PAP_IN_NEW_ctr++
+#define UPD_CON_IN_NEW(n) UPD_CON_IN_NEW_ctr++ ; \
+ UPD_HISTO(CON_IN_NEW,n)
+#define UPD_PAP_IN_NEW(n) UPD_PAP_IN_NEW_ctr++ ; \
+ UPD_HISTO(PAP_IN_NEW,n)
/* ToDo: UPD_NEW_COPY_ctr, as below */
-#define UPD_CON_IN_PLACE() UPD_CON_IN_PLACE_ctr++ ; \
- UPD_IN_PLACE_COPY_ctr += ReturnInRegsNodeValid
- /* increments if True; otherwise, no */
+#define UPD_CON_IN_PLACE(n) UPD_CON_IN_PLACE_ctr++ ; \
+ UPD_IN_PLACE_COPY_ctr += ReturnInRegsNodeValid ; \
+ /* increments if True; otherwise, no */ \
+ UPD_HISTO(CON_IN_PLACE,n)
#define UPD_PAP_IN_PLACE() UPD_PAP_IN_PLACE_ctr++ ; \
UPD_IN_PLACE_COPY_ctr += ReturnInRegsNodeValid
/* increments if True; otherwise, no */
%************************************************************************
%* *
-\subsubsection[ticky-updates-entered]{Updates Subsequently Entered}
+\subsubsection[ticky-selectors]{Doing selectors at GC time}
%* *
%************************************************************************
-If @UPDATES_ENTERED_COUNT@ is defined we add the Age word to the
-closures. This is used to record indicate if a closure has been
-updated but not yet entered. It is set when the closure is updated and
-cleared when subsequently entered.
-
-The commoning up of @CONST@, @CHARLIKE@ and @INTLIKE@ closures is
-turned if this is required. This has only been done for 2s collection.
-It is done using a nasty hack which defines the @_Evacuate@ and
-@_Scavenge@ code for @CONST@, @CHARLIKE@ and @INTLIKE@ info tables to
-be @_Evacuate_1@ and @_Scavenge_1_0@.
-
-Unfortunately this broke everything so it has not been done ;-(.
-Instead we have to run with enough heap so no garbage collection is
-needed for accurate numbers. ToDo: Fix this!
-
-As implemented it can not be used in conjunction with heap profiling
-or lifetime profiling becasue they make conflicting use the Age word!
+@GC_SEL_ABANDONED@: we could've done the selection, but we gave up
+(e.g., to avoid overflowing the C stack); @GC_SEL_MINOR@: did a
+selection in a minor GC; @GC_SEL_MAJOR@: ditto, but major GC.
\begin{code}
-#if defined(UPDATES_ENTERED_COUNT)
-
-#define UPDATED_SET_UPDATED(n) AGE_HDR(n) = 1
-
-#define ENTERED_CHECK_UPDATED(n) \
- if (AGE_HDR(n)) { \
- if (AGE_HDR(n) == 1) { \
- UPD_ENTERED_ctr++; \
- AGE_HDR(n) += 1; \
- } else { \
- UPD_ENTERED_AGAIN_ctr++; \
- AGE_HDR(n) = 0; \
- }}
-
-#else /* ! UPDATES_ENTERED_COUNT */
-
-#define UPDATED_SET_UPDATED(n) /* nothing */
-#define ENTERED_CHECK_UPDATED(n) /* nothing */
-
-#endif /* ! UPDATES_ENTERED_COUNT */
+#define GC_SEL_ABANDONED() GC_SEL_ABANDONED_ctr++;
+#define GC_SEL_MINOR() GC_SEL_MINOR_ctr++;
+#define GC_SEL_MAJOR() GC_SEL_MAJOR_ctr++;
+
+#define GC_SHORT_IND() GC_SHORT_IND_ctr++;
+#define GC_SHORT_CAF() GC_SHORT_CAF_ctr++;
+#define GC_COMMON_CHARLIKE() GC_COMMON_CHARLIKE_ctr++;
+#define GC_COMMON_INTLIKE() GC_COMMON_INTLIKE_ctr++;
+#define GC_COMMON_INTLIKE_FAIL() GC_COMMON_INTLIKE_FAIL_ctr++;
+#define GC_COMMON_CONST() GC_COMMON_CONST_ctr++;
\end{code}
%************************************************************************
extern I_ ENT_PAP_ctr;
extern I_ ENT_THK_ctr;
-extern I_ UPD_ENTERED_ctr;
-extern I_ UPD_ENTERED_AGAIN_ctr;
+extern I_ UPD_ENTERED_hst[9];
extern I_ RET_NEW_IN_HEAP_ctr;
extern I_ RET_NEW_IN_REGS_ctr;
extern I_ RET_SEMI_IN_REGS_ctr;
extern I_ VEC_RETURN_ctr;
+extern I_ RET_SEMI_FAILED_IND_ctr;
+extern I_ RET_SEMI_FAILED_UNEVAL_ctr;
+
+extern I_ RET_SEMI_loads_avoided;
+
+extern I_ RET_NEW_IN_HEAP_hst[9];
+extern I_ RET_NEW_IN_REGS_hst[9];
+extern I_ RET_OLD_IN_HEAP_hst[9];
+extern I_ RET_OLD_IN_REGS_hst[9];
+/*no such thing: extern I_ RET_SEMI_BY_DEFAULT_hst[9]; */
+extern I_ RET_SEMI_IN_HEAP_hst[9];
+extern I_ RET_SEMI_IN_REGS_hst[9];
+extern I_ RET_VEC_RETURN_hst[9];
+
extern I_ ReturnInRegsNodeValid; /* see below */
extern I_ UPDF_OMITTED_ctr;
extern I_ UPDF_RCC_OMITTED_ctr;
extern I_ UPD_EXISTING_ctr;
+extern I_ UPD_SQUEEZED_ctr;
extern I_ UPD_CON_W_NODE_ctr;
extern I_ UPD_CON_IN_PLACE_ctr;
extern I_ UPD_PAP_IN_PLACE_ctr;
extern I_ UPD_CON_IN_NEW_ctr;
extern I_ UPD_PAP_IN_NEW_ctr;
+extern I_ UPD_CON_IN_PLACE_hst[9];
+extern I_ UPD_CON_IN_NEW_hst[9];
+extern I_ UPD_PAP_IN_NEW_hst[9];
+
extern I_ UPD_NEW_IND_ctr;
extern I_ UPD_NEW_IN_PLACE_PTRS_ctr;
extern I_ UPD_NEW_IN_PLACE_NOPTRS_ctr;
extern I_ UPD_IN_PLACE_COPY_ctr; /* see below */
-#endif /* DO_REDN_COUNTING */
+extern I_ GC_SEL_ABANDONED_ctr;
+extern I_ GC_SEL_MINOR_ctr;
+extern I_ GC_SEL_MAJOR_ctr;
+extern I_ GC_SHORT_IND_ctr;
+extern I_ GC_SHORT_CAF_ctr;
+extern I_ GC_COMMON_CHARLIKE_ctr;
+extern I_ GC_COMMON_INTLIKE_ctr;
+extern I_ GC_COMMON_INTLIKE_FAIL_ctr;
+extern I_ GC_COMMON_CONST_ctr;
+
+#endif /* TICKY_TICKY */
\end{code}
%************************************************************************
%* *
-\subsection[RednCounts-nonmacros]{Un-macros for ``none of the above''}
+\subsection[Ticky-nonmacros]{Un-macros for ``none of the above''}
%* *
%************************************************************************
\begin{code}
-#if ! (defined(DO_SPAT_PROFILING) || defined(DO_REDN_COUNTING))
-
-#define SET_ACTIVITY(act) /* nothing */
+#ifndef TICKY_TICKY
#define ALLOC_HEAP(n) /* nothing */
#define UN_ALLOC_HEAP(n) /* nothing */
#define ENT_IND(n) /* nothing */
#define ENT_PAP(n) /* nothing */
-#define RET_NEW_IN_HEAP() /* nothing */
-#define RET_NEW_IN_REGS() /* nothing */
-#define RET_OLD_IN_HEAP() /* nothing */
-#define RET_OLD_IN_REGS() /* nothing */
+#define RET_NEW_IN_HEAP(n) /* nothing */
+#define RET_NEW_IN_REGS(n) /* nothing */
+#define RET_OLD_IN_HEAP(n) /* nothing */
+#define RET_OLD_IN_REGS(n) /* nothing */
#define RET_SEMI_BY_DEFAULT() /* nothing */
-#define RET_SEMI_IN_HEAP() /* nothing */
-#define RET_SEMI_IN_REGS() /* nothing */
-#define VEC_RETURN() /* nothing */
+#define RET_SEMI_IN_HEAP(n) /* nothing */
+#define RET_SEMI_IN_REGS(n,u) /* nothing */
+#define RET_SEMI_FAILED(t) /* nothing */
+#define VEC_RETURN(n) /* nothing */
#define UPDF_OMITTED() /* nothing */
#define UPDF_STD_PUSHED() /* nothing */
#define UPDF_RCC_OMITTED() /* nothing */
#define UPD_EXISTING() /* nothing */
+#define UPD_SQUEEZED() /* nothing */
#define UPD_CON_W_NODE() /* nothing */
-#define UPD_CON_IN_PLACE() /* nothing */
+#define UPD_CON_IN_PLACE(n) /* nothing */
#define UPD_PAP_IN_PLACE() /* nothing */
-#define UPD_CON_IN_NEW() /* nothing */
-#define UPD_PAP_IN_NEW() /* nothing */
-\end{code}
-
-For special subsequent enter counting:
-\begin{code}
-#define UPDATED_SET_UPDATED(n) /* nothing */
-#define ENTERED_CHECK_UPDATED(n) /* nothing */
+#define UPD_CON_IN_NEW(n) /* nothing */
+#define UPD_PAP_IN_NEW(n) /* nothing */
+
+#define GC_SEL_ABANDONED() /* nothing */
+#define GC_SEL_MINOR() /* nothing */
+#define GC_SEL_MAJOR() /* nothing */
+
+#define GC_SHORT_IND() /* nothing */
+#define GC_SHORT_CAF() /* nothing */
+#define GC_COMMON_CHARLIKE() /* nothing */
+#define GC_COMMON_INTLIKE() /* nothing */
+#define GC_COMMON_INTLIKE_FAIL()/* nothing */
+#define GC_COMMON_CONST() /* nothing */
\end{code}
For a generational collector:
End of file multi-slurp protection:
\begin{code}
-#endif /* ! REDNCOUNTS_H */
+#endif /* ! TICKY_H */
\end{code}
/* Our C Hackery stuff for Callbacks */
-typedef int KeyCode;
+typedef I_ KeyCode;
extern StgStablePtr cbackList;
-extern int genericRlCback ();
+extern I_ genericRlCback PROTO((I_, I_));
extern StgStablePtr haskellRlEntry;
-extern int current_narg, rl_return;
+extern I_ current_narg, rl_return;
extern KeyCode current_kc;
extern char* rl_prompt_hack;
#define OFFSET(table, x) ((StgUnion *) &(x) - (StgUnion *) (&table))
-#define OFFSET_Dbl1 OFFSET(MainRegTable, RTBL_Dbl1)
-#define OFFSET_Dbl2 OFFSET(MainRegTable, RTBL_Dbl2)
-#define OFFSET_Flt1 OFFSET(MainRegTable, RTBL_Flt1)
-#define OFFSET_Flt2 OFFSET(MainRegTable, RTBL_Flt2)
-#define OFFSET_Flt3 OFFSET(MainRegTable, RTBL_Flt3)
-#define OFFSET_Flt4 OFFSET(MainRegTable, RTBL_Flt4)
-#define OFFSET_R1 OFFSET(MainRegTable, RTBL_R1)
-#define OFFSET_R2 OFFSET(MainRegTable, RTBL_R2)
-#define OFFSET_R3 OFFSET(MainRegTable, RTBL_R3)
-#define OFFSET_R4 OFFSET(MainRegTable, RTBL_R4)
-#define OFFSET_R5 OFFSET(MainRegTable, RTBL_R5)
-#define OFFSET_R6 OFFSET(MainRegTable, RTBL_R6)
-#define OFFSET_R7 OFFSET(MainRegTable, RTBL_R7)
-#define OFFSET_R8 OFFSET(MainRegTable, RTBL_R8)
-#define OFFSET_SpA OFFSET(MainRegTable, RTBL_SpA)
-#define OFFSET_SuA OFFSET(MainRegTable, RTBL_SuA)
-#define OFFSET_SpB OFFSET(MainRegTable, RTBL_SpB)
-#define OFFSET_SuB OFFSET(MainRegTable, RTBL_SuB)
-#define OFFSET_Hp OFFSET(MainRegTable, RTBL_Hp)
-#define OFFSET_HpLim OFFSET(MainRegTable, RTBL_HpLim)
-#define OFFSET_Tag OFFSET(MainRegTable, RTBL_Tag)
-#define OFFSET_Ret OFFSET(MainRegTable, RTBL_Ret)
-#define OFFSET_Activity OFFSET(MainRegTable, RTBL_Activity)
-#define OFFSET_StkO OFFSET(MainRegTable, RTBL_StkO)
-#define OFFSET_Liveness OFFSET(MainRegTable, RTBL_Liveness)
+#define OFFSET_Dbl1 OFFSET(MainRegTable, MAIN_Dbl1)
+#define OFFSET_Dbl2 OFFSET(MainRegTable, MAIN_Dbl2)
+#define OFFSET_Flt1 OFFSET(MainRegTable, MAIN_Flt1)
+#define OFFSET_Flt2 OFFSET(MainRegTable, MAIN_Flt2)
+#define OFFSET_Flt3 OFFSET(MainRegTable, MAIN_Flt3)
+#define OFFSET_Flt4 OFFSET(MainRegTable, MAIN_Flt4)
+#define OFFSET_R1 OFFSET(MainRegTable, MAIN_R1)
+#define OFFSET_R2 OFFSET(MainRegTable, MAIN_R2)
+#define OFFSET_R3 OFFSET(MainRegTable, MAIN_R3)
+#define OFFSET_R4 OFFSET(MainRegTable, MAIN_R4)
+#define OFFSET_R5 OFFSET(MainRegTable, MAIN_R5)
+#define OFFSET_R6 OFFSET(MainRegTable, MAIN_R6)
+#define OFFSET_R7 OFFSET(MainRegTable, MAIN_R7)
+#define OFFSET_R8 OFFSET(MainRegTable, MAIN_R8)
+#define OFFSET_SpA OFFSET(MainRegTable, MAIN_SpA)
+#define OFFSET_SuA OFFSET(MainRegTable, MAIN_SuA)
+#define OFFSET_SpB OFFSET(MainRegTable, MAIN_SpB)
+#define OFFSET_SuB OFFSET(MainRegTable, MAIN_SuB)
+#define OFFSET_Hp OFFSET(MainRegTable, MAIN_Hp)
+#define OFFSET_HpLim OFFSET(MainRegTable, MAIN_HpLim)
+#define OFFSET_Tag OFFSET(MainRegTable, MAIN_Tag)
+#define OFFSET_Ret OFFSET(MainRegTable, MAIN_Ret)
+#define OFFSET_StkO OFFSET(MainRegTable, MAIN_StkO)
+#define OFFSET_Liveness OFFSET(MainRegTable, MAIN_Liveness)
#define SM_HP OFFSET(StorageMgrInfo, StorageMgrInfo.hp)
#define SM_HPLIM OFFSET(StorageMgrInfo, StorageMgrInfo.hplim)
printf("#define OFFSET_HpLim %d\n", OFFSET_HpLim);
printf("#define OFFSET_Tag %d\n", OFFSET_Tag);
printf("#define OFFSET_Ret %d\n", OFFSET_Ret);
- printf("#define OFFSET_Activity %d\n", OFFSET_Activity);
#ifdef CONCURRENT
printf("#define OFFSET_StkO %d\n", OFFSET_StkO);
printf("#define OFFSET_Liveness %d\n", OFFSET_Liveness);
#else
#define _POSIX_SOURCE 1
#define _POSIX_C_SOURCE 199301L
+/* Alphas set _POSIX_VERSION (unistd.h) */
+/* ditto _POSIX2_C_VERSION
+ _POSIX2_VERSION
+ _POSIX_4SOURCE
+*/
#include <unistd.h>
#include <signal.h>
#endif
/* macros to deal with stacks (no longer heap) growing in either dirn */
#include "StgDirections.h"
+/* declarations for all the runtime flags for the RTS */
+#ifdef IN_GHC_RTS
+#include "RtsFlags.h"
+#endif
+/* and those that are visible *everywhere* (RTS + Haskell code) */
+struct ALL_FLAGS {
+#ifdef TICKY_TICKY
+ W_ doUpdEntryCounts; /* if true, we cannot short-circuit Inds,
+ common-up {Int,Char}Likes or Consts
+ */
+#endif
+ W_ dummy_entry; /* so there is *something* in it... */
+};
+extern struct ALL_FLAGS AllFlags;
+
/* declarations for garbage collection routines */
#include "SMinterface.h"
#include "COptRegs.h"
#include "COptWraps.h"
-/* these will come into play if you use -DDO_RUNTIME_PROFILING (default: off) */
-#include "RednCounts.h"
+/* these will come into play if you use -DTICKY_TICKY (default: off) */
+#include "Ticky.h"
-extern hash_t hash_str PROTO((char *str));
-extern hash_t hash_fixed PROTO((char *data, I_ len));
-extern I_ decode PROTO((char *s));
+hash_t hash_str PROTO((char *str));
+hash_t hash_fixed PROTO((char *data, I_ len));
/* ullong (64bit) formatting */
char *ullong_format_string PROTO((ullong x, char *s, rtsBool with_commas));
#include "Threads.h"
#include "Parallel.h"
-/* Things will happen in here if the driver does -DUSE_COST_CENTRES */
+/* Things will happen in here if the driver does -DPROFILING */
#include "CostCentre.h"
-/* These will come into play if you use -DLIFE_PROFILE or -DHEAP_PROF_WITH_AGE */
-#include "AgeProfile.h"
-
-/* These will come into play if you use -DFORCE_GC */
-#include "Force_GC.h"
-
/* GRAN and PAR stuff */
#include "GranSim.h"
-#if defined(USE_COST_CENTRES) || defined(CONCURRENT)
+#if defined(PROFILING) || defined(CONCURRENT)
char * time_str(STG_NO_ARGS);
#endif
/* hooks: user might write some of their own */
extern void ErrorHdrHook PROTO((FILE *));
-extern void OutOfHeapHook PROTO((W_, W_));
+extern void OutOfHeapHook PROTO((W_));
extern void StackOverflowHook PROTO((I_));
-extern void MallocFailHook PROTO((I_));
+extern void MallocFailHook PROTO((I_, char *));
extern void PatErrorHdrHook PROTO((FILE *));
extern void PreTraceHook PROTO((FILE *));
extern void PostTraceHook PROTO((FILE *));
#endif
extern char **prog_argv; /* from runtime/main/main.lc */
-extern I_ prog_argc;
+extern int prog_argc;
extern char **environ; /* we can get this one straight */
EXTDATA(STK_STUB_closure);
/* now these really *DO* need to be somewhere else... */
-extern char *time_str(STG_NO_ARGS);
-extern I_ stg_exit PROTO((I_));
-extern I_ _stg_rem PROTO((I_, I_));
+char *time_str(STG_NO_ARGS);
+I_ stg_exit PROTO((I_));
+I_ _stg_rem PROTO((I_, I_));
+char *stgMallocBytes PROTO((I_, char *));
+char *stgMallocWords PROTO((I_, char *));
/* definitions for closures */
#include "SMClosures.h"
StgInt createDirectory PROTO((StgByteArray));
/* env.lc */
-char * strdup PROTO((const char *));
+char * strdup PROTO((char *));
int setenviron PROTO((char **));
int copyenv (STG_NO_ARGS);
int setenv PROTO((char *));
StgInt getClockTime PROTO((StgByteArray, StgByteArray));
/* getCPUTime.lc */
-StgAddr getCPUTime(STG_NO_ARGS);
+StgByteArray getCPUTime PROTO((StgByteArray));
/* getCurrentDirectory.lc */
StgAddr getCurrentDirectory(STG_NO_ARGS);
StgInt setCurrentDirectory PROTO((StgByteArray));
/* showTime.lc */
-StgAddr showTime PROTO((StgInt, StgByteArray));
+StgAddr showTime PROTO((StgInt, StgByteArray, StgByteArray));
/* system.lc */
StgInt systemCmd PROTO((StgByteArray));
/* toLocalTime.lc */
-StgAddr toLocalTime PROTO((StgInt, StgByteArray));
+StgAddr toLocalTime PROTO((StgInt, StgByteArray, StgByteArray));
/* toUTCTime.lc */
-StgAddr toUTCTime PROTO((StgInt, StgByteArray));
+StgAddr toUTCTime PROTO((StgInt, StgByteArray, StgByteArray));
/* toClockSec.lc */
-StgAddr toClockSec PROTO((StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgInt));
+StgAddr toClockSec PROTO((StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgByteArray));
/* writeFile.lc */
StgInt writeFile PROTO((StgAddr, StgAddr, StgInt));
#endif
#if HAVE_TM_ZONE
-#define ZONE(x) (((struct tm *)x)->tm_zone)
-#define GMTOFF(x) (((struct tm *)x)->tm_gmtoff)
+#define ZONE(x) (((struct tm *)x)->tm_zone)
+#define SETZONE(x,z) (((struct tm *)x)->tm_zone = z)
+#define GMTOFF(x) (((struct tm *)x)->tm_gmtoff)
#else
#if HAVE_TZNAME
extern time_t timezone, altzone;
extern char *tmzone[2];
-#define ZONE(x) (((struct tm *)x)->tm_isdst ? tmzone[1] : tmzone[0])
-#define GMTOFF(x) (((struct tm *)x)->tm_isdst ? altzone : timezone)
+#define ZONE(x) (((struct tm *)x)->tm_isdst ? tmzone[1] : tmzone[0])
+#define SETZONE(x,z)
+#define GMTOFF(x) (((struct tm *)x)->tm_isdst ? altzone : timezone)
#endif
#endif
-#endif
\ No newline at end of file
+#endif
CAT2(blob,_HC_m) = $(CAT2(blob,_HS):.hs=_m.hc) @@\
CAT2(blob,_HC_n) = $(CAT2(blob,_HS):.hs=_n.hc) @@\
CAT2(blob,_HC_o) = $(CAT2(blob,_HS):.hs=_o.hc) @@\
+CAT2(blob,_HC_A) = $(CAT2(blob,_HS):.hs=_A.hc) @@\
+CAT2(blob,_HC_B) = $(CAT2(blob,_HS):.hs=_B.hc) @@\
@@\
CAT2(blob,_DEP_norm) = $(CAT2(blob,_HC_norm):.hc=.o) @@\
CAT2(blob,_DEP_p) = $(CAT2(blob,_HC_p):.hc=.o) @@\
CAT2(blob,_DEP_m) = $(CAT2(blob,_HC_m):.hc=.o) @@\
CAT2(blob,_DEP_n) = $(CAT2(blob,_HC_n):.hc=.o) @@\
CAT2(blob,_DEP_o) = $(CAT2(blob,_HC_o):.hc=.o) @@\
+CAT2(blob,_DEP_A) = $(CAT2(blob,_HC_A):.hc=.o) @@\
+CAT2(blob,_DEP_B) = $(CAT2(blob,_HC_B):.hc=.o) @@\
@@\
CAT2(blob,_HIs_p) = $(CAT2(blob,_HIs):.hi=_p.hi) @@\
CAT2(blob,_HIs_t) = $(CAT2(blob,_HIs):.hi=_t.hi) @@\
CAT2(blob,_HIs_l) = $(CAT2(blob,_HIs):.hi=_l.hi) @@\
CAT2(blob,_HIs_m) = $(CAT2(blob,_HIs):.hi=_m.hi) @@\
CAT2(blob,_HIs_n) = $(CAT2(blob,_HIs):.hi=_n.hi) @@\
-CAT2(blob,_HIs_o) = $(CAT2(blob,_HIs):.hi=_o.hi)
+CAT2(blob,_HIs_o) = $(CAT2(blob,_HIs):.hi=_o.hi) @@\
+CAT2(blob,_HIs_A) = $(CAT2(blob,_HIs):.hi=_A.hi) @@\
+CAT2(blob,_HIs_B) = $(CAT2(blob,_HIs):.hi=_B.hi)
#define PrintFileStuff(blob,outf) \
@echo 'IfGhcBuild_m(' CAT2(blob,_HC_m) = $(CAT2(blob,_HC_m)) ')' >> outf @@\
@echo 'IfGhcBuild_n(' CAT2(blob,_HC_n) = $(CAT2(blob,_HC_n)) ')' >> outf @@\
@echo 'IfGhcBuild_o(' CAT2(blob,_HC_o) = $(CAT2(blob,_HC_o)) ')' >> outf @@\
+ @echo 'IfGhcBuild_A(' CAT2(blob,_HC_A) = $(CAT2(blob,_HC_A)) ')' >> outf @@\
+ @echo 'IfGhcBuild_B(' CAT2(blob,_HC_B) = $(CAT2(blob,_HC_B)) ')' >> outf @@\
@echo 'IfGhcBuild_p(' CAT2(blob,_DEP_p) = $(CAT2(blob,_DEP_p)) ')' >> outf @@\
@echo 'IfGhcBuild_t(' CAT2(blob,_DEP_t) = $(CAT2(blob,_DEP_t)) ')' >> outf @@\
@echo 'IfGhcBuild_u(' CAT2(blob,_DEP_u) = $(CAT2(blob,_DEP_u)) ')' >> outf @@\
@echo 'IfGhcBuild_m(' CAT2(blob,_DEP_m) = $(CAT2(blob,_DEP_m)) ')' >> outf @@\
@echo 'IfGhcBuild_n(' CAT2(blob,_DEP_n) = $(CAT2(blob,_DEP_n)) ')' >> outf @@\
@echo 'IfGhcBuild_o(' CAT2(blob,_DEP_o) = $(CAT2(blob,_DEP_o)) ')' >> outf @@\
+ @echo 'IfGhcBuild_A(' CAT2(blob,_DEP_A) = $(CAT2(blob,_DEP_A)) ')' >> outf @@\
+ @echo 'IfGhcBuild_B(' CAT2(blob,_DEP_B) = $(CAT2(blob,_DEP_B)) ')' >> outf @@\
@echo 'IfGhcBuild_p(' CAT2(blob,_HIs_p) = $(CAT2(blob,_HIs_p)) ')' >> outf @@\
@echo 'IfGhcBuild_t(' CAT2(blob,_HIs_t) = $(CAT2(blob,_HIs_t)) ')' >> outf @@\
@echo 'IfGhcBuild_u(' CAT2(blob,_HIs_u) = $(CAT2(blob,_HIs_u)) ')' >> outf @@\
@echo 'IfGhcBuild_l(' CAT2(blob,_HIs_l) = $(CAT2(blob,_HIs_l)) ')' >> outf @@\
@echo 'IfGhcBuild_m(' CAT2(blob,_HIs_m) = $(CAT2(blob,_HIs_m)) ')' >> outf @@\
@echo 'IfGhcBuild_n(' CAT2(blob,_HIs_n) = $(CAT2(blob,_HIs_n)) ')' >> outf @@\
- @echo 'IfGhcBuild_o(' CAT2(blob,_HIs_o) = $(CAT2(blob,_HIs_o)) ')' >> outf
+ @echo 'IfGhcBuild_o(' CAT2(blob,_HIs_o) = $(CAT2(blob,_HIs_o)) ')' >> outf @@\
+ @echo 'IfGhcBuild_A(' CAT2(blob,_HIs_A) = $(CAT2(blob,_HIs_A)) ')' >> outf @@\
+ @echo 'IfGhcBuild_B(' CAT2(blob,_HIs_B) = $(CAT2(blob,_HIs_B)) ')' >> outf
BASIC_HS = $(BASIC_LHS:.lhs=.hs) $(BASIC_HS_PREL)
BASIC_OBJS_DIRS = $(BASIC_HS:.hs=)
IfGhcBuild_m(hcs_m :: $(BASIC_HC_m) $(ONE3_HC_m) $(GHCLIB_HC_m) $(HBCLIB_HC_m))
IfGhcBuild_n(hcs_n :: $(BASIC_HC_n) $(ONE3_HC_n) $(GHCLIB_HC_n) $(HBCLIB_HC_n))
IfGhcBuild_o(hcs_o :: $(BASIC_HC_o) $(ONE3_HC_o) $(GHCLIB_HC_o) $(HBCLIB_HC_o))
+IfGhcBuild_A(hcs_A :: $(BASIC_HC_A) $(ONE3_HC_A) $(GHCLIB_HC_A) $(HBCLIB_HC_A))
+IfGhcBuild_B(hcs_B :: $(BASIC_HC_B) $(ONE3_HC_B) $(GHCLIB_HC_B) $(HBCLIB_HC_B))
IfGhcBuild_normal(libs:: libHS.a libHS13.a libHSghc.a libHShbc.a)
IfGhcBuild_p(libs_p :: libHS_p.a libHS13_p.a libHSghc_p.a libHShbc_p.a)
IfGhcBuild_m(libs_m :: libHS_m.a libHS13_m.a libHSghc_m.a libHShbc_m.a)
IfGhcBuild_n(libs_n :: libHS_n.a libHS13_n.a libHSghc_n.a libHShbc_n.a)
IfGhcBuild_o(libs_o :: libHS_o.a libHS13_o.a libHSghc_o.a libHShbc_o.a)
+IfGhcBuild_A(libs_A :: libHS_A.a libHS13_A.a libHSghc_A.a libHShbc_A.a)
+IfGhcBuild_B(libs_B :: libHS_B.a libHS13_B.a libHSghc_B.a libHShbc_B.a)
/* maybe for GNU make only? */
-.PHONY :: hcs hcs_p hcs_t hcs_mg hcs_mr hcs_mt hcs_mp hcs_mg hcs_a hcs_b hcs_c hcs_d hcs_e hcs_f hcs_g hcs_h hcs_i hcs_j hcs_k hcs_l hcs_m hcs_n hcs_o
+.PHONY :: hcs hcs_p hcs_t hcs_mg hcs_mr hcs_mt hcs_mp hcs_mg hcs_a hcs_b hcs_c hcs_d hcs_e hcs_f hcs_g hcs_h hcs_i hcs_j hcs_k hcs_l hcs_m hcs_n hcs_o hcs_A hcs_B
#endif /* reasonable make */
, $(ONE3_DEP_o), $(ONE3_HIs_o) \
))
+IfGhcBuild_A(BigBuildTarget(_A,'*_A.o',his_A \
+, $(BASIC_DEP_A), $(BASIC_HIs_A) \
+, $(GHCLIB_DEP_A), $(GHCLIB_HIs_A) \
+, $(HBCLIB_DEP_A), $(HBCLIB_HIs_A) \
+, $(ONE3_DEP_A), $(ONE3_HIs_A) \
+))
+
+IfGhcBuild_B(BigBuildTarget(_B,'*_B.o',his_B \
+, $(BASIC_DEP_B), $(BASIC_HIs_B) \
+, $(GHCLIB_DEP_B), $(GHCLIB_HIs_B) \
+, $(HBCLIB_DEP_B), $(HBCLIB_HIs_B) \
+, $(ONE3_DEP_B), $(ONE3_HIs_B) \
+))
+
/****************************************************************
* *
* Creating the individual .hc files: *
IfGhcBuild_l(DoHs(file,isuf,_l, flags $(GHC_OPTS_l), '_l.o', '*_l.o')) \
IfGhcBuild_m(DoHs(file,isuf,_m, flags $(GHC_OPTS_m), '_m.o', '*_m.o')) \
IfGhcBuild_n(DoHs(file,isuf,_n, flags $(GHC_OPTS_n), '_n.o', '*_n.o')) \
-IfGhcBuild_o(DoHs(file,isuf,_o, flags $(GHC_OPTS_o), '_o.o', '*_o.o'))
+IfGhcBuild_o(DoHs(file,isuf,_o, flags $(GHC_OPTS_o), '_o.o', '*_o.o')) \
+IfGhcBuild_A(DoHs(file,isuf,_A, flags $(GHC_OPTS_A), '_A.o', '*_A.o')) \
+IfGhcBuild_B(DoHs(file,isuf,_B, flags $(GHC_OPTS_B), '_B.o', '*_B.o'))
/* now use the macro: */
#endif
#if GhcWithSockets == YES
CompilePreludishly(ghc/Socket,lhs, -ighc -fhaskell-1.3)
-CompilePreludishly(ghc/SocketPrim,lhs, -ighc -fhaskell-1.3 -K2m -optcO-DNON_POSIX_SOURCE '-#include"ghcSockets.h"')
+CompilePreludishly(ghc/SocketPrim,lhs, -ighc -fhaskell-1.3 -H12m -K2m -optcO-DNON_POSIX_SOURCE '-#include"ghcSockets.h"')
CompilePreludishly(ghc/BSD,lhs, -ighc -fhaskell-1.3 -optcO-DNON_POSIX_SOURCE '-#include"ghcSockets.h"')
CompilePreludishly(ghc/CError,lhs, -ighc -fhaskell-1.3 -K2m -fomit-derived-read)
#endif
/* now include the extra dependencies so generated */
#include "Jmake.inc5"
+/* for unix-libs.lit */
+LitSuffixRule(.lhs,.hs)
+LitDocRootTarget(unix-libs,lit)
+
/* should be *LAST* */
#if HaskellCompilerType != HC_USE_HC_FILES
/* otherwise, the dependencies jeopardize our .hc files --
import PreludeIOError(IOError13)
import PreludeMonadicIO(Either)
import SocketPrim(Family)
-data Family {-# GHC_PRAGMA AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_NBS | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_NIT | AF_802 | AF_OSI | AF_X25 | AF_OSINET | AF_GOSSIP | AF_IPX #-}
+data Family {-# GHC_PRAGMA AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_ISO | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_ROUTE | AF_LINK | Pseudo_AF_XTP | AF_NETMAN | AF_X25 | AF_CTF | AF_WAN #-}
data HostEntry = HostEntry [Char] [[Char]] Family [_Word]
type HostName = [Char]
type PortNumber = Int
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Family
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Family, [Char])]), (Int -> Family -> [Char] -> [Char]), ([Char] -> [([Family], [Char])]), ([Family] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Family), _CONSTM_ Text showsPrec (Family), _CONSTM_ Text readList (Family), _CONSTM_ Text showList (Family)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
unvectorizeHostAddrs ptr n
| str == ``NULL'' = returnPrimIO []
| otherwise =
- _casm_ ``%r = (W_)ntohl(((struct hostent*)%0)->h_addr_list[(int)%1]);''
+ _casm_ ``{ u_long tmp;
+ if ((((struct hostent*)%0)->h_addr_list[(int)%1]) == NULL)
+ tmp=(W_)0;
+ else
+ tmp = (W_)ntohl(((struct in_addr *)(((struct hostent*)%0)->h_addr_list[(int)%1]))->s_addr);
+ %r=(W_)tmp;} ''
ptr n `thenPrimIO` \ x ->
unvectorizeHostAddrs ptr (n+1) `thenPrimIO` \ xs ->
returnPrimIO (x : xs)
where str = indexAddrOffAddr ptr n
+{-
+unvectorizeHostAddrs :: _Addr -> Int -> PrimIO [_Word]
+unvectorizeHostAddrs ptr n
+ | str == ``NULL'' = returnPrimIO []
+ | otherwise =
+ _casm_ ``%r = (W_)ntohl(((struct hostent*)%0)->h_addr_list[(int)%1]);''
+ ptr n `thenPrimIO` \ x ->
+ unvectorizeHostAddrs ptr (n+1) `thenPrimIO` \ xs ->
+ returnPrimIO (x : xs)
+ where str = indexAddrOffAddr ptr n
+-}
-------------------------------------------------------------------------------
mutByteArr2Addr :: _MutableByteArray _RealWorld Int -> PrimIO _Addr
import PreludeIOError(IOError13)
import PreludeMonadicIO(Either)
import SocketPrim(Family)
-data Family {-# GHC_PRAGMA AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_NBS | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_NIT | AF_802 | AF_OSI | AF_X25 | AF_OSINET | AF_GOSSIP | AF_IPX #-}
+data Family {-# GHC_PRAGMA AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_ISO | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_ROUTE | AF_LINK | Pseudo_AF_XTP | AF_NETMAN | AF_X25 | AF_CTF | AF_WAN #-}
data HostEntry = HostEntry [Char] [[Char]] Family [_Word]
type HostName = [Char]
type PortNumber = Int
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Family
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Family, [Char])]), (Int -> Family -> [Char] -> [Char]), ([Char] -> [([Family], [Char])]), ([Family] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Family), _CONSTM_ Text showsPrec (Family), _CONSTM_ Text readList (Family), _CONSTM_ Text showList (Family)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
import PreludeIOError(IOError13)
import PreludeMonadicIO(Either)
import SocketPrim(Family)
-data Family {-# GHC_PRAGMA AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_NBS | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_NIT | AF_802 | AF_OSI | AF_X25 | AF_OSINET | AF_GOSSIP | AF_IPX #-}
+data Family {-# GHC_PRAGMA AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_ISO | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_ROUTE | AF_LINK | Pseudo_AF_XTP | AF_NETMAN | AF_X25 | AF_CTF | AF_WAN #-}
data HostEntry = HostEntry [Char] [[Char]] Family [_Word]
type HostName = [Char]
type PortNumber = Int
instance Text Family
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Family, [Char])]), (Int -> Family -> [Char] -> [Char]), ([Char] -> [([Family], [Char])]), ([Family] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Family), _CONSTM_ Text showsPrec (Family), _CONSTM_ Text readList (Family), _CONSTM_ Text showList (Family)] _N_
readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
import PreludeIOError(IOError13)
import PreludeMonadicIO(Either)
import SocketPrim(Family)
-data Family {-# GHC_PRAGMA AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_NBS | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_NIT | AF_802 | AF_OSI | AF_X25 | AF_OSINET | AF_GOSSIP | AF_IPX #-}
+data Family {-# GHC_PRAGMA AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_ISO | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_ROUTE | AF_LINK | Pseudo_AF_XTP | AF_NETMAN | AF_X25 | AF_CTF | AF_WAN #-}
data HostEntry = HostEntry [Char] [[Char]] Family [_Word]
type HostName = [Char]
type PortNumber = Int
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Family
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Family, [Char])]), (Int -> Family -> [Char] -> [Char]), ([Char] -> [([Family], [Char])]), ([Family] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Family), _CONSTM_ Text showsPrec (Family), _CONSTM_ Text readList (Family), _CONSTM_ Text showList (Family)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
import PreludeIOError(IOError13)
import PreludeMonadicIO(Either)
import SocketPrim(Family)
-data Family {-# GHC_PRAGMA AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_NBS | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_NIT | AF_802 | AF_OSI | AF_X25 | AF_OSINET | AF_GOSSIP | AF_IPX #-}
+data Family {-# GHC_PRAGMA AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_ISO | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_ROUTE | AF_LINK | Pseudo_AF_XTP | AF_NETMAN | AF_X25 | AF_CTF | AF_WAN #-}
data HostEntry = HostEntry [Char] [[Char]] Family [_Word]
type HostName = [Char]
type PortNumber = Int
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Family
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Family, [Char])]), (Int -> Family -> [Char] -> [Char]), ([Char] -> [([Family], [Char])]), ([Family] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Family), _CONSTM_ Text showsPrec (Family), _CONSTM_ Text readList (Family), _CONSTM_ Text showList (Family)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
import PreludeIOError(IOError13)
import PreludeMonadicIO(Either)
import SocketPrim(Family)
-data Family {-# GHC_PRAGMA AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_NBS | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_NIT | AF_802 | AF_OSI | AF_X25 | AF_OSINET | AF_GOSSIP | AF_IPX #-}
+data Family {-# GHC_PRAGMA AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_ISO | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_ROUTE | AF_LINK | Pseudo_AF_XTP | AF_NETMAN | AF_X25 | AF_CTF | AF_WAN #-}
data HostEntry = HostEntry [Char] [[Char]] Family [_Word]
type HostName = [Char]
type PortNumber = Int
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Family
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Family, [Char])]), (Int -> Family -> [Char] -> [Char]), ([Char] -> [([Family], [Char])]), ([Family] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Family), _CONSTM_ Text showsPrec (Family), _CONSTM_ Text readList (Family), _CONSTM_ Text showList (Family)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text CErrorCode
{-# GHC_PRAGMA _M_ CError {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(CErrorCode, [Char])]), (Int -> CErrorCode -> [Char] -> [Char]), ([Char] -> [([CErrorCode], [Char])]), ([CErrorCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (CErrorCode), _CONSTM_ Text showsPrec (CErrorCode), _CONSTM_ Text readList (CErrorCode), _CONSTM_ Text showList (CErrorCode)] _N_
readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(CErrorCode, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text CErrorCode
{-# GHC_PRAGMA _M_ CError {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(CErrorCode, [Char])]), (Int -> CErrorCode -> [Char] -> [Char]), ([Char] -> [([CErrorCode], [Char])]), ([CErrorCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (CErrorCode), _CONSTM_ Text showsPrec (CErrorCode), _CONSTM_ Text readList (CErrorCode), _CONSTM_ Text showList (CErrorCode)] _N_
readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(CErrorCode, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text CErrorCode
{-# GHC_PRAGMA _M_ CError {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(CErrorCode, [Char])]), (Int -> CErrorCode -> [Char] -> [Char]), ([Char] -> [([CErrorCode], [Char])]), ([CErrorCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (CErrorCode), _CONSTM_ Text showsPrec (CErrorCode), _CONSTM_ Text readList (CErrorCode), _CONSTM_ Text showList (CErrorCode)] _N_
readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(CErrorCode, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text CErrorCode
{-# GHC_PRAGMA _M_ CError {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(CErrorCode, [Char])]), (Int -> CErrorCode -> [Char] -> [Char]), ([Char] -> [([CErrorCode], [Char])]), ([CErrorCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (CErrorCode), _CONSTM_ Text showsPrec (CErrorCode), _CONSTM_ Text readList (CErrorCode), _CONSTM_ Text showList (CErrorCode)] _N_
readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(CErrorCode, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text CErrorCode
{-# GHC_PRAGMA _M_ CError {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(CErrorCode, [Char])]), (Int -> CErrorCode -> [Char] -> [Char]), ([Char] -> [([CErrorCode], [Char])]), ([CErrorCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (CErrorCode), _CONSTM_ Text showsPrec (CErrorCode), _CONSTM_ Text readList (CErrorCode), _CONSTM_ Text showList (CErrorCode)] _N_
readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(CErrorCode, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text CErrorCode
{-# GHC_PRAGMA _M_ CError {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(CErrorCode, [Char])]), (Int -> CErrorCode -> [Char] -> [Char]), ([Char] -> [([CErrorCode], [Char])]), ([CErrorCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (CErrorCode), _CONSTM_ Text showsPrec (CErrorCode), _CONSTM_ Text readList (CErrorCode), _CONSTM_ Text showList (CErrorCode)] _N_
readsPrec = _A_ 2 _U_ 22 _N_ _S_ _!_ _F_ _IF_ARGS_ 0 2 XX 4 \ (u0 :: Int) (u1 :: [Char]) -> _APP_ _TYAPP_ patError# { (Int -> [Char] -> [(CErrorCode, [Char])]) } [ _NOREP_S_ "%DPreludeCore.Text.readsPrec\"", u0, u1 ] _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
sizeFM :: FiniteMap a b -> Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: FiniteMap u0 u1) -> case u2 of { _ALG_ _ORIG_ FiniteMap EmptyFM -> _!_ I# [] [0#]; _ORIG_ FiniteMap Branch (u3 :: u0) (u4 :: u1) (u5 :: Int#) (u6 :: FiniteMap u0 u1) (u7 :: FiniteMap u0 u1) -> _!_ I# [] [u5]; _NO_DEFLT_ } _N_ #-}
+instance (Eq a, Eq b) => Eq (FiniteMap a b)
+ {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
ppr sty key, ppSP, ppInt (IF_GHC(I# sz, sz)), ppSP,
pprX sty fm_r, ppRparen]
#endif
+
+#if !defined(COMPILING_GHC)
+instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where
+ fm_1 == fm_2 = (sizeFM fm_1 == sizeFM fm_2) && -- quick test
+ (fmToList fm_1 == fmToList fm_2)
+
+{- NO: not clear what The Right Thing to do is:
+instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where
+ fm_1 <= fm_2 = (sizeFM fm_1 <= sizeFM fm_2) && -- quick test
+ (fmToList fm_1 <= fmToList fm_2)
+-}
+#endif
\end{code}
%************************************************************************
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
sizeFM :: FiniteMap a b -> Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: FiniteMap u0 u1) -> case u2 of { _ALG_ _ORIG_ FiniteMap EmptyFM -> _!_ I# [] [0#]; _ORIG_ FiniteMap Branch (u3 :: u0) (u4 :: u1) (u5 :: Int#) (u6 :: FiniteMap u0 u1) (u7 :: FiniteMap u0 u1) -> _!_ I# [] [u5]; _NO_DEFLT_ } _N_ #-}
+instance (Eq a, Eq b) => Eq (FiniteMap a b)
+ {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
sizeFM :: FiniteMap a b -> Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: FiniteMap u0 u1) -> case u2 of { _ALG_ _ORIG_ FiniteMap EmptyFM -> _!_ I# [] [0#]; _ORIG_ FiniteMap Branch (u3 :: u0) (u4 :: u1) (u5 :: Int#) (u6 :: FiniteMap u0 u1) (u7 :: FiniteMap u0 u1) -> _!_ I# [] [u5]; _NO_DEFLT_ } _N_ #-}
+instance (Eq a, Eq b) => Eq (FiniteMap a b)
+ {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
sizeFM :: FiniteMap a b -> Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: FiniteMap u0 u1) -> case u2 of { _ALG_ _ORIG_ FiniteMap EmptyFM -> _!_ I# [] [0#]; _ORIG_ FiniteMap Branch (u3 :: u0) (u4 :: u1) (u5 :: Int#) (u6 :: FiniteMap u0 u1) (u7 :: FiniteMap u0 u1) -> _!_ I# [] [u5]; _NO_DEFLT_ } _N_ #-}
+instance (Eq a, Eq b) => Eq (FiniteMap a b)
+ {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
sizeFM :: FiniteMap a b -> Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: FiniteMap u0 u1) -> case u2 of { _ALG_ _ORIG_ FiniteMap EmptyFM -> _!_ I# [] [0#]; _ORIG_ FiniteMap Branch (u3 :: u0) (u4 :: u1) (u5 :: Int#) (u6 :: FiniteMap u0 u1) (u7 :: FiniteMap u0 u1) -> _!_ I# [] [u5]; _NO_DEFLT_ } _N_ #-}
+instance (Eq a, Eq b) => Eq (FiniteMap a b)
+ {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
sizeFM :: FiniteMap a b -> Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: FiniteMap u0 u1) -> case u2 of { _ALG_ _ORIG_ FiniteMap EmptyFM -> _!_ I# [] [0#]; _ORIG_ FiniteMap Branch (u3 :: u0) (u4 :: u1) (u5 :: Int#) (u6 :: FiniteMap u0 u1) (u7 :: FiniteMap u0 u1) -> _!_ I# [] [u5]; _NO_DEFLT_ } _N_ #-}
+instance (Eq a, Eq b) => Eq (FiniteMap a b)
+ {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
acc
else
let
- x@(C# x#) = _headPS repl
- xs = _tailPS' repl
+ x = _headPS repl
+ x# = case x of { C# c -> c }
+ xs = _tailPS' repl
in
case x# of
'\\'# ->
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _foldlPS _N_ #-}
foldrPS :: (Char -> a -> a) -> a -> _PackedString -> a
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _foldrPS _N_ #-}
+getPS :: _FILE -> Int -> _State _RealWorld -> (_PackedString, _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
headPS :: _PackedString -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _headPS _N_ #-}
implode :: [Char] -> _PackedString
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _CPS [] [""#, 0#] _N_ #-}
nullPS :: _PackedString -> Bool
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _nullPS _N_ #-}
+packBytesForC :: [Char] -> _ByteArray Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packBytesForC _N_ #-}
+packBytesForCST :: [Char] -> _State a -> (_ByteArray Int, _State a)
+ {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packBytesForCST _N_ #-}
packCBytes :: Int -> _Addr -> _PackedString
{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+packCBytesST :: Int -> _Addr -> _State a -> (_PackedString, _State a)
+ {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(P)U(P)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
packCString :: _Addr -> _PackedString
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
packString :: [Char] -> _PackedString
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packString _N_ #-}
+packStringST :: [Char] -> _State a -> (_PackedString, _State a)
+ {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packStringST _N_ #-}
psToByteArray :: _PackedString -> _ByteArray Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _psToByteArray _N_ #-}
putPS :: _FILE -> _PackedString -> _State _RealWorld -> ((), _State _RealWorld)
%
\section[PackedString]{Packed strings}
-A non-weird interface to the wired-in @PackedString@ type.
+A non-weird/abstract interface to the wired-in @PackedString@ type.
\begin{code}
module PackedString (
PackedString(..),
- packString,
- packCString,
- packCBytes,
+ packString, -- :: [Char] -> PackedString
+ packCString, -- :: _Addr -> PackedString
+ packCBytes, -- :: Int -> _Addr -> PackedString
+
+ packStringST, -- :: [Char] -> _ST s PackedString
+ packCBytesST, -- :: Int -> _Addr -> _ST s PackedString
+ packBytesForC, -- :: [Char] -> _ByteArray Int
+ packBytesForCST, -- :: [Char] -> _ST s (_ByteArray Int)
+
--NO: packStringForC,
- nilPS,
- consPS,
- byteArrayToPS,
- psToByteArray,
+ nilPS, -- :: PackedString
+ consPS, -- :: Char -> PackedString -> PackedString
+ byteArrayToPS, -- :: _ByteArray Int -> PackedString
+ psToByteArray, -- :: PackedString -> _ByteArray Int
- unpackPS,
+ unpackPS, -- :: PackedString -> [Char]
--NO: unpackPS#,
- putPS,
-
- implode, explode, -- alt. names for packString, unpackPS
-
- headPS,
- tailPS,
- nullPS,
- appendPS,
- lengthPS,
- indexPS,
- mapPS,
- filterPS,
- foldlPS,
- foldrPS,
- takePS,
- dropPS,
- splitAtPS,
- takeWhilePS,
- dropWhilePS,
- spanPS,
- breakPS,
- linesPS,
- wordsPS,
- reversePS,
- concatPS,
-
- substrPS,
+ putPS, -- :: _FILE -> PackedString -> PrimIO ()
+ getPS, -- :: _FILE -> Int -> PrimIO PackedString
+
+ {- alt. names for packString, unpackPS -}
+ implode, -- :: [Char] -> PackedString
+ explode, -- :: PackedString -> [Char]
+
+ headPS, -- :: PackedString -> Char
+ tailPS, -- :: PackedString -> PackedString
+ nullPS, -- :: PackedString -> Bool
+ appendPS, -- :: PackedString -> PackedString -> PackedString
+ lengthPS, -- :: PackedString -> Int
+ indexPS, -- :: PackedString -> Int -> Char
+ mapPS, -- :: (Char -> Char) -> PackedString -> PackedString
+ filterPS, -- :: (Char -> Bool) -> PackedString -> PackedString
+ foldlPS, -- :: (a -> Char -> a) -> a -> PackedString -> a
+ foldrPS, -- :: (Char -> a -> a) -> a -> PackedString -> a
+ takePS, -- :: Int -> PackedString -> PackedString
+ dropPS, -- :: Int -> PackedString -> PackedString
+ splitAtPS, -- :: Int -> PackedString -> PackedString
+ takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
+ dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
+ spanPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+ breakPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+ linesPS, -- :: PackedString -> [PackedString]
+ wordsPS, -- :: PackedString -> [PackedString]
+ reversePS, -- :: PackedString -> PackedString
+ concatPS, -- :: [PackedString] -> PackedString
+
+ substrPS, -- :: PackedString -> Int -> Int -> PackedString
-- to make interface self-sufficient
_PackedString, -- abstract!
_FILE
) where
+import PS
+
type PackedString = _PackedString
packString = _packString
byteArrayToPS = _byteArrayToPS
psToByteArray = _psToByteArray
+packStringST = _packStringST
+packCBytesST = _packCBytesST
+packBytesForC = _packBytesForC
+packBytesForCST = _packBytesForCST
+
unpackPS = _unpackPS
putPS = _putPS
+getPS = _getPS
implode = _packString -- alt. names
explode = _unpackPS
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _foldlPS _N_ #-}
foldrPS :: (Char -> a -> a) -> a -> _PackedString -> a
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _foldrPS _N_ #-}
+getPS :: _FILE -> Int -> _State _RealWorld -> (_PackedString, _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
headPS :: _PackedString -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _headPS _N_ #-}
implode :: [Char] -> _PackedString
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _CPS [] [""#, 0#] _N_ #-}
nullPS :: _PackedString -> Bool
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _nullPS _N_ #-}
+packBytesForC :: [Char] -> _ByteArray Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packBytesForC _N_ #-}
+packBytesForCST :: [Char] -> _State a -> (_ByteArray Int, _State a)
+ {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packBytesForCST _N_ #-}
packCBytes :: Int -> _Addr -> _PackedString
{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+packCBytesST :: Int -> _Addr -> _State a -> (_PackedString, _State a)
+ {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(P)U(P)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
packCString :: _Addr -> _PackedString
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
packString :: [Char] -> _PackedString
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packString _N_ #-}
+packStringST :: [Char] -> _State a -> (_PackedString, _State a)
+ {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packStringST _N_ #-}
psToByteArray :: _PackedString -> _ByteArray Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _psToByteArray _N_ #-}
putPS :: _FILE -> _PackedString -> _State _RealWorld -> ((), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _foldlPS _N_ #-}
foldrPS :: (Char -> a -> a) -> a -> _PackedString -> a
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _foldrPS _N_ #-}
+getPS :: _FILE -> Int -> _State _RealWorld -> (_PackedString, _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
headPS :: _PackedString -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _headPS _N_ #-}
implode :: [Char] -> _PackedString
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _CPS [] [""#, 0#] _N_ #-}
nullPS :: _PackedString -> Bool
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _nullPS _N_ #-}
+packBytesForC :: [Char] -> _ByteArray Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packBytesForC _N_ #-}
+packBytesForCST :: [Char] -> _State a -> (_ByteArray Int, _State a)
+ {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packBytesForCST _N_ #-}
packCBytes :: Int -> _Addr -> _PackedString
{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+packCBytesST :: Int -> _Addr -> _State a -> (_PackedString, _State a)
+ {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(P)U(P)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
packCString :: _Addr -> _PackedString
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
packString :: [Char] -> _PackedString
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packString _N_ #-}
+packStringST :: [Char] -> _State a -> (_PackedString, _State a)
+ {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packStringST _N_ #-}
psToByteArray :: _PackedString -> _ByteArray Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _psToByteArray _N_ #-}
putPS :: _FILE -> _PackedString -> _State _RealWorld -> ((), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _foldlPS _N_ #-}
foldrPS :: (Char -> a -> a) -> a -> _PackedString -> a
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _foldrPS _N_ #-}
+getPS :: _FILE -> Int -> _State _RealWorld -> (_PackedString, _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
headPS :: _PackedString -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _headPS _N_ #-}
implode :: [Char] -> _PackedString
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _CPS [] [""#, 0#] _N_ #-}
nullPS :: _PackedString -> Bool
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _nullPS _N_ #-}
+packBytesForC :: [Char] -> _ByteArray Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packBytesForC _N_ #-}
+packBytesForCST :: [Char] -> _State a -> (_ByteArray Int, _State a)
+ {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packBytesForCST _N_ #-}
packCBytes :: Int -> _Addr -> _PackedString
{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+packCBytesST :: Int -> _Addr -> _State a -> (_PackedString, _State a)
+ {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(P)U(P)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
packCString :: _Addr -> _PackedString
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
packString :: [Char] -> _PackedString
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packString _N_ #-}
+packStringST :: [Char] -> _State a -> (_PackedString, _State a)
+ {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packStringST _N_ #-}
psToByteArray :: _PackedString -> _ByteArray Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _psToByteArray _N_ #-}
putPS :: _FILE -> _PackedString -> _State _RealWorld -> ((), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _foldlPS _N_ #-}
foldrPS :: (Char -> a -> a) -> a -> _PackedString -> a
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _foldrPS _N_ #-}
+getPS :: _FILE -> Int -> _State _RealWorld -> (_PackedString, _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 211 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
headPS :: _PackedString -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _headPS _N_ #-}
implode :: [Char] -> _PackedString
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _CPS [] [""#, 0#] _N_ #-}
nullPS :: _PackedString -> Bool
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _nullPS _N_ #-}
+packBytesForC :: [Char] -> _ByteArray Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packBytesForC _N_ #-}
+packBytesForCST :: [Char] -> _State a -> (_ByteArray Int, _State a)
+ {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packBytesForCST _N_ #-}
packCBytes :: Int -> _Addr -> _PackedString
{-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+packCBytesST :: Int -> _Addr -> _State a -> (_PackedString, _State a)
+ {-# GHC_PRAGMA _A_ 3 _U_ 112 _N_ _S_ "U(P)U(P)L" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
packCString :: _Addr -> _PackedString
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
packString :: [Char] -> _PackedString
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packString _N_ #-}
+packStringST :: [Char] -> _State a -> (_PackedString, _State a)
+ {-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _packStringST _N_ #-}
psToByteArray :: _PackedString -> _ByteArray Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 0 0 X 1 _ORIG_ PreludePS _psToByteArray _N_ #-}
putPS :: _FILE -> _PackedString -> _State _RealWorld -> ((), _State _RealWorld)
the generic callback for this KeyCode.
The entry point that $genericRlCback$ calls would then read the
-global variables $current_i$ and $current_kc$ and do a lookup:
+global variables $current\_i$ and $current\_kc$ and do a lookup:
\begin{code}
rlAddDefun :: String -> -- Function Name
The C function $genericRlCallback$ puts the callback arguments into
global variables and enters the Haskell world through the
$haskellRlEntry$ function. Before exiting, the Haskell function will
-deposit its result in the global varariable $rl_return$.
+deposit its result in the global varariable $rl\_return$.
In the Haskell action that is invoked via $enterStablePtr$, a match
-between the Keycode in $current_kc$ and the Haskell callback needs to
+between the Keycode in $current\_kc$ and the Haskell callback needs to
be made. To essentially keep the same assoc. list of (KeyCode,cback
function) as Readline does, we make use of yet another global variable
$cbackList$:
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Set where
-import FiniteMap(FiniteMap, intersectFM, keysFM, minusFM, plusFM)
+import FiniteMap(FiniteMap, keysFM, sizeFM)
data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
-type Set a = FiniteMap a ()
-elementOf :: Ord a => a -> FiniteMap a () -> Bool
+data Set a {-# GHC_PRAGMA MkSet (FiniteMap a ()) #-}
+cardinality :: Set a -> Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap sizeFM { u0 } { () } _N_} _F_ _IF_ARGS_ 1 1 C 3 _/\_ u0 -> \ (u1 :: Set u0) -> case u1 of { _ALG_ _ORIG_ Set MkSet (u2 :: FiniteMap u0 ()) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ FiniteMap sizeFM { u0 } { () } [ u2 ]; _NO_DEFLT_ } _N_ #-}
+elementOf :: Ord a => a -> Set a -> Bool
{-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _N_ #-}
-emptySet :: FiniteMap a ()
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, ()] [] _N_ #-}
-intersect :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap intersectFM { u0 } { () } _N_ #-}
-intersectFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-isEmptySet :: FiniteMap a () -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
+emptySet :: Set a
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+intersect :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+isEmptySet :: Set a -> Bool
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
keysFM :: FiniteMap b a -> [b]
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-mapSet :: Ord b => (a -> b) -> FiniteMap a () -> FiniteMap b ()
+mapSet :: Ord b => (a -> b) -> Set a -> Set b
{-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _N_ #-}
-minusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-minusSet :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap minusFM { u0 } { () } _N_ #-}
-mkSet :: Ord a => [a] -> FiniteMap a ()
+minusSet :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+mkSet :: Ord a => [a] -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 11 _N_ _N_ _N_ _N_ #-}
-plusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-setToList :: FiniteMap a () -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_ #-}
-singletonSet :: a -> FiniteMap a ()
+setToList :: Set a -> [a]
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_} _F_ _IF_ARGS_ 1 1 C 3 _/\_ u0 -> \ (u1 :: Set u0) -> case u1 of { _ALG_ _ORIG_ Set MkSet (u2 :: FiniteMap u0 ()) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } [ u2 ]; _NO_DEFLT_ } _N_ #-}
+singletonSet :: a -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
-union :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap plusFM { u0 } { () } _N_ #-}
-unionManySets :: Ord a => [FiniteMap a ()] -> FiniteMap a ()
+sizeFM :: FiniteMap a b -> Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: FiniteMap u0 u1) -> case u2 of { _ALG_ _ORIG_ FiniteMap EmptyFM -> _!_ I# [] [0#]; _ORIG_ FiniteMap Branch (u3 :: u0) (u4 :: u1) (u5 :: Int#) (u6 :: FiniteMap u0 u1) (u7 :: FiniteMap u0 u1) -> _!_ I# [] [u5]; _NO_DEFLT_ } _N_ #-}
+union :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+unionManySets :: Ord a => [Set a] -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _N_ _N_ #-}
+instance (Eq a, Eq b) => Eq (FiniteMap a b)
+ {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
+instance Eq a => Eq (Set a)
+ {-# GHC_PRAGMA _M_ Set {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
%
-% (c) The AQUA Project, Glasgow University, 1994
+% (c) The AQUA Project, Glasgow University, 1994-1995
%
\section[Set]{An implementation of sets}
implementation of @FiniteMaps@. The interface is (roughly?) as
before.
-See also the @UniqSet@ module (sets of things from which you can
-extract a @Unique@).
+(95/08: This module is no longer part of the GHC compiler proper; it
+is a GHC library module only, now.)
\begin{code}
-#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)
-#define OUTPUTABLE_a , Outputable a
-#else
-#define OUTPUTABLE_a {--}
-#endif
-
module Set (
-#if defined(__GLASGOW_HASKELL__)
- Set(..), -- abstract type: NOT
-#else
-- not a synonym so we can make it abstract
Set,
-#endif
mkSet, setToList, emptySet, singletonSet,
union, unionManySets, minusSet,
elementOf, mapSet,
- intersect, isEmptySet
+ intersect, isEmptySet,
+ cardinality
-- to make the interface self-sufficient
#if defined(__GLASGOW_HASKELL__)
, FiniteMap -- abstract
-- for pragmas
- , intersectFM, minusFM, keysFM, plusFM
+ , keysFM, sizeFM
#endif
) where
, Maybe(..)
#endif
)
-#if defined(__GLASGOW_HASKELL__)
--- I guess this is here so that our friend USE_ATTACK_PRAGMAS can
--- do his job of seeking out and destroying information hiding. ADR
-import Util --OLD: hiding ( Set(..), emptySet )
-#endif
-
-#if defined(COMPILING_GHC)
-import Outputable
-#endif
\end{code}
\begin{code}
-#if defined(__GLASGOW_HASKELL__)
-
-type Set a = FiniteMap a ()
-
-#define MkSet {--}
-
-#else
-- This can't be a type synonym if you want to use constructor classes.
data Set a = MkSet (FiniteMap a ()) {-# STRICT #-}
-#endif
emptySet :: Set a
emptySet = MkSet emptyFM
setToList :: Set a -> [a]
setToList (MkSet set) = keysFM set
-mkSet :: (Ord a OUTPUTABLE_a) => [a] -> Set a
+mkSet :: Ord a => [a] -> Set a
mkSet xs = MkSet (listToFM [ (x, ()) | x <- xs])
-union :: (Ord a OUTPUTABLE_a) => Set a -> Set a -> Set a
+union :: Ord a => Set a -> Set a -> Set a
union (MkSet set1) (MkSet set2) = MkSet (plusFM set1 set2)
-unionManySets :: (Ord a OUTPUTABLE_a) => [Set a] -> Set a
+unionManySets :: Ord a => [Set a] -> Set a
unionManySets ss = foldr union emptySet ss
-minusSet :: (Ord a OUTPUTABLE_a) => Set a -> Set a -> Set a
+minusSet :: Ord a => Set a -> Set a -> Set a
minusSet (MkSet set1) (MkSet set2) = MkSet (minusFM set1 set2)
-intersect :: (Ord a OUTPUTABLE_a) => Set a -> Set a -> Set a
+intersect :: Ord a => Set a -> Set a -> Set a
intersect (MkSet set1) (MkSet set2) = MkSet (intersectFM set1 set2)
-elementOf :: (Ord a OUTPUTABLE_a) => a -> Set a -> Bool
+elementOf :: Ord a => a -> Set a -> Bool
elementOf x (MkSet set) = maybeToBool(lookupFM set x)
isEmptySet :: Set a -> Bool
isEmptySet (MkSet set) = sizeFM set == 0
-mapSet :: (Ord a OUTPUTABLE_a) => (b -> a) -> Set b -> Set a
+mapSet :: Ord a => (b -> a) -> Set b -> Set a
mapSet f (MkSet set) = MkSet (listToFM [ (f key, ()) | key <- keysFM set ])
+
+cardinality :: Set a -> Int
+cardinality (MkSet set) = sizeFM set
+
+-- fair enough...
+instance (Eq a) => Eq (Set a) where
+ (MkSet set_1) == (MkSet set_2) = set_1 == set_2
+
+-- but not so clear what the right thing to do is:
+{- NO:
+instance (Ord a) => Ord (Set a) where
+ (MkSet set_1) <= (MkSet set_2) = set_1 <= set_2
+-}
\end{code}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Set where
-import FiniteMap(FiniteMap, intersectFM, keysFM, minusFM, plusFM)
+import FiniteMap(FiniteMap, keysFM, sizeFM)
data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
-type Set a = FiniteMap a ()
-elementOf :: Ord a => a -> FiniteMap a () -> Bool
+data Set a {-# GHC_PRAGMA MkSet (FiniteMap a ()) #-}
+cardinality :: Set a -> Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap sizeFM { u0 } { () } _N_} _F_ _IF_ARGS_ 1 1 C 3 _/\_ u0 -> \ (u1 :: Set u0) -> case u1 of { _ALG_ _ORIG_ Set MkSet (u2 :: FiniteMap u0 ()) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ FiniteMap sizeFM { u0 } { () } [ u2 ]; _NO_DEFLT_ } _N_ #-}
+elementOf :: Ord a => a -> Set a -> Bool
{-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _N_ #-}
-emptySet :: FiniteMap a ()
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, ()] [] _N_ #-}
-intersect :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap intersectFM { u0 } { () } _N_ #-}
-intersectFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-isEmptySet :: FiniteMap a () -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
+emptySet :: Set a
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+intersect :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+isEmptySet :: Set a -> Bool
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
keysFM :: FiniteMap b a -> [b]
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-mapSet :: Ord b => (a -> b) -> FiniteMap a () -> FiniteMap b ()
+mapSet :: Ord b => (a -> b) -> Set a -> Set b
{-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _N_ #-}
-minusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-minusSet :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap minusFM { u0 } { () } _N_ #-}
-mkSet :: Ord a => [a] -> FiniteMap a ()
+minusSet :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+mkSet :: Ord a => [a] -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 11 _N_ _N_ _N_ _N_ #-}
-plusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-setToList :: FiniteMap a () -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_ #-}
-singletonSet :: a -> FiniteMap a ()
+setToList :: Set a -> [a]
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_} _F_ _IF_ARGS_ 1 1 C 3 _/\_ u0 -> \ (u1 :: Set u0) -> case u1 of { _ALG_ _ORIG_ Set MkSet (u2 :: FiniteMap u0 ()) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } [ u2 ]; _NO_DEFLT_ } _N_ #-}
+singletonSet :: a -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
-union :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap plusFM { u0 } { () } _N_ #-}
-unionManySets :: Ord a => [FiniteMap a ()] -> FiniteMap a ()
+sizeFM :: FiniteMap a b -> Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: FiniteMap u0 u1) -> case u2 of { _ALG_ _ORIG_ FiniteMap EmptyFM -> _!_ I# [] [0#]; _ORIG_ FiniteMap Branch (u3 :: u0) (u4 :: u1) (u5 :: Int#) (u6 :: FiniteMap u0 u1) (u7 :: FiniteMap u0 u1) -> _!_ I# [] [u5]; _NO_DEFLT_ } _N_ #-}
+union :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+unionManySets :: Ord a => [Set a] -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _N_ _N_ #-}
+instance (Eq a, Eq b) => Eq (FiniteMap a b)
+ {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
+instance Eq a => Eq (Set a)
+ {-# GHC_PRAGMA _M_ Set {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Set where
-import FiniteMap(FiniteMap, intersectFM, keysFM, minusFM, plusFM)
+import FiniteMap(FiniteMap, keysFM, sizeFM)
data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
-type Set a = FiniteMap a ()
-elementOf :: Ord a => a -> FiniteMap a () -> Bool
+data Set a {-# GHC_PRAGMA MkSet (FiniteMap a ()) #-}
+cardinality :: Set a -> Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap sizeFM { u0 } { () } _N_} _F_ _IF_ARGS_ 1 1 C 3 _/\_ u0 -> \ (u1 :: Set u0) -> case u1 of { _ALG_ _ORIG_ Set MkSet (u2 :: FiniteMap u0 ()) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ FiniteMap sizeFM { u0 } { () } [ u2 ]; _NO_DEFLT_ } _N_ #-}
+elementOf :: Ord a => a -> Set a -> Bool
{-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _N_ #-}
-emptySet :: FiniteMap a ()
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, ()] [] _N_ #-}
-intersect :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap intersectFM { u0 } { () } _N_ #-}
-intersectFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-isEmptySet :: FiniteMap a () -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
+emptySet :: Set a
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+intersect :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+isEmptySet :: Set a -> Bool
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
keysFM :: FiniteMap b a -> [b]
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-mapSet :: Ord b => (a -> b) -> FiniteMap a () -> FiniteMap b ()
+mapSet :: Ord b => (a -> b) -> Set a -> Set b
{-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _N_ #-}
-minusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-minusSet :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap minusFM { u0 } { () } _N_ #-}
-mkSet :: Ord a => [a] -> FiniteMap a ()
+minusSet :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+mkSet :: Ord a => [a] -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 11 _N_ _N_ _N_ _N_ #-}
-plusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-setToList :: FiniteMap a () -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_ #-}
-singletonSet :: a -> FiniteMap a ()
+setToList :: Set a -> [a]
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_} _F_ _IF_ARGS_ 1 1 C 3 _/\_ u0 -> \ (u1 :: Set u0) -> case u1 of { _ALG_ _ORIG_ Set MkSet (u2 :: FiniteMap u0 ()) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } [ u2 ]; _NO_DEFLT_ } _N_ #-}
+singletonSet :: a -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
-union :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap plusFM { u0 } { () } _N_ #-}
-unionManySets :: Ord a => [FiniteMap a ()] -> FiniteMap a ()
+sizeFM :: FiniteMap a b -> Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: FiniteMap u0 u1) -> case u2 of { _ALG_ _ORIG_ FiniteMap EmptyFM -> _!_ I# [] [0#]; _ORIG_ FiniteMap Branch (u3 :: u0) (u4 :: u1) (u5 :: Int#) (u6 :: FiniteMap u0 u1) (u7 :: FiniteMap u0 u1) -> _!_ I# [] [u5]; _NO_DEFLT_ } _N_ #-}
+union :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+unionManySets :: Ord a => [Set a] -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _N_ _N_ #-}
+instance (Eq a, Eq b) => Eq (FiniteMap a b)
+ {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
+instance Eq a => Eq (Set a)
+ {-# GHC_PRAGMA _M_ Set {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Set where
-import FiniteMap(FiniteMap, intersectFM, keysFM, minusFM, plusFM)
+import FiniteMap(FiniteMap, keysFM, sizeFM)
data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
-type Set a = FiniteMap a ()
-elementOf :: Ord a => a -> FiniteMap a () -> Bool
+data Set a {-# GHC_PRAGMA MkSet (FiniteMap a ()) #-}
+cardinality :: Set a -> Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap sizeFM { u0 } { () } _N_} _F_ _IF_ARGS_ 1 1 C 3 _/\_ u0 -> \ (u1 :: Set u0) -> case u1 of { _ALG_ _ORIG_ Set MkSet (u2 :: FiniteMap u0 ()) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ FiniteMap sizeFM { u0 } { () } [ u2 ]; _NO_DEFLT_ } _N_ #-}
+elementOf :: Ord a => a -> Set a -> Bool
{-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _N_ #-}
-emptySet :: FiniteMap a ()
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, ()] [] _N_ #-}
-intersect :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap intersectFM { u0 } { () } _N_ #-}
-intersectFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-isEmptySet :: FiniteMap a () -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
+emptySet :: Set a
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+intersect :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+isEmptySet :: Set a -> Bool
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
keysFM :: FiniteMap b a -> [b]
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-mapSet :: Ord b => (a -> b) -> FiniteMap a () -> FiniteMap b ()
+mapSet :: Ord b => (a -> b) -> Set a -> Set b
{-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _N_ #-}
-minusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-minusSet :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap minusFM { u0 } { () } _N_ #-}
-mkSet :: Ord a => [a] -> FiniteMap a ()
+minusSet :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+mkSet :: Ord a => [a] -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 11 _N_ _N_ _N_ _N_ #-}
-plusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-setToList :: FiniteMap a () -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_ #-}
-singletonSet :: a -> FiniteMap a ()
+setToList :: Set a -> [a]
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_} _F_ _IF_ARGS_ 1 1 C 3 _/\_ u0 -> \ (u1 :: Set u0) -> case u1 of { _ALG_ _ORIG_ Set MkSet (u2 :: FiniteMap u0 ()) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } [ u2 ]; _NO_DEFLT_ } _N_ #-}
+singletonSet :: a -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
-union :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap plusFM { u0 } { () } _N_ #-}
-unionManySets :: Ord a => [FiniteMap a ()] -> FiniteMap a ()
+sizeFM :: FiniteMap a b -> Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: FiniteMap u0 u1) -> case u2 of { _ALG_ _ORIG_ FiniteMap EmptyFM -> _!_ I# [] [0#]; _ORIG_ FiniteMap Branch (u3 :: u0) (u4 :: u1) (u5 :: Int#) (u6 :: FiniteMap u0 u1) (u7 :: FiniteMap u0 u1) -> _!_ I# [] [u5]; _NO_DEFLT_ } _N_ #-}
+union :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+unionManySets :: Ord a => [Set a] -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _N_ _N_ #-}
+instance (Eq a, Eq b) => Eq (FiniteMap a b)
+ {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
+instance Eq a => Eq (Set a)
+ {-# GHC_PRAGMA _M_ Set {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Set where
-import FiniteMap(FiniteMap, intersectFM, keysFM, minusFM, plusFM)
+import FiniteMap(FiniteMap, keysFM, sizeFM)
data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
-type Set a = FiniteMap a ()
-elementOf :: Ord a => a -> FiniteMap a () -> Bool
+data Set a {-# GHC_PRAGMA MkSet (FiniteMap a ()) #-}
+cardinality :: Set a -> Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap sizeFM { u0 } { () } _N_} _F_ _IF_ARGS_ 1 1 C 3 _/\_ u0 -> \ (u1 :: Set u0) -> case u1 of { _ALG_ _ORIG_ Set MkSet (u2 :: FiniteMap u0 ()) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ FiniteMap sizeFM { u0 } { () } [ u2 ]; _NO_DEFLT_ } _N_ #-}
+elementOf :: Ord a => a -> Set a -> Bool
{-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _N_ #-}
-emptySet :: FiniteMap a ()
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, ()] [] _N_ #-}
-intersect :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap intersectFM { u0 } { () } _N_ #-}
-intersectFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-isEmptySet :: FiniteMap a () -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
+emptySet :: Set a
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+intersect :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+isEmptySet :: Set a -> Bool
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
keysFM :: FiniteMap b a -> [b]
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-mapSet :: Ord b => (a -> b) -> FiniteMap a () -> FiniteMap b ()
+mapSet :: Ord b => (a -> b) -> Set a -> Set b
{-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _N_ #-}
-minusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-minusSet :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap minusFM { u0 } { () } _N_ #-}
-mkSet :: Ord a => [a] -> FiniteMap a ()
+minusSet :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+mkSet :: Ord a => [a] -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 11 _N_ _N_ _N_ _N_ #-}
-plusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-setToList :: FiniteMap a () -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_ #-}
-singletonSet :: a -> FiniteMap a ()
+setToList :: Set a -> [a]
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_} _F_ _IF_ARGS_ 1 1 C 3 _/\_ u0 -> \ (u1 :: Set u0) -> case u1 of { _ALG_ _ORIG_ Set MkSet (u2 :: FiniteMap u0 ()) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } [ u2 ]; _NO_DEFLT_ } _N_ #-}
+singletonSet :: a -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
-union :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap plusFM { u0 } { () } _N_ #-}
-unionManySets :: Ord a => [FiniteMap a ()] -> FiniteMap a ()
+sizeFM :: FiniteMap a b -> Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: FiniteMap u0 u1) -> case u2 of { _ALG_ _ORIG_ FiniteMap EmptyFM -> _!_ I# [] [0#]; _ORIG_ FiniteMap Branch (u3 :: u0) (u4 :: u1) (u5 :: Int#) (u6 :: FiniteMap u0 u1) (u7 :: FiniteMap u0 u1) -> _!_ I# [] [u5]; _NO_DEFLT_ } _N_ #-}
+union :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+unionManySets :: Ord a => [Set a] -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _N_ _N_ #-}
+instance (Eq a, Eq b) => Eq (FiniteMap a b)
+ {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
+instance Eq a => Eq (Set a)
+ {-# GHC_PRAGMA _M_ Set {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Set where
-import FiniteMap(FiniteMap, intersectFM, keysFM, minusFM, plusFM)
+import FiniteMap(FiniteMap, keysFM, sizeFM)
data FiniteMap a b {-# GHC_PRAGMA EmptyFM | Branch a b Int# (FiniteMap a b) (FiniteMap a b) #-}
-type Set a = FiniteMap a ()
-elementOf :: Ord a => a -> FiniteMap a () -> Bool
+data Set a {-# GHC_PRAGMA MkSet (FiniteMap a ()) #-}
+cardinality :: Set a -> Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap sizeFM { u0 } { () } _N_} _F_ _IF_ARGS_ 1 1 C 3 _/\_ u0 -> \ (u1 :: Set u0) -> case u1 of { _ALG_ _ORIG_ Set MkSet (u2 :: FiniteMap u0 ()) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ FiniteMap sizeFM { u0 } { () } [ u2 ]; _NO_DEFLT_ } _N_ #-}
+elementOf :: Ord a => a -> Set a -> Bool
{-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _N_ #-}
-emptySet :: FiniteMap a ()
- {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _!_ _ORIG_ FiniteMap EmptyFM [u0, ()] [] _N_ #-}
-intersect :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap intersectFM { u0 } { () } _N_ #-}
-intersectFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-isEmptySet :: FiniteMap a () -> Bool
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
+emptySet :: Set a
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
+intersect :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+isEmptySet :: Set a -> Bool
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _N_ _N_} _N_ _N_ #-}
keysFM :: FiniteMap b a -> [b]
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
-mapSet :: Ord b => (a -> b) -> FiniteMap a () -> FiniteMap b ()
+mapSet :: Ord b => (a -> b) -> Set a -> Set b
{-# GHC_PRAGMA _A_ 1 _U_ 121 _N_ _N_ _N_ _N_ #-}
-minusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-minusSet :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap minusFM { u0 } { () } _N_ #-}
-mkSet :: Ord a => [a] -> FiniteMap a ()
+minusSet :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+mkSet :: Ord a => [a] -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 11 _N_ _N_ _N_ _N_ #-}
-plusFM :: Ord a => FiniteMap a b -> FiniteMap a b -> FiniteMap a b
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _N_ _N_ #-}
-setToList :: FiniteMap a () -> [a]
- {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_ #-}
-singletonSet :: a -> FiniteMap a ()
+setToList :: Set a -> [a]
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(S)" {_A_ 1 _U_ 1 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } _N_} _F_ _IF_ARGS_ 1 1 C 3 _/\_ u0 -> \ (u1 :: Set u0) -> case u1 of { _ALG_ _ORIG_ Set MkSet (u2 :: FiniteMap u0 ()) -> _APP_ _TYAPP_ _TYAPP_ _ORIG_ FiniteMap keysFM { () } { u0 } [ u2 ]; _NO_DEFLT_ } _N_ #-}
+singletonSet :: a -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
-union :: Ord a => FiniteMap a () -> FiniteMap a () -> FiniteMap a ()
- {-# GHC_PRAGMA _A_ 1 _U_ 221 _N_ _N_ _F_ _IF_ARGS_ 1 0 X 1 _/\_ u0 -> _TYAPP_ _TYAPP_ _ORIG_ FiniteMap plusFM { u0 } { () } _N_ #-}
-unionManySets :: Ord a => [FiniteMap a ()] -> FiniteMap a ()
+sizeFM :: FiniteMap a b -> Int
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _F_ _IF_ARGS_ 2 1 C 6 _/\_ u0 u1 -> \ (u2 :: FiniteMap u0 u1) -> case u2 of { _ALG_ _ORIG_ FiniteMap EmptyFM -> _!_ I# [] [0#]; _ORIG_ FiniteMap Branch (u3 :: u0) (u4 :: u1) (u5 :: Int#) (u6 :: FiniteMap u0 u1) (u7 :: FiniteMap u0 u1) -> _!_ I# [] [u5]; _NO_DEFLT_ } _N_ #-}
+union :: Ord a => Set a -> Set a -> Set a
+ {-# GHC_PRAGMA _A_ 1 _U_ 211 _N_ _N_ _N_ _N_ #-}
+unionManySets :: Ord a => [Set a] -> Set a
{-# GHC_PRAGMA _A_ 1 _U_ 22 _N_ _N_ _N_ _N_ #-}
+instance (Eq a, Eq b) => Eq (FiniteMap a b)
+ {-# GHC_PRAGMA _M_ FiniteMap {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
+instance Eq a => Eq (Set a)
+ {-# GHC_PRAGMA _M_ Set {-dfun-} _A_ 1 _U_ 2 _N_ _N_ _N_ _N_ #-}
Socket
) where
-
import BSD
import SocketPrim renaming (accept to socketPrim_accept
, socketPort to socketPort_prim
)
-
-
-
\end{code}
-
%***************************************************************************
%* *
-\subsection[Socket-Setup]{High Level "Setup" functions}
+\subsection[Socket-Setup]{High Level ``Setup'' functions}
%* *
%***************************************************************************
type Hostname = String
-- Maybe consider this alternative.
-- data Hostname = Name String | IP Int Int Int Int
-
-
\end{code}
If more control over the socket type is required then $socketPrim$
should be used instead.
-
-
\begin{code}
connectTo :: Hostname -> -- Hostname
PortID -> -- Port Identifier
IO Handle -- Connected Socket
+
connectTo hostname (Service serv) =
getProtocolNumber "tcp" >>= \ proto ->
socket AF_INET Stream proto >>= \ sock ->
getServicePortNumber serv >>= \ port ->
getHostByName hostname >>= \ (HostEntry _ _ _ haddrs) ->
connect sock (SockAddrInet port (head haddrs)) >>
- socketToHandle sock
+ socketToHandle sock >>= \ h ->
+ hSetBuffering h NoBuffering >>
+ return h
connectTo hostname (PortNumber port) =
getProtocolNumber "tcp" >>= \ proto ->
socket AF_INET Stream proto >>= \ sock ->
socketToHandle sock
\end{code}
-
The dual to the $connectTo$ call. This creates the server side
socket which has been bound to the specified port.
\begin{code}
listenOn :: PortID -> -- Port Identifier
IO Socket -- Connected Socket
+
listenOn (Service serv) =
getProtocolNumber "tcp" >>= \ proto ->
socket AF_INET Stream proto >>= \ sock ->
accept :: Socket -> -- Listening Socket
IO (Handle, -- StdIO Handle for read/write
HostName) -- HostName of Peer socket
+
accept sock =
socketPrim_accept sock >>= \ (sock', (SockAddrInet _ haddr)) ->
getHostByAddr AF_INET haddr >>= \ (HostEntry peer _ _ _) ->
PortID-> -- Port Number
String -> -- Message to send
IO ()
+
sendTo h p msg =
connectTo h p >>= \ s ->
hPutStr s msg >>
hClose s
-
-
-
recvFrom :: Hostname -> -- Hostname
PortID-> -- Port Number
IO String -- Received Data
+
recvFrom host port =
listenOn port >>= \ s ->
let
waiting >>= \ message ->
sClose s >>
return message
-
\end{code}
\begin{code}
socketPort :: Socket -> IO PortID
+
socketPort s =
getSocketName s >>= \ sockaddr ->
return (case sockaddr of
SockAddrUnix path ->
(UnixSocket path)
)
-
\end{code}
import PreludeMonadicIO(Either)
import PreludePrimIO(_MVar)
import PreludeStdIO(_Handle)
-data Family = AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_NBS | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_NIT | AF_802 | AF_OSI | AF_X25 | AF_OSINET | AF_GOSSIP | AF_IPX
+data Family = AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_ISO | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_ROUTE | AF_LINK | Pseudo_AF_XTP | AF_NETMAN | AF_X25 | AF_CTF | AF_WAN
type HostAddress = _Word
data SockAddr = SockAddrUnix [Char] | SockAddrInet Int _Word
data Socket
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Family
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Family, [Char])]), (Int -> Family -> [Char] -> [Char]), ([Char] -> [([Family], [Char])]), ([Family] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Family), _CONSTM_ Text showsPrec (Family), _CONSTM_ Text readList (Family), _CONSTM_ Text showList (Family)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text SocketType
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(SocketType, [Char])]), (Int -> SocketType -> [Char] -> [Char]), ([Char] -> [([SocketType], [Char])]), ([SocketType] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (SocketType), _CONSTM_ Text showsPrec (SocketType), _CONSTM_ Text readList (SocketType), _CONSTM_ Text showList (SocketType)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
%
% Last Modified: Fri Jul 21 15:14:43 1995
% Darren J Moffat <moffatd@dcs.gla.ac.uk>
-\section[Socket]{Haskell 1.3 Socket bindings}
+\section[SocketPrim]{Low-level socket bindings}
+The @SocketPrim@ module is for when you want full control over the
+sockets, something like what you have in C (which is very messy).
\begin{code}
module SocketPrim (
\begin{code}
-data SocketStatus =
- -- Returned Status Function called
- NotConnected -- socket
- | Bound -- bindSocket
- | Listening -- listen
- | Connected -- connect/accept
- | Error String -- Any
- deriving (Eq, Text)
-
-data Socket = MkSocket
- Int -- File Descriptor Part
- Family
- SocketType
- Int -- Protocol Number
- (MutableVar _RealWorld SocketStatus) -- Status Flag
-
-
+data SocketStatus
+ -- Returned Status Function called
+ = NotConnected -- socket
+ | Bound -- bindSocket
+ | Listening -- listen
+ | Connected -- connect/accept
+ | Error String -- Any
+ deriving (Eq, Text)
+
+data Socket
+ = MkSocket
+ Int -- File Descriptor Part
+ Family
+ SocketType
+ Int -- Protocol Number
+ (MutableVar _RealWorld SocketStatus) -- Status Flag
\end{code}
-In C bind takes either a $struct sockaddr_in$ or a $struct
-sockaddr_un$ but these are always type cast to $struct sockaddr$. We
+In C bind takes either a $struct sockaddr\_in$ or a $struct
+sockaddr\_un$ but these are always type cast to $struct sockaddr$. We
attempt to emulate this and provide better type checking. Note that
the socket family fields are redundant since this is caputured in the
constructor names, it has thus be left out of the Haskell $SockAddr$
\begin{code}
type HostAddress = _Word
-data SockAddr = -- C Names
- SockAddrUnix -- struct sockaddr_un
+data SockAddr -- C Names
+ = SockAddrUnix -- struct sockaddr_un
String -- sun_path
| SockAddrInet -- struct sockaddr_in
Int -- sin_port
HostAddress -- sin_addr
- deriving Eq
-
+ deriving Eq
\end{code}
particular, have a different meaning to many Haskell programmers and
have thus been renamed by appending the prefix Socket.
-
Create an unconnected socket of the given family, type and protocol.
The most common invocation of $socket$ is the following:
\begin{verbatim}
means that the programmer is only interested in data being sent to
that port number. The $Family$ passed to $bindSocket$ must
be the same as that passed to $socket$. If the special port
-number $aNY_PORT$ is passed then the system assigns the next
+number $aNY\_PORT$ is passed then the system assigns the next
available use port.
Port numbers for standard unix services can be found by calling
1000; although there are afew, namely NFS and IRC, which used higher
numbered ports.
-The port number allocated to a socket bound by using $aNY_PORT$ can be
+The port number allocated to a socket bound by using $aNY\_PORT$ can be
found by calling $port$
\begin{code}
else
writeVar status (Bound) `seqPrimIO`
return ()
-
\end{code}
unpackSockAddr ptr `thenPrimIO` \ addr ->
newVar Connected `thenPrimIO` \ status ->
return ((MkSocket sock family stype protocol status), addr)
-
\end{code}
%************************************************************************
return xs
in
loop ""
-
\end{code}
The port number the given socket is currently connected to can be
determined by calling $port$, is generally only useful when bind
-was given $aNY_PORT$.
+was given $aNY\_PORT$.
\begin{code}
socketPort :: Socket -> -- Connected & Bound Socket
\begin{center}
\begin{tabular}{|l|c|c|c|c|c|c|c|}
\hline
-\textbf{A Call to} & socket & connect & bindSocket & listen & accept & read & write \\
+{\bf A Call to} & socket & connect & bindSocket & listen & accept & read & write \\
\hline
-\textbf{Precedes} & & & & & & & \\
+{\bf Precedes} & & & & & & & \\
\hline
socket & & & & & & & \\
\hline
%************************************************************************
%* *
-\subsection[Socket-OSDefs]{OS Dependant Definitions}
+\subsection[Socket-OSDefs]{OS Dependent Definitions}
%* *
%************************************************************************
from /usr/include/sys/socket.h on the appropriate machines.
Maybe a configure script that could parse the socket.h file to produce
-the following declaration is required to make it "portable" rather than
-using the dreded \#ifdefs.
+the following declaration is required to make it ``portable'' rather than
+using the dreaded \#ifdefs.
Presently only the following machine/os combinations are supported:
\end{itemize}
\begin{code}
-
unpackFamily :: Int -> Family
packFamily :: Family -> Int
packSocketType stype = 1 + (index (Stream, Packet) stype)
#endif
-
\end{code}
%************************************************************************
import PreludeMonadicIO(Either)
import PreludePrimIO(_MVar)
import PreludeStdIO(_Handle)
-data Family = AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_NBS | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_NIT | AF_802 | AF_OSI | AF_X25 | AF_OSINET | AF_GOSSIP | AF_IPX
+data Family = AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_ISO | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_ROUTE | AF_LINK | Pseudo_AF_XTP | AF_NETMAN | AF_X25 | AF_CTF | AF_WAN
type HostAddress = _Word
data SockAddr = SockAddrUnix [Char] | SockAddrInet Int _Word
data Socket
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Family
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Family, [Char])]), (Int -> Family -> [Char] -> [Char]), ([Char] -> [([Family], [Char])]), ([Family] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Family), _CONSTM_ Text showsPrec (Family), _CONSTM_ Text readList (Family), _CONSTM_ Text showList (Family)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text SocketType
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(SocketType, [Char])]), (Int -> SocketType -> [Char] -> [Char]), ([Char] -> [([SocketType], [Char])]), ([SocketType] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (SocketType), _CONSTM_ Text showsPrec (SocketType), _CONSTM_ Text readList (SocketType), _CONSTM_ Text showList (SocketType)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
import PreludeMonadicIO(Either)
import PreludePrimIO(_MVar)
import PreludeStdIO(_Handle)
-data Family = AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_NBS | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_NIT | AF_802 | AF_OSI | AF_X25 | AF_OSINET | AF_GOSSIP | AF_IPX
+data Family = AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_ISO | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_ROUTE | AF_LINK | Pseudo_AF_XTP | AF_NETMAN | AF_X25 | AF_CTF | AF_WAN
type HostAddress = _Word
data SockAddr = SockAddrUnix [Char] | SockAddrInet Int _Word
data Socket
instance Text Family
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Family, [Char])]), (Int -> Family -> [Char] -> [Char]), ([Char] -> [([Family], [Char])]), ([Family] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Family), _CONSTM_ Text showsPrec (Family), _CONSTM_ Text readList (Family), _CONSTM_ Text showList (Family)] _N_
readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text SocketType
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(SocketType, [Char])]), (Int -> SocketType -> [Char] -> [Char]), ([Char] -> [([SocketType], [Char])]), ([SocketType] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (SocketType), _CONSTM_ Text showsPrec (SocketType), _CONSTM_ Text readList (SocketType), _CONSTM_ Text showList (SocketType)] _N_
readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
import PreludeMonadicIO(Either)
import PreludePrimIO(_MVar)
import PreludeStdIO(_Handle)
-data Family = AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_NBS | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_NIT | AF_802 | AF_OSI | AF_X25 | AF_OSINET | AF_GOSSIP | AF_IPX
+data Family = AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_ISO | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_ROUTE | AF_LINK | Pseudo_AF_XTP | AF_NETMAN | AF_X25 | AF_CTF | AF_WAN
type HostAddress = _Word
data SockAddr = SockAddrUnix [Char] | SockAddrInet Int _Word
data Socket
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Family
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Family, [Char])]), (Int -> Family -> [Char] -> [Char]), ([Char] -> [([Family], [Char])]), ([Family] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Family), _CONSTM_ Text showsPrec (Family), _CONSTM_ Text readList (Family), _CONSTM_ Text showList (Family)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text SocketType
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(SocketType, [Char])]), (Int -> SocketType -> [Char] -> [Char]), ([Char] -> [([SocketType], [Char])]), ([SocketType] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (SocketType), _CONSTM_ Text showsPrec (SocketType), _CONSTM_ Text readList (SocketType), _CONSTM_ Text showList (SocketType)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
import PreludeMonadicIO(Either)
import PreludePrimIO(_MVar)
import PreludeStdIO(_Handle)
-data Family = AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_NBS | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_NIT | AF_802 | AF_OSI | AF_X25 | AF_OSINET | AF_GOSSIP | AF_IPX
+data Family = AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_ISO | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_ROUTE | AF_LINK | Pseudo_AF_XTP | AF_NETMAN | AF_X25 | AF_CTF | AF_WAN
type HostAddress = _Word
data SockAddr = SockAddrUnix [Char] | SockAddrInet Int _Word
data Socket
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Family
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Family, [Char])]), (Int -> Family -> [Char] -> [Char]), ([Char] -> [([Family], [Char])]), ([Family] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Family), _CONSTM_ Text showsPrec (Family), _CONSTM_ Text readList (Family), _CONSTM_ Text showList (Family)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text SocketType
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(SocketType, [Char])]), (Int -> SocketType -> [Char] -> [Char]), ([Char] -> [([SocketType], [Char])]), ([SocketType] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (SocketType), _CONSTM_ Text showsPrec (SocketType), _CONSTM_ Text readList (SocketType), _CONSTM_ Text showList (SocketType)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
import PreludeMonadicIO(Either)
import PreludePrimIO(_MVar)
import PreludeStdIO(_Handle)
-data Family = AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_NBS | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_NIT | AF_802 | AF_OSI | AF_X25 | AF_OSINET | AF_GOSSIP | AF_IPX
+data Family = AF_UNSPEC | AF_UNIX | AF_INET | AF_IMPLINK | AF_PUP | AF_CHAOS | AF_NS | AF_ISO | AF_ECMA | AF_DATAKIT | AF_CCITT | AF_SNA | AF_DECnet | AF_DLI | AF_LAT | AF_HYLINK | AF_APPLETALK | AF_ROUTE | AF_LINK | Pseudo_AF_XTP | AF_NETMAN | AF_X25 | AF_CTF | AF_WAN
type HostAddress = _Word
data SockAddr = SockAddrUnix [Char] | SockAddrInet Int _Word
data Socket
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Family
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Family, [Char])]), (Int -> Family -> [Char] -> [Char]), ([Char] -> [([Family], [Char])]), ([Family] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Family), _CONSTM_ Text showsPrec (Family), _CONSTM_ Text readList (Family), _CONSTM_ Text showList (Family)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text SocketType
{-# GHC_PRAGMA _M_ SocketPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(SocketType, [Char])]), (Int -> SocketType -> [Char] -> [Char]), ([Char] -> [([SocketType], [Char])]), ([SocketType] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (SocketType), _CONSTM_ Text showsPrec (SocketType), _CONSTM_ Text readList (SocketType), _CONSTM_ Text showList (SocketType)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
- showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LE" _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
+ showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
readIntArray :: Ix a => _MutableByteArray b a -> a -> _State b -> (Int, _State b)
{-# GHC_PRAGMA _A_ 4 _U_ 1121 _N_ _S_ "U(AASA)U(LP)LU(P)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 111 _N_ _S_ "U(U(U(P)U(P))P)U(P)U(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
readVar :: _MutableArray a Int b -> _State a -> (b, _State a)
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)U(P))P)U(P)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AP)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
returnPrimIO :: a -> _State _RealWorld -> (a, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [u0, (_State _RealWorld)] [u1, u2]; _NO_DEFLT_ } _N_ #-}
returnST :: b -> _State a -> (b, _State a)
writeIntArray :: Ix a => _MutableByteArray b a -> a -> Int -> _State b -> ((), _State b)
{-# GHC_PRAGMA _A_ 5 _U_ 11211 _N_ _S_ "U(AASA)U(LP)LU(P)U(P)" {_A_ 5 _U_ 11222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 4 _U_ 1111 _N_ _S_ "U(U(U(P)U(P))P)U(P)U(P)U(P)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
writeVar :: _MutableArray b Int a -> a -> _State b -> ((), _State b)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(U(U(P)U(P))P)LU(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AP)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Eq _FILE
{-# GHC_PRAGMA _M_ Stdio {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_FILE -> _FILE -> Bool), (_FILE -> _FILE -> Bool)] [_CONSTM_ Eq (==) (_FILE), _CONSTM_ Eq (/=) (_FILE)] _N_
(==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Addr#) (u1 :: Addr#) -> _#_ eqAddr# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: _FILE) (u1 :: _FILE) -> case u0 of { _ALG_ _ORIG_ Stdio _FILE (u2 :: Addr#) -> case u1 of { _ALG_ _ORIG_ Stdio _FILE (u3 :: Addr#) -> _#_ eqAddr# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
writeVar :: MutableVar s a -> a -> _ST s ()
sameVar :: MutableVar s a -> MutableVar s a -> Bool
+{- MUCH GRATUITOUS INEFFICIENCY: WDP 95/09:
+
newVar init s = newArray (0,0) init s
readVar v s = readArray v 0 s
writeVar v val s = writeArray v 0 val s
sameVar v1 v2 = sameMutableArray v1 v2
+-}
+
+newVar init (S# s#)
+ = case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# ->
+ (_MutableArray vAR_IXS arr#, S# s2#) }
+ where
+ vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
+
+readVar (_MutableArray _ var#) (S# s#)
+ = case readArray# var# 0# s# of { StateAndPtr# s2# r ->
+ (r, S# s2#) }
+
+writeVar (_MutableArray _ var#) val (S# s#)
+ = case writeArray# var# 0# val s# of { s2# ->
+ ((), S# s2#) }
+
+sameVar (_MutableArray _ var1#) (_MutableArray _ var2#)
+ = sameMutableArray# var1# var2#
\end{code}
readIntArray :: Ix a => _MutableByteArray b a -> a -> _State b -> (Int, _State b)
{-# GHC_PRAGMA _A_ 4 _U_ 1121 _N_ _S_ "U(AASA)U(LP)LU(P)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 111 _N_ _S_ "U(U(U(P)U(P))P)U(P)U(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
readVar :: _MutableArray a Int b -> _State a -> (b, _State a)
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)U(P))P)U(P)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AP)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
returnPrimIO :: a -> _State _RealWorld -> (a, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [u0, (_State _RealWorld)] [u1, u2]; _NO_DEFLT_ } _N_ #-}
returnST :: b -> _State a -> (b, _State a)
writeIntArray :: Ix a => _MutableByteArray b a -> a -> Int -> _State b -> ((), _State b)
{-# GHC_PRAGMA _A_ 5 _U_ 11211 _N_ _S_ "U(AASA)U(LP)LU(P)U(P)" {_A_ 5 _U_ 11222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 4 _U_ 1111 _N_ _S_ "U(U(U(P)U(P))P)U(P)U(P)U(P)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
writeVar :: _MutableArray b Int a -> a -> _State b -> ((), _State b)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(U(U(P)U(P))P)LU(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AP)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Eq _FILE
{-# GHC_PRAGMA _M_ Stdio {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_FILE -> _FILE -> Bool), (_FILE -> _FILE -> Bool)] [_CONSTM_ Eq (==) (_FILE), _CONSTM_ Eq (/=) (_FILE)] _N_
(==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Addr#) (u1 :: Addr#) -> _#_ eqAddr# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: _FILE) (u1 :: _FILE) -> case u0 of { _ALG_ _ORIG_ Stdio _FILE (u2 :: Addr#) -> case u1 of { _ALG_ _ORIG_ Stdio _FILE (u3 :: Addr#) -> _#_ eqAddr# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
readIntArray :: Ix a => _MutableByteArray b a -> a -> _State b -> (Int, _State b)
{-# GHC_PRAGMA _A_ 4 _U_ 1121 _N_ _S_ "U(AASA)U(LP)LU(P)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 111 _N_ _S_ "U(U(U(P)U(P))P)U(P)U(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
readVar :: _MutableArray a Int b -> _State a -> (b, _State a)
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)U(P))P)U(P)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AP)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
returnPrimIO :: a -> _State _RealWorld -> (a, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [u0, (_State _RealWorld)] [u1, u2]; _NO_DEFLT_ } _N_ #-}
returnST :: b -> _State a -> (b, _State a)
writeIntArray :: Ix a => _MutableByteArray b a -> a -> Int -> _State b -> ((), _State b)
{-# GHC_PRAGMA _A_ 5 _U_ 11211 _N_ _S_ "U(AASA)U(LP)LU(P)U(P)" {_A_ 5 _U_ 11222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 4 _U_ 1111 _N_ _S_ "U(U(U(P)U(P))P)U(P)U(P)U(P)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
writeVar :: _MutableArray b Int a -> a -> _State b -> ((), _State b)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(U(U(P)U(P))P)LU(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AP)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Eq _FILE
{-# GHC_PRAGMA _M_ Stdio {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_FILE -> _FILE -> Bool), (_FILE -> _FILE -> Bool)] [_CONSTM_ Eq (==) (_FILE), _CONSTM_ Eq (/=) (_FILE)] _N_
(==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Addr#) (u1 :: Addr#) -> _#_ eqAddr# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: _FILE) (u1 :: _FILE) -> case u0 of { _ALG_ _ORIG_ Stdio _FILE (u2 :: Addr#) -> case u1 of { _ALG_ _ORIG_ Stdio _FILE (u3 :: Addr#) -> _#_ eqAddr# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
readIntArray :: Ix a => _MutableByteArray b a -> a -> _State b -> (Int, _State b)
{-# GHC_PRAGMA _A_ 4 _U_ 1121 _N_ _S_ "U(AASA)U(LP)LU(P)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 111 _N_ _S_ "U(U(U(P)U(P))P)U(P)U(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
readVar :: _MutableArray a Int b -> _State a -> (b, _State a)
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)U(P))P)U(P)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AP)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
returnPrimIO :: a -> _State _RealWorld -> (a, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [u0, (_State _RealWorld)] [u1, u2]; _NO_DEFLT_ } _N_ #-}
returnST :: b -> _State a -> (b, _State a)
writeIntArray :: Ix a => _MutableByteArray b a -> a -> Int -> _State b -> ((), _State b)
{-# GHC_PRAGMA _A_ 5 _U_ 11211 _N_ _S_ "U(AASA)U(LP)LU(P)U(P)" {_A_ 5 _U_ 11222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 4 _U_ 1111 _N_ _S_ "U(U(U(P)U(P))P)U(P)U(P)U(P)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
writeVar :: _MutableArray b Int a -> a -> _State b -> ((), _State b)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(U(U(P)U(P))P)LU(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AP)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Eq _FILE
{-# GHC_PRAGMA _M_ Stdio {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_FILE -> _FILE -> Bool), (_FILE -> _FILE -> Bool)] [_CONSTM_ Eq (==) (_FILE), _CONSTM_ Eq (/=) (_FILE)] _N_
(==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Addr#) (u1 :: Addr#) -> _#_ eqAddr# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: _FILE) (u1 :: _FILE) -> case u0 of { _ALG_ _ORIG_ Stdio _FILE (u2 :: Addr#) -> case u1 of { _ALG_ _ORIG_ Stdio _FILE (u3 :: Addr#) -> _#_ eqAddr# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
readIntArray :: Ix a => _MutableByteArray b a -> a -> _State b -> (Int, _State b)
{-# GHC_PRAGMA _A_ 4 _U_ 1121 _N_ _S_ "U(AASA)U(LP)LU(P)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 111 _N_ _S_ "U(U(U(P)U(P))P)U(P)U(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
readVar :: _MutableArray a Int b -> _State a -> (b, _State a)
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)U(P))P)U(P)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AP)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
returnPrimIO :: a -> _State _RealWorld -> (a, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [u0, (_State _RealWorld)] [u1, u2]; _NO_DEFLT_ } _N_ #-}
returnST :: b -> _State a -> (b, _State a)
writeIntArray :: Ix a => _MutableByteArray b a -> a -> Int -> _State b -> ((), _State b)
{-# GHC_PRAGMA _A_ 5 _U_ 11211 _N_ _S_ "U(AASA)U(LP)LU(P)U(P)" {_A_ 5 _U_ 11222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 4 _U_ 1111 _N_ _S_ "U(U(U(P)U(P))P)U(P)U(P)U(P)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
writeVar :: _MutableArray b Int a -> a -> _State b -> ((), _State b)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(U(U(P)U(P))P)LU(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AP)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Eq _FILE
{-# GHC_PRAGMA _M_ Stdio {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_FILE -> _FILE -> Bool), (_FILE -> _FILE -> Bool)] [_CONSTM_ Eq (==) (_FILE), _CONSTM_ Eq (/=) (_FILE)] _N_
(==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Addr#) (u1 :: Addr#) -> _#_ eqAddr# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: _FILE) (u1 :: _FILE) -> case u0 of { _ALG_ _ORIG_ Stdio _FILE (u2 :: Addr#) -> case u1 of { _ALG_ _ORIG_ Stdio _FILE (u3 :: Addr#) -> _#_ eqAddr# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
readIntArray :: Ix a => _MutableByteArray b a -> a -> _State b -> (Int, _State b)
{-# GHC_PRAGMA _A_ 4 _U_ 1121 _N_ _S_ "U(AASA)U(LP)LU(P)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 3 _U_ 111 _N_ _S_ "U(U(U(P)U(P))P)U(P)U(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
readVar :: _MutableArray a Int b -> _State a -> (b, _State a)
- {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(U(U(P)U(P))P)U(P)" {_A_ 4 _U_ 2222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 2 _U_ 11 _N_ _S_ "U(AP)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
returnPrimIO :: a -> _State _RealWorld -> (a, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "LS" _F_ _ALWAYS_ _/\_ u0 -> \ (u1 :: u0) (u2 :: _State _RealWorld) -> case u2 of { _ALG_ S# (u3 :: State# _RealWorld) -> _!_ _TUP_2 [u0, (_State _RealWorld)] [u1, u2]; _NO_DEFLT_ } _N_ #-}
returnST :: b -> _State a -> (b, _State a)
writeIntArray :: Ix a => _MutableByteArray b a -> a -> Int -> _State b -> ((), _State b)
{-# GHC_PRAGMA _A_ 5 _U_ 11211 _N_ _S_ "U(AASA)U(LP)LU(P)U(P)" {_A_ 5 _U_ 11222 _N_ _N_ _N_ _N_} _N_ _SPECIALISE_ [ Int, _N_ ] 1 { _A_ 4 _U_ 1111 _N_ _S_ "U(U(U(P)U(P))P)U(P)U(P)U(P)" {_A_ 5 _U_ 12222 _N_ _N_ _N_ _N_} _N_ _N_ } #-}
writeVar :: _MutableArray b Int a -> a -> _State b -> ((), _State b)
- {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(U(U(P)U(P))P)LU(P)" {_A_ 5 _U_ 22222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AP)LU(P)" {_A_ 3 _U_ 222 _N_ _N_ _N_ _N_} _N_ _N_ #-}
instance Eq _FILE
{-# GHC_PRAGMA _M_ Stdio {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_FILE -> _FILE -> Bool), (_FILE -> _FILE -> Bool)] [_CONSTM_ Eq (==) (_FILE), _CONSTM_ Eq (/=) (_FILE)] _N_
(==) = _A_ 2 _U_ 11 _N_ _S_ "U(P)U(P)" {_A_ 2 _U_ 22 _N_ _N_ _F_ _IF_ARGS_ 0 2 XX 1 \ (u0 :: Addr#) (u1 :: Addr#) -> _#_ eqAddr# [] [u0, u1] _N_} _F_ _IF_ARGS_ 0 2 CC 3 \ (u0 :: _FILE) (u1 :: _FILE) -> case u0 of { _ALG_ _ORIG_ Stdio _FILE (u2 :: Addr#) -> case u1 of { _ALG_ _ORIG_ Stdio _FILE (u3 :: Addr#) -> _#_ eqAddr# [] [u2, u3]; _NO_DEFLT_ }; _NO_DEFLT_ } _N_,
getCPUTime :: IO Integer
getCPUTime =
- _ccall_ getCPUTime `thenPrimIO` \ ptr@(A# ptr#) ->
- if ptr /= ``NULL'' then
- return (fromInt (I# (indexIntOffAddr# ptr# 0#)) * 1000000000 +
- fromInt (I# (indexIntOffAddr# ptr# 1#)) +
- fromInt (I# (indexIntOffAddr# ptr# 2#)) * 1000000000 +
- fromInt (I# (indexIntOffAddr# ptr# 3#)))
+ newIntArray (0,3) `thenPrimIO` \ marr ->
+ unsafeFreezeByteArray marr `thenPrimIO` \ barr@(_ByteArray _ frozen#) ->
+ _ccall_ getCPUTime barr `thenPrimIO` \ ptr ->
+ if (ptr::_Addr) /= ``NULL'' then
+ return (fromInt (I# (indexIntArray# frozen# 0#)) * 1000000000 +
+ fromInt (I# (indexIntArray# frozen# 1#)) +
+ fromInt (I# (indexIntArray# frozen# 2#)) * 1000000000 +
+ fromInt (I# (indexIntArray# frozen# 3#)))
else
failWith (UnsupportedOperation "can't get CPU time")
+
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface LibPosix where
-import LibDirectory(removeDirectory)
+import LibDirectory(getCurrentDirectory, removeDirectory, setCurrentDirectory)
import LibPosixDB(GroupEntry(..), UserEntry(..), getGroupEntryForID, getGroupEntryForName, getUserEntryForID, getUserEntryForName, groupID, groupMembers, groupName, homeDirectory, userGroupID, userID, userName, userShell)
import LibPosixErr(ErrorCode(..), argumentListTooLong, badChannel, brokenPipe, directoryNotEmpty, e2BIG, eACCES, eAGAIN, eBADF, eBUSY, eCHILD, eDEADLK, eEXIST, eFBIG, eINTR, eINVAL, eIO, eISDIR, eMFILE, eMLINK, eNAMETOOLONG, eNFILE, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOMEM, eNOSPC, eNOSYS, eNOTDIR, eNOTEMPTY, eNOTTY, eNXIO, ePERM, ePIPE, eROFS, eSPIPE, eSRCH, eXDEV, execFormatError, fileAlreadyExists, fileTooLarge, filenameTooLong, getErrorCode, improperLink, inappropriateIOControlOperation, inputOutputError, interruptedOperation, invalidArgument, invalidSeek, isADirectory, noChildProcess, noError, noLocksAvailable, noSpaceLeftOnDevice, noSuchDeviceOrAddress, noSuchFileOrDirectory, noSuchOperationOnDevice, noSuchProcess, notADirectory, notEnoughMemory, operationNotImplemented, operationNotPermitted, permissionDenied, readOnlyFileSystem, resourceBusy, resourceDeadlockAvoided, resourceTemporarilyUnavailable, setErrorCode, tooManyLinks, tooManyOpenFiles, tooManyOpenFilesInSystem)
import LibPosixFiles(DeviceID(..), DirStream(..), FileID(..), FileMode(..), FileStatus(..), OpenMode(..), PathVar(..), accessModes, accessTime, changeWorkingDirectory, closeDirStream, createDirectory, createFile, createLink, createNamedPipe, deviceID, fileGroup, fileID, fileMode, fileOwner, fileSize, getChannelStatus, getChannelVar, getFileStatus, getPathVar, getWorkingDirectory, groupExecuteMode, groupModes, groupReadMode, groupWriteMode, intersectFileModes, isBlockDevice, isCharacterDevice, isDirectory, isNamedPipe, isRegularFile, linkCount, modificationTime, nullFileMode, openChannel, openDirStream, otherExecuteMode, otherModes, otherReadMode, otherWriteMode, ownerExecuteMode, ownerModes, ownerReadMode, ownerWriteMode, queryAccess, queryFile, readDirStream, removeLink, rename, rewindDirStream, setFileCreationMask, setFileMode, setFileTimes, setGroupIDMode, setOwnerAndGroup, setUserIDMode, statusChangeTime, stdError, stdFileMode, stdInput, stdOutput, touchFile, unionFileModes)
type ProcessID = Int
type UserID = Int
data ExitCode {-# GHC_PRAGMA ExitSuccess | ExitFailure Int #-}
+getCurrentDirectory :: _State _RealWorld -> (Either IOError13 [Char], _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
removeDirectory :: [Char] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getGroupEntryForID :: Int -> _State _RealWorld -> (Either IOError13 GroupEntry, _State _RealWorld)
nullFileMode :: _Word
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
openChannel :: [Char] -> OpenMode -> Maybe _Word -> Bool -> Bool -> Bool -> Bool -> Bool -> _State _RealWorld -> (Either IOError13 Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 9 _U_ 202111112 _N_ _S_ "SASEEEEEL" {_A_ 8 _U_ 22111112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 9 _U_ 212111112 _N_ _S_ "SESEEEEEL" _N_ _N_ #-}
openDirStream :: [Char] -> _State _RealWorld -> (Either IOError13 _Addr, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
otherExecuteMode :: _Word
{-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
runProcess :: [Char] -> [[Char]] -> Maybe [([Char], [Char])] -> Maybe [Char] -> Maybe (_MVar _Handle) -> Maybe (_MVar _Handle) -> Maybe (_MVar _Handle) -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 8 _U_ 22111111 _N_ _S_ "LLLLLLLU(P)" _N_ _N_ #-}
+setCurrentDirectory :: [Char] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
userGroupID :: UserEntry -> Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: UserEntry) -> case u0 of { _ALG_ _ORIG_ LibPosixDB UE (u1 :: [Char]) (u2 :: Int) (u3 :: Int) (u4 :: [Char]) (u5 :: [Char]) -> u3; _NO_DEFLT_ } _N_ #-}
userID :: UserEntry -> Int
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ProcessStatus
{-# GHC_PRAGMA _M_ LibPosixProcPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ProcessStatus, [Char])]), (Int -> ProcessStatus -> [Char] -> [Char]), ([Char] -> [([ProcessStatus], [Char])]), ([ProcessStatus] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ProcessStatus), _CONSTM_ Text showsPrec (ProcessStatus), _CONSTM_ Text readList (ProcessStatus), _CONSTM_ Text showList (ProcessStatus)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
ProcessGroupID(..),
UserID(..),
- ExitCode
- ) where
+ ExitCode,
+
+ -- make interface complete:
+ setCurrentDirectory{-pragmas-}, getCurrentDirectory{-pragmas-}
+ ) where
import LibPosixDB
import LibPosixErr
-- runProcess is our candidate for the high-level OS-independent primitive
-- If accepted, it will be moved out of LibPosix into LibSystem.
-import LibDirectory ( setCurrentDirectory )
+import LibDirectory ( setCurrentDirectory, getCurrentDirectory{-pragmas-} )
import PreludeGlaST
import PreludePrimIO ( takeMVar, putMVar, _MVar )
nullFileMode :: _Word
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
openChannel :: [Char] -> OpenMode -> Maybe _Word -> Bool -> Bool -> Bool -> Bool -> Bool -> _State _RealWorld -> (Either IOError13 Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 9 _U_ 202111112 _N_ _S_ "SASEEEEEL" {_A_ 8 _U_ 22111112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 9 _U_ 212111112 _N_ _S_ "SESEEEEEL" _N_ _N_ #-}
openDirStream :: [Char] -> _State _RealWorld -> (Either IOError13 _Addr, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
otherExecuteMode :: _Word
creat# = case creat of { W# x -> x }
flags = W# (creat# `or#` append# `or#` excl# `or#`
- noctty# `or#` nonblock# `or#` trunc#)
+ noctty# `or#` nonblock# `or#` trunc# `or#` how#)
+ how# = case (case how of { ReadOnly -> ``O_RDONLY'';WriteOnly -> ``O_WRONLY'';ReadWrite -> ``O_RDWR''}) of { W# x -> x }
append# = case (if append then ``O_APPEND'' else ``0'') of { W# x -> x }
excl# = case (if excl then ``O_EXCL'' else ``0'') of { W# x -> x }
noctty# = case (if noctty then ``O_NOCTTY'' else ``0'') of { W# x -> x }
nullFileMode :: _Word
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
openChannel :: [Char] -> OpenMode -> Maybe _Word -> Bool -> Bool -> Bool -> Bool -> Bool -> _State _RealWorld -> (Either IOError13 Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 9 _U_ 202111112 _N_ _S_ "SASEEEEEL" {_A_ 8 _U_ 22111112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 9 _U_ 212111112 _N_ _S_ "SESEEEEEL" _N_ _N_ #-}
openDirStream :: [Char] -> _State _RealWorld -> (Either IOError13 _Addr, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
otherExecuteMode :: _Word
nullFileMode :: _Word
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
openChannel :: [Char] -> OpenMode -> Maybe _Word -> Bool -> Bool -> Bool -> Bool -> Bool -> _State _RealWorld -> (Either IOError13 Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 9 _U_ 202111112 _N_ _S_ "SASEEEEEL" {_A_ 8 _U_ 22111112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 9 _U_ 212111112 _N_ _S_ "SESEEEEEL" _N_ _N_ #-}
openDirStream :: [Char] -> _State _RealWorld -> (Either IOError13 _Addr, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
otherExecuteMode :: _Word
nullFileMode :: _Word
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
openChannel :: [Char] -> OpenMode -> Maybe _Word -> Bool -> Bool -> Bool -> Bool -> Bool -> _State _RealWorld -> (Either IOError13 Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 9 _U_ 202111112 _N_ _S_ "SASEEEEEL" {_A_ 8 _U_ 22111112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 9 _U_ 212111112 _N_ _S_ "SESEEEEEL" _N_ _N_ #-}
openDirStream :: [Char] -> _State _RealWorld -> (Either IOError13 _Addr, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
otherExecuteMode :: _Word
nullFileMode :: _Word
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
openChannel :: [Char] -> OpenMode -> Maybe _Word -> Bool -> Bool -> Bool -> Bool -> Bool -> _State _RealWorld -> (Either IOError13 Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 9 _U_ 202111112 _N_ _S_ "SASEEEEEL" {_A_ 8 _U_ 22111112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 9 _U_ 212111112 _N_ _S_ "SESEEEEEL" _N_ _N_ #-}
openDirStream :: [Char] -> _State _RealWorld -> (Either IOError13 _Addr, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
otherExecuteMode :: _Word
nullFileMode :: _Word
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
openChannel :: [Char] -> OpenMode -> Maybe _Word -> Bool -> Bool -> Bool -> Bool -> Bool -> _State _RealWorld -> (Either IOError13 Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 9 _U_ 202111112 _N_ _S_ "SASEEEEEL" {_A_ 8 _U_ 22111112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 9 _U_ 212111112 _N_ _S_ "SESEEEEEL" _N_ _N_ #-}
openDirStream :: [Char] -> _State _RealWorld -> (Either IOError13 _Addr, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
otherExecuteMode :: _Word
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ProcessStatus
{-# GHC_PRAGMA _M_ LibPosixProcPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ProcessStatus, [Char])]), (Int -> ProcessStatus -> [Char] -> [Char]), ([Char] -> [([ProcessStatus], [Char])]), ([ProcessStatus] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ProcessStatus), _CONSTM_ Text showsPrec (ProcessStatus), _CONSTM_ Text readList (ProcessStatus), _CONSTM_ Text showList (ProcessStatus)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ProcessStatus
{-# GHC_PRAGMA _M_ LibPosixProcPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ProcessStatus, [Char])]), (Int -> ProcessStatus -> [Char] -> [Char]), ([Char] -> [([ProcessStatus], [Char])]), ([ProcessStatus] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ProcessStatus), _CONSTM_ Text showsPrec (ProcessStatus), _CONSTM_ Text readList (ProcessStatus), _CONSTM_ Text showList (ProcessStatus)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ProcessStatus
{-# GHC_PRAGMA _M_ LibPosixProcPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ProcessStatus, [Char])]), (Int -> ProcessStatus -> [Char] -> [Char]), ([Char] -> [([ProcessStatus], [Char])]), ([ProcessStatus] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ProcessStatus), _CONSTM_ Text showsPrec (ProcessStatus), _CONSTM_ Text readList (ProcessStatus), _CONSTM_ Text showList (ProcessStatus)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ProcessStatus
{-# GHC_PRAGMA _M_ LibPosixProcPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ProcessStatus, [Char])]), (Int -> ProcessStatus -> [Char] -> [Char]), ([Char] -> [([ProcessStatus], [Char])]), ([ProcessStatus] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ProcessStatus), _CONSTM_ Text showsPrec (ProcessStatus), _CONSTM_ Text readList (ProcessStatus), _CONSTM_ Text showList (ProcessStatus)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ProcessStatus
{-# GHC_PRAGMA _M_ LibPosixProcPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ProcessStatus, [Char])]), (Int -> ProcessStatus -> [Char] -> [Char]), ([Char] -> [([ProcessStatus], [Char])]), ([ProcessStatus] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ProcessStatus), _CONSTM_ Text showsPrec (ProcessStatus), _CONSTM_ Text readList (ProcessStatus), _CONSTM_ Text showList (ProcessStatus)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface LibPosix where
-import LibDirectory(removeDirectory)
+import LibDirectory(getCurrentDirectory, removeDirectory, setCurrentDirectory)
import LibPosixDB(GroupEntry(..), UserEntry(..), getGroupEntryForID, getGroupEntryForName, getUserEntryForID, getUserEntryForName, groupID, groupMembers, groupName, homeDirectory, userGroupID, userID, userName, userShell)
import LibPosixErr(ErrorCode(..), argumentListTooLong, badChannel, brokenPipe, directoryNotEmpty, e2BIG, eACCES, eAGAIN, eBADF, eBUSY, eCHILD, eDEADLK, eEXIST, eFBIG, eINTR, eINVAL, eIO, eISDIR, eMFILE, eMLINK, eNAMETOOLONG, eNFILE, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOMEM, eNOSPC, eNOSYS, eNOTDIR, eNOTEMPTY, eNOTTY, eNXIO, ePERM, ePIPE, eROFS, eSPIPE, eSRCH, eXDEV, execFormatError, fileAlreadyExists, fileTooLarge, filenameTooLong, getErrorCode, improperLink, inappropriateIOControlOperation, inputOutputError, interruptedOperation, invalidArgument, invalidSeek, isADirectory, noChildProcess, noError, noLocksAvailable, noSpaceLeftOnDevice, noSuchDeviceOrAddress, noSuchFileOrDirectory, noSuchOperationOnDevice, noSuchProcess, notADirectory, notEnoughMemory, operationNotImplemented, operationNotPermitted, permissionDenied, readOnlyFileSystem, resourceBusy, resourceDeadlockAvoided, resourceTemporarilyUnavailable, setErrorCode, tooManyLinks, tooManyOpenFiles, tooManyOpenFilesInSystem)
import LibPosixFiles(DeviceID(..), DirStream(..), FileID(..), FileMode(..), FileStatus(..), OpenMode(..), PathVar(..), accessModes, accessTime, changeWorkingDirectory, closeDirStream, createDirectory, createFile, createLink, createNamedPipe, deviceID, fileGroup, fileID, fileMode, fileOwner, fileSize, getChannelStatus, getChannelVar, getFileStatus, getPathVar, getWorkingDirectory, groupExecuteMode, groupModes, groupReadMode, groupWriteMode, intersectFileModes, isBlockDevice, isCharacterDevice, isDirectory, isNamedPipe, isRegularFile, linkCount, modificationTime, nullFileMode, openChannel, openDirStream, otherExecuteMode, otherModes, otherReadMode, otherWriteMode, ownerExecuteMode, ownerModes, ownerReadMode, ownerWriteMode, queryAccess, queryFile, readDirStream, removeLink, rename, rewindDirStream, setFileCreationMask, setFileMode, setFileTimes, setGroupIDMode, setOwnerAndGroup, setUserIDMode, statusChangeTime, stdError, stdFileMode, stdInput, stdOutput, touchFile, unionFileModes)
type ProcessID = Int
type UserID = Int
data ExitCode {-# GHC_PRAGMA ExitSuccess | ExitFailure Int #-}
+getCurrentDirectory :: _State _RealWorld -> (Either IOError13 [Char], _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
removeDirectory :: [Char] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getGroupEntryForID :: Int -> _State _RealWorld -> (Either IOError13 GroupEntry, _State _RealWorld)
nullFileMode :: _Word
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
openChannel :: [Char] -> OpenMode -> Maybe _Word -> Bool -> Bool -> Bool -> Bool -> Bool -> _State _RealWorld -> (Either IOError13 Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 9 _U_ 202111112 _N_ _S_ "SASEEEEEL" {_A_ 8 _U_ 22111112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 9 _U_ 212111112 _N_ _S_ "SESEEEEEL" _N_ _N_ #-}
openDirStream :: [Char] -> _State _RealWorld -> (Either IOError13 _Addr, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
otherExecuteMode :: _Word
{-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
runProcess :: [Char] -> [[Char]] -> Maybe [([Char], [Char])] -> Maybe [Char] -> Maybe (_MVar _Handle) -> Maybe (_MVar _Handle) -> Maybe (_MVar _Handle) -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 8 _U_ 22111111 _N_ _S_ "LLLLLLLU(P)" _N_ _N_ #-}
+setCurrentDirectory :: [Char] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
userGroupID :: UserEntry -> Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: UserEntry) -> case u0 of { _ALG_ _ORIG_ LibPosixDB UE (u1 :: [Char]) (u2 :: Int) (u3 :: Int) (u4 :: [Char]) (u5 :: [Char]) -> u3; _NO_DEFLT_ } _N_ #-}
userID :: UserEntry -> Int
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ProcessStatus
{-# GHC_PRAGMA _M_ LibPosixProcPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ProcessStatus, [Char])]), (Int -> ProcessStatus -> [Char] -> [Char]), ([Char] -> [([ProcessStatus], [Char])]), ([ProcessStatus] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ProcessStatus), _CONSTM_ Text showsPrec (ProcessStatus), _CONSTM_ Text readList (ProcessStatus), _CONSTM_ Text showList (ProcessStatus)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface LibPosix where
-import LibDirectory(removeDirectory)
+import LibDirectory(getCurrentDirectory, removeDirectory, setCurrentDirectory)
import LibPosixDB(GroupEntry(..), UserEntry(..), getGroupEntryForID, getGroupEntryForName, getUserEntryForID, getUserEntryForName, groupID, groupMembers, groupName, homeDirectory, userGroupID, userID, userName, userShell)
import LibPosixErr(ErrorCode(..), argumentListTooLong, badChannel, brokenPipe, directoryNotEmpty, e2BIG, eACCES, eAGAIN, eBADF, eBUSY, eCHILD, eDEADLK, eEXIST, eFBIG, eINTR, eINVAL, eIO, eISDIR, eMFILE, eMLINK, eNAMETOOLONG, eNFILE, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOMEM, eNOSPC, eNOSYS, eNOTDIR, eNOTEMPTY, eNOTTY, eNXIO, ePERM, ePIPE, eROFS, eSPIPE, eSRCH, eXDEV, execFormatError, fileAlreadyExists, fileTooLarge, filenameTooLong, getErrorCode, improperLink, inappropriateIOControlOperation, inputOutputError, interruptedOperation, invalidArgument, invalidSeek, isADirectory, noChildProcess, noError, noLocksAvailable, noSpaceLeftOnDevice, noSuchDeviceOrAddress, noSuchFileOrDirectory, noSuchOperationOnDevice, noSuchProcess, notADirectory, notEnoughMemory, operationNotImplemented, operationNotPermitted, permissionDenied, readOnlyFileSystem, resourceBusy, resourceDeadlockAvoided, resourceTemporarilyUnavailable, setErrorCode, tooManyLinks, tooManyOpenFiles, tooManyOpenFilesInSystem)
import LibPosixFiles(DeviceID(..), DirStream(..), FileID(..), FileMode(..), FileStatus(..), OpenMode(..), PathVar(..), accessModes, accessTime, changeWorkingDirectory, closeDirStream, createDirectory, createFile, createLink, createNamedPipe, deviceID, fileGroup, fileID, fileMode, fileOwner, fileSize, getChannelStatus, getChannelVar, getFileStatus, getPathVar, getWorkingDirectory, groupExecuteMode, groupModes, groupReadMode, groupWriteMode, intersectFileModes, isBlockDevice, isCharacterDevice, isDirectory, isNamedPipe, isRegularFile, linkCount, modificationTime, nullFileMode, openChannel, openDirStream, otherExecuteMode, otherModes, otherReadMode, otherWriteMode, ownerExecuteMode, ownerModes, ownerReadMode, ownerWriteMode, queryAccess, queryFile, readDirStream, removeLink, rename, rewindDirStream, setFileCreationMask, setFileMode, setFileTimes, setGroupIDMode, setOwnerAndGroup, setUserIDMode, statusChangeTime, stdError, stdFileMode, stdInput, stdOutput, touchFile, unionFileModes)
type ProcessID = Int
type UserID = Int
data ExitCode {-# GHC_PRAGMA ExitSuccess | ExitFailure Int #-}
+getCurrentDirectory :: _State _RealWorld -> (Either IOError13 [Char], _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
removeDirectory :: [Char] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getGroupEntryForID :: Int -> _State _RealWorld -> (Either IOError13 GroupEntry, _State _RealWorld)
nullFileMode :: _Word
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
openChannel :: [Char] -> OpenMode -> Maybe _Word -> Bool -> Bool -> Bool -> Bool -> Bool -> _State _RealWorld -> (Either IOError13 Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 9 _U_ 202111112 _N_ _S_ "SASEEEEEL" {_A_ 8 _U_ 22111112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 9 _U_ 212111112 _N_ _S_ "SESEEEEEL" _N_ _N_ #-}
openDirStream :: [Char] -> _State _RealWorld -> (Either IOError13 _Addr, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
otherExecuteMode :: _Word
{-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
runProcess :: [Char] -> [[Char]] -> Maybe [([Char], [Char])] -> Maybe [Char] -> Maybe (_MVar _Handle) -> Maybe (_MVar _Handle) -> Maybe (_MVar _Handle) -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 8 _U_ 22111111 _N_ _S_ "LLLLLLLU(P)" _N_ _N_ #-}
+setCurrentDirectory :: [Char] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
userGroupID :: UserEntry -> Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: UserEntry) -> case u0 of { _ALG_ _ORIG_ LibPosixDB UE (u1 :: [Char]) (u2 :: Int) (u3 :: Int) (u4 :: [Char]) (u5 :: [Char]) -> u3; _NO_DEFLT_ } _N_ #-}
userID :: UserEntry -> Int
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface LibPosix where
-import LibDirectory(removeDirectory)
+import LibDirectory(getCurrentDirectory, removeDirectory, setCurrentDirectory)
import LibPosixDB(GroupEntry(..), UserEntry(..), getGroupEntryForID, getGroupEntryForName, getUserEntryForID, getUserEntryForName, groupID, groupMembers, groupName, homeDirectory, userGroupID, userID, userName, userShell)
import LibPosixErr(ErrorCode(..), argumentListTooLong, badChannel, brokenPipe, directoryNotEmpty, e2BIG, eACCES, eAGAIN, eBADF, eBUSY, eCHILD, eDEADLK, eEXIST, eFBIG, eINTR, eINVAL, eIO, eISDIR, eMFILE, eMLINK, eNAMETOOLONG, eNFILE, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOMEM, eNOSPC, eNOSYS, eNOTDIR, eNOTEMPTY, eNOTTY, eNXIO, ePERM, ePIPE, eROFS, eSPIPE, eSRCH, eXDEV, execFormatError, fileAlreadyExists, fileTooLarge, filenameTooLong, getErrorCode, improperLink, inappropriateIOControlOperation, inputOutputError, interruptedOperation, invalidArgument, invalidSeek, isADirectory, noChildProcess, noError, noLocksAvailable, noSpaceLeftOnDevice, noSuchDeviceOrAddress, noSuchFileOrDirectory, noSuchOperationOnDevice, noSuchProcess, notADirectory, notEnoughMemory, operationNotImplemented, operationNotPermitted, permissionDenied, readOnlyFileSystem, resourceBusy, resourceDeadlockAvoided, resourceTemporarilyUnavailable, setErrorCode, tooManyLinks, tooManyOpenFiles, tooManyOpenFilesInSystem)
import LibPosixFiles(DeviceID(..), DirStream(..), FileID(..), FileMode(..), FileStatus(..), OpenMode(..), PathVar(..), accessModes, accessTime, changeWorkingDirectory, closeDirStream, createDirectory, createFile, createLink, createNamedPipe, deviceID, fileGroup, fileID, fileMode, fileOwner, fileSize, getChannelStatus, getChannelVar, getFileStatus, getPathVar, getWorkingDirectory, groupExecuteMode, groupModes, groupReadMode, groupWriteMode, intersectFileModes, isBlockDevice, isCharacterDevice, isDirectory, isNamedPipe, isRegularFile, linkCount, modificationTime, nullFileMode, openChannel, openDirStream, otherExecuteMode, otherModes, otherReadMode, otherWriteMode, ownerExecuteMode, ownerModes, ownerReadMode, ownerWriteMode, queryAccess, queryFile, readDirStream, removeLink, rename, rewindDirStream, setFileCreationMask, setFileMode, setFileTimes, setGroupIDMode, setOwnerAndGroup, setUserIDMode, statusChangeTime, stdError, stdFileMode, stdInput, stdOutput, touchFile, unionFileModes)
type ProcessID = Int
type UserID = Int
data ExitCode {-# GHC_PRAGMA ExitSuccess | ExitFailure Int #-}
+getCurrentDirectory :: _State _RealWorld -> (Either IOError13 [Char], _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
removeDirectory :: [Char] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getGroupEntryForID :: Int -> _State _RealWorld -> (Either IOError13 GroupEntry, _State _RealWorld)
nullFileMode :: _Word
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
openChannel :: [Char] -> OpenMode -> Maybe _Word -> Bool -> Bool -> Bool -> Bool -> Bool -> _State _RealWorld -> (Either IOError13 Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 9 _U_ 202111112 _N_ _S_ "SASEEEEEL" {_A_ 8 _U_ 22111112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 9 _U_ 212111112 _N_ _S_ "SESEEEEEL" _N_ _N_ #-}
openDirStream :: [Char] -> _State _RealWorld -> (Either IOError13 _Addr, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
otherExecuteMode :: _Word
{-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
runProcess :: [Char] -> [[Char]] -> Maybe [([Char], [Char])] -> Maybe [Char] -> Maybe (_MVar _Handle) -> Maybe (_MVar _Handle) -> Maybe (_MVar _Handle) -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 8 _U_ 22111111 _N_ _S_ "LLLLLLLU(P)" _N_ _N_ #-}
+setCurrentDirectory :: [Char] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
userGroupID :: UserEntry -> Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: UserEntry) -> case u0 of { _ALG_ _ORIG_ LibPosixDB UE (u1 :: [Char]) (u2 :: Int) (u3 :: Int) (u4 :: [Char]) (u5 :: [Char]) -> u3; _NO_DEFLT_ } _N_ #-}
userID :: UserEntry -> Int
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ProcessStatus
{-# GHC_PRAGMA _M_ LibPosixProcPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ProcessStatus, [Char])]), (Int -> ProcessStatus -> [Char] -> [Char]), ([Char] -> [([ProcessStatus], [Char])]), ([ProcessStatus] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ProcessStatus), _CONSTM_ Text showsPrec (ProcessStatus), _CONSTM_ Text readList (ProcessStatus), _CONSTM_ Text showList (ProcessStatus)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface LibPosix where
-import LibDirectory(removeDirectory)
+import LibDirectory(getCurrentDirectory, removeDirectory, setCurrentDirectory)
import LibPosixDB(GroupEntry(..), UserEntry(..), getGroupEntryForID, getGroupEntryForName, getUserEntryForID, getUserEntryForName, groupID, groupMembers, groupName, homeDirectory, userGroupID, userID, userName, userShell)
import LibPosixErr(ErrorCode(..), argumentListTooLong, badChannel, brokenPipe, directoryNotEmpty, e2BIG, eACCES, eAGAIN, eBADF, eBUSY, eCHILD, eDEADLK, eEXIST, eFBIG, eINTR, eINVAL, eIO, eISDIR, eMFILE, eMLINK, eNAMETOOLONG, eNFILE, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOMEM, eNOSPC, eNOSYS, eNOTDIR, eNOTEMPTY, eNOTTY, eNXIO, ePERM, ePIPE, eROFS, eSPIPE, eSRCH, eXDEV, execFormatError, fileAlreadyExists, fileTooLarge, filenameTooLong, getErrorCode, improperLink, inappropriateIOControlOperation, inputOutputError, interruptedOperation, invalidArgument, invalidSeek, isADirectory, noChildProcess, noError, noLocksAvailable, noSpaceLeftOnDevice, noSuchDeviceOrAddress, noSuchFileOrDirectory, noSuchOperationOnDevice, noSuchProcess, notADirectory, notEnoughMemory, operationNotImplemented, operationNotPermitted, permissionDenied, readOnlyFileSystem, resourceBusy, resourceDeadlockAvoided, resourceTemporarilyUnavailable, setErrorCode, tooManyLinks, tooManyOpenFiles, tooManyOpenFilesInSystem)
import LibPosixFiles(DeviceID(..), DirStream(..), FileID(..), FileMode(..), FileStatus(..), OpenMode(..), PathVar(..), accessModes, accessTime, changeWorkingDirectory, closeDirStream, createDirectory, createFile, createLink, createNamedPipe, deviceID, fileGroup, fileID, fileMode, fileOwner, fileSize, getChannelStatus, getChannelVar, getFileStatus, getPathVar, getWorkingDirectory, groupExecuteMode, groupModes, groupReadMode, groupWriteMode, intersectFileModes, isBlockDevice, isCharacterDevice, isDirectory, isNamedPipe, isRegularFile, linkCount, modificationTime, nullFileMode, openChannel, openDirStream, otherExecuteMode, otherModes, otherReadMode, otherWriteMode, ownerExecuteMode, ownerModes, ownerReadMode, ownerWriteMode, queryAccess, queryFile, readDirStream, removeLink, rename, rewindDirStream, setFileCreationMask, setFileMode, setFileTimes, setGroupIDMode, setOwnerAndGroup, setUserIDMode, statusChangeTime, stdError, stdFileMode, stdInput, stdOutput, touchFile, unionFileModes)
type ProcessID = Int
type UserID = Int
data ExitCode {-# GHC_PRAGMA ExitSuccess | ExitFailure Int #-}
+getCurrentDirectory :: _State _RealWorld -> (Either IOError13 [Char], _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
removeDirectory :: [Char] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getGroupEntryForID :: Int -> _State _RealWorld -> (Either IOError13 GroupEntry, _State _RealWorld)
nullFileMode :: _Word
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
openChannel :: [Char] -> OpenMode -> Maybe _Word -> Bool -> Bool -> Bool -> Bool -> Bool -> _State _RealWorld -> (Either IOError13 Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 9 _U_ 202111112 _N_ _S_ "SASEEEEEL" {_A_ 8 _U_ 22111112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 9 _U_ 212111112 _N_ _S_ "SESEEEEEL" _N_ _N_ #-}
openDirStream :: [Char] -> _State _RealWorld -> (Either IOError13 _Addr, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
otherExecuteMode :: _Word
{-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
runProcess :: [Char] -> [[Char]] -> Maybe [([Char], [Char])] -> Maybe [Char] -> Maybe (_MVar _Handle) -> Maybe (_MVar _Handle) -> Maybe (_MVar _Handle) -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 8 _U_ 22111111 _N_ _S_ "LLLLLLLU(P)" _N_ _N_ #-}
+setCurrentDirectory :: [Char] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
userGroupID :: UserEntry -> Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: UserEntry) -> case u0 of { _ALG_ _ORIG_ LibPosixDB UE (u1 :: [Char]) (u2 :: Int) (u3 :: Int) (u4 :: [Char]) (u5 :: [Char]) -> u3; _NO_DEFLT_ } _N_ #-}
userID :: UserEntry -> Int
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ProcessStatus
{-# GHC_PRAGMA _M_ LibPosixProcPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ProcessStatus, [Char])]), (Int -> ProcessStatus -> [Char] -> [Char]), ([Char] -> [([ProcessStatus], [Char])]), ([ProcessStatus] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ProcessStatus), _CONSTM_ Text showsPrec (ProcessStatus), _CONSTM_ Text readList (ProcessStatus), _CONSTM_ Text showList (ProcessStatus)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface LibPosix where
-import LibDirectory(removeDirectory)
+import LibDirectory(getCurrentDirectory, removeDirectory, setCurrentDirectory)
import LibPosixDB(GroupEntry(..), UserEntry(..), getGroupEntryForID, getGroupEntryForName, getUserEntryForID, getUserEntryForName, groupID, groupMembers, groupName, homeDirectory, userGroupID, userID, userName, userShell)
import LibPosixErr(ErrorCode(..), argumentListTooLong, badChannel, brokenPipe, directoryNotEmpty, e2BIG, eACCES, eAGAIN, eBADF, eBUSY, eCHILD, eDEADLK, eEXIST, eFBIG, eINTR, eINVAL, eIO, eISDIR, eMFILE, eMLINK, eNAMETOOLONG, eNFILE, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOMEM, eNOSPC, eNOSYS, eNOTDIR, eNOTEMPTY, eNOTTY, eNXIO, ePERM, ePIPE, eROFS, eSPIPE, eSRCH, eXDEV, execFormatError, fileAlreadyExists, fileTooLarge, filenameTooLong, getErrorCode, improperLink, inappropriateIOControlOperation, inputOutputError, interruptedOperation, invalidArgument, invalidSeek, isADirectory, noChildProcess, noError, noLocksAvailable, noSpaceLeftOnDevice, noSuchDeviceOrAddress, noSuchFileOrDirectory, noSuchOperationOnDevice, noSuchProcess, notADirectory, notEnoughMemory, operationNotImplemented, operationNotPermitted, permissionDenied, readOnlyFileSystem, resourceBusy, resourceDeadlockAvoided, resourceTemporarilyUnavailable, setErrorCode, tooManyLinks, tooManyOpenFiles, tooManyOpenFilesInSystem)
import LibPosixFiles(DeviceID(..), DirStream(..), FileID(..), FileMode(..), FileStatus(..), OpenMode(..), PathVar(..), accessModes, accessTime, changeWorkingDirectory, closeDirStream, createDirectory, createFile, createLink, createNamedPipe, deviceID, fileGroup, fileID, fileMode, fileOwner, fileSize, getChannelStatus, getChannelVar, getFileStatus, getPathVar, getWorkingDirectory, groupExecuteMode, groupModes, groupReadMode, groupWriteMode, intersectFileModes, isBlockDevice, isCharacterDevice, isDirectory, isNamedPipe, isRegularFile, linkCount, modificationTime, nullFileMode, openChannel, openDirStream, otherExecuteMode, otherModes, otherReadMode, otherWriteMode, ownerExecuteMode, ownerModes, ownerReadMode, ownerWriteMode, queryAccess, queryFile, readDirStream, removeLink, rename, rewindDirStream, setFileCreationMask, setFileMode, setFileTimes, setGroupIDMode, setOwnerAndGroup, setUserIDMode, statusChangeTime, stdError, stdFileMode, stdInput, stdOutput, touchFile, unionFileModes)
type ProcessID = Int
type UserID = Int
data ExitCode {-# GHC_PRAGMA ExitSuccess | ExitFailure Int #-}
+getCurrentDirectory :: _State _RealWorld -> (Either IOError13 [Char], _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
removeDirectory :: [Char] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
getGroupEntryForID :: Int -> _State _RealWorld -> (Either IOError13 GroupEntry, _State _RealWorld)
nullFileMode :: _Word
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _N_ _N_ _N_ #-}
openChannel :: [Char] -> OpenMode -> Maybe _Word -> Bool -> Bool -> Bool -> Bool -> Bool -> _State _RealWorld -> (Either IOError13 Int, _State _RealWorld)
- {-# GHC_PRAGMA _A_ 9 _U_ 202111112 _N_ _S_ "SASEEEEEL" {_A_ 8 _U_ 22111112 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+ {-# GHC_PRAGMA _A_ 9 _U_ 212111112 _N_ _S_ "SESEEEEEL" _N_ _N_ #-}
openDirStream :: [Char] -> _State _RealWorld -> (Either IOError13 _Addr, _State _RealWorld)
{-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "SL" _N_ _N_ #-}
otherExecuteMode :: _Word
{-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
runProcess :: [Char] -> [[Char]] -> Maybe [([Char], [Char])] -> Maybe [Char] -> Maybe (_MVar _Handle) -> Maybe (_MVar _Handle) -> Maybe (_MVar _Handle) -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 8 _U_ 22111111 _N_ _S_ "LLLLLLLU(P)" _N_ _N_ #-}
+setCurrentDirectory :: [Char] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 2 _U_ 21 _N_ _S_ "LU(P)" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_ #-}
userGroupID :: UserEntry -> Int
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(AAU(P)AA)" {_A_ 1 _U_ 2 _N_ _N_ _F_ _IF_ARGS_ 0 1 X 2 \ (u0 :: Int#) -> _!_ I# [] [u0] _N_} _F_ _IF_ARGS_ 0 1 C 2 \ (u0 :: UserEntry) -> case u0 of { _ALG_ _ORIG_ LibPosixDB UE (u1 :: [Char]) (u2 :: Int) (u3 :: Int) (u4 :: [Char]) (u5 :: [Char]) -> u3; _NO_DEFLT_ } _N_ #-}
userID :: UserEntry -> Int
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ProcessStatus
{-# GHC_PRAGMA _M_ LibPosixProcPrim {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ProcessStatus, [Char])]), (Int -> ProcessStatus -> [Char] -> [Char]), ([Char] -> [([ProcessStatus], [Char])]), ([ProcessStatus] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ProcessStatus), _CONSTM_ Text showsPrec (ProcessStatus), _CONSTM_ Text readList (ProcessStatus), _CONSTM_ Text showList (ProcessStatus)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_ #-}
instance Text ExitCode
{-# GHC_PRAGMA _M_ LibSystem {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(ExitCode, [Char])]), (Int -> ExitCode -> [Char] -> [Char]), ([Char] -> [([ExitCode], [Char])]), ([ExitCode] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (ExitCode), _CONSTM_ Text showsPrec (ExitCode), _CONSTM_ Text readList (ExitCode), _CONSTM_ Text showList (ExitCode)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _N_ _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LS" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
import PreludeIOError
import PreludeGlaST
import PS
+import LibPosixUtil (allocWords, allocChars)
\end{code}
instance Text ClockTime where
showsPrec p (TOD sec@(J# a# s# d#) nsec) =
showString (unsafePerformPrimIO (
- _ccall_ showTime (I# s#) (_ByteArray (error "ClockTime.show") d#)
+ allocChars 32 `thenPrimIO` \ buf ->
+ _ccall_ showTime (I# s#) (_ByteArray (error "ClockTime.show") d#) buf
`thenPrimIO` \ str ->
_ccall_ strlen str `thenPrimIO` \ len ->
_packCBytesST len str `thenStrictlyST` \ ps ->
\begin{code}
toCalendarTime :: ClockTime -> CalendarTime
toCalendarTime (TOD sec@(J# a# s# d#) psec) = unsafePerformPrimIO (
- _ccall_ toLocalTime (I# s#) (_ByteArray (error "toCalendarTime") d#)
+ allocWords (``sizeof(struct tm)''::Int) `thenPrimIO` \ res ->
+ allocChars 32 `thenPrimIO` \ zoneNm ->
+ _casm_ ``SETZONE((struct tm *)%0,(char *)%1); '' res zoneNm `thenPrimIO` \ () ->
+ _ccall_ toLocalTime (I# s#) (_ByteArray (error "toCalendarTime") d#) res
`thenPrimIO` \ tm ->
if tm == (``NULL''::_Addr) then
error "toCalendarTime{LibTime}: out of range"
`thenPrimIO` \ yday ->
_casm_ ``%r = ((struct tm *)%0)->tm_isdst;'' tm
`thenPrimIO` \ isdst ->
- _ccall_ ZONE tm `thenPrimIO` \ zone ->
- _ccall_ GMTOFF tm `thenPrimIO` \ tz ->
+ _ccall_ ZONE tm `thenPrimIO` \ zone ->
+ _ccall_ GMTOFF tm `thenPrimIO` \ tz ->
_ccall_ strlen zone `thenPrimIO` \ len ->
_packCBytesST len zone `thenStrictlyST` \ tzname ->
returnPrimIO (CalendarTime (1900+year) mon mday hour min sec psec
toUTCTime :: ClockTime -> CalendarTime
toUTCTime (TOD sec@(J# a# s# d#) psec) = unsafePerformPrimIO (
- _ccall_ toUTCTime (I# s#) (_ByteArray (error "toCalendarTime") d#)
+ allocWords (``sizeof(struct tm)''::Int) `thenPrimIO` \ res ->
+ allocChars 32 `thenPrimIO` \ zoneNm ->
+ _casm_ ``SETZONE((struct tm *)%0,(char *)%1); '' res zoneNm `thenPrimIO` \ () ->
+ _ccall_ toUTCTime (I# s#) (_ByteArray (error "toCalendarTime") d#) res
`thenPrimIO` \ tm ->
if tm == (``NULL''::_Addr) then
error "toUTCTime{LibTime}: out of range"
error "toClockTime{LibTime}: timezone offset out of range"
else
unsafePerformPrimIO (
- _ccall_ toClockSec year mon mday hour min sec tz
+ allocWords (``sizeof(time_t)'') `thenPrimIO` \ res ->
+ _ccall_ toClockSec year mon mday hour min sec tz res
`thenPrimIO` \ ptr@(A# ptr#) ->
if ptr /= ``NULL'' then
returnPrimIO (TOD (int2Integer# (indexIntOffAddr# ptr# 0#)) psec)
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)LLLLLLL)U(U(P)LLLLLLL)" _N_ _N_ #-}
instance Text Time
{-# GHC_PRAGMA _M_ Time {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Time, [Char])]), (Int -> Time -> [Char] -> [Char]), ([Char] -> [([Time], [Char])]), ([Time] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Time), _CONSTM_ Text showsPrec (Time), _CONSTM_ Text readList (Time), _CONSTM_ Text showList (Time)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LU(LLLLLLLL)" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)LLLLLLL)U(U(P)LLLLLLL)" _N_ _N_ #-}
instance Text Time
{-# GHC_PRAGMA _M_ Time {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Time, [Char])]), (Int -> Time -> [Char] -> [Char]), ([Char] -> [([Time], [Char])]), ([Time] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Time), _CONSTM_ Text showsPrec (Time), _CONSTM_ Text readList (Time), _CONSTM_ Text showList (Time)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LU(LLLLLLLL)" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)LLLLLLL)U(U(P)LLLLLLL)" _N_ _N_ #-}
instance Text Time
{-# GHC_PRAGMA _M_ Time {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Time, [Char])]), (Int -> Time -> [Char] -> [Char]), ([Char] -> [([Time], [Char])]), ([Time] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Time), _CONSTM_ Text showsPrec (Time), _CONSTM_ Text readList (Time), _CONSTM_ Text showList (Time)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LU(LLLLLLLL)" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)LLLLLLL)U(U(P)LLLLLLL)" _N_ _N_ #-}
instance Text Time
{-# GHC_PRAGMA _M_ Time {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Time, [Char])]), (Int -> Time -> [Char] -> [Char]), ([Char] -> [([Time], [Char])]), ([Time] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Time), _CONSTM_ Text showsPrec (Time), _CONSTM_ Text readList (Time), _CONSTM_ Text showList (Time)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LU(LLLLLLLL)" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "U(U(P)LLLLLLL)U(U(P)LLLLLLL)" _N_ _N_ #-}
instance Text Time
{-# GHC_PRAGMA _M_ Time {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Time, [Char])]), (Int -> Time -> [Char] -> [Char]), ([Char] -> [([Time], [Char])]), ([Time] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Time), _CONSTM_ Text showsPrec (Time), _CONSTM_ Text readList (Time), _CONSTM_ Text showList (Time)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 12 _N_ _S_ "U(P)L" {_A_ 2 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 2 _U_ 112 _N_ _S_ "LU(LLLLLLLL)" _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
'_mc', '_mr', '_mt', '_mp', '_mg',
'_2s', '_1s', '_du',
'_a', '_b', '_c', '_d', '_e', '_f', '_g', '_h',
- '_i', '_j', '_k', '_o', '_m', '_n', '_o' ) {
+ '_i', '_j', '_k', '_o', '_m', '_n', '_o', '_A', '_B' ) {
$copy = $_;
# change all .hc and .hi
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _S_ _!_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _APP_ _TYAPP_ _ORIG_ PreludeBuiltin error { u0 } [ _NOREP_S_ "Oops! The program has entered an `absent' argument!\n" ] _N_ #-}
error :: [Char] -> a
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ _!_ _N_ _N_ #-}
+parError# :: a
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _S_ _!_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _APP_ _TYAPP_ _ORIG_ PreludeBuiltin error { u0 } [ _NOREP_S_ "Oops! Entered parError# (a GHC bug -- please report it!)\n" ] _N_ #-}
patError# :: [Char] -> a
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ _!_ _N_ _N_ #-}
_trace,
absent#,
error,
- patError#
+ patError#,
+ parError#
) where
import Cls
absent# = error "Oops! The program has entered an `absent' argument!\n"
+parError# = error "Oops! Entered parError# (a GHC bug -- please report it!)\n"
+
---------------------------------------------------------------
_runST m = case m (S# realWorld#) of
(r,_) -> r
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _S_ _!_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _APP_ _TYAPP_ _ORIG_ PreludeBuiltin error { u0 } [ _NOREP_S_ "Oops! The program has entered an `absent' argument!\n" ] _N_ #-}
error :: [Char] -> a
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ _!_ _N_ _N_ #-}
+parError# :: a
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _S_ _!_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _APP_ _TYAPP_ _ORIG_ PreludeBuiltin error { u0 } [ _NOREP_S_ "Oops! Entered parError# (a GHC bug -- please report it!)\n" ] _N_ #-}
patError# :: [Char] -> a
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ _!_ _N_ _N_ #-}
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _S_ _!_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _APP_ _TYAPP_ _ORIG_ PreludeBuiltin error { u0 } [ _NOREP_S_ "Oops! The program has entered an `absent' argument!\n" ] _N_ #-}
error :: [Char] -> a
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ _!_ _N_ _N_ #-}
+parError# :: a
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _S_ _!_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _APP_ _TYAPP_ _ORIG_ PreludeBuiltin error { u0 } [ _NOREP_S_ "Oops! Entered parError# (a GHC bug -- please report it!)\n" ] _N_ #-}
patError# :: [Char] -> a
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ _!_ _N_ _N_ #-}
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _S_ _!_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _APP_ _TYAPP_ _ORIG_ PreludeBuiltin error { u0 } [ _NOREP_S_ "Oops! The program has entered an `absent' argument!\n" ] _N_ #-}
error :: [Char] -> a
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ _!_ _N_ _N_ #-}
+parError# :: a
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _S_ _!_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _APP_ _TYAPP_ _ORIG_ PreludeBuiltin error { u0 } [ _NOREP_S_ "Oops! Entered parError# (a GHC bug -- please report it!)\n" ] _N_ #-}
patError# :: [Char] -> a
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ _!_ _N_ _N_ #-}
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _S_ _!_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _APP_ _TYAPP_ _ORIG_ PreludeBuiltin error { u0 } [ _NOREP_S_ "Oops! The program has entered an `absent' argument!\n" ] _N_ #-}
error :: [Char] -> a
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ _!_ _N_ _N_ #-}
+parError# :: a
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _S_ _!_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _APP_ _TYAPP_ _ORIG_ PreludeBuiltin error { u0 } [ _NOREP_S_ "Oops! Entered parError# (a GHC bug -- please report it!)\n" ] _N_ #-}
patError# :: [Char] -> a
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ _!_ _N_ _N_ #-}
{-# GHC_PRAGMA _A_ 0 _N_ _N_ _S_ _!_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _APP_ _TYAPP_ _ORIG_ PreludeBuiltin error { u0 } [ _NOREP_S_ "Oops! The program has entered an `absent' argument!\n" ] _N_ #-}
error :: [Char] -> a
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ _!_ _N_ _N_ #-}
+parError# :: a
+ {-# GHC_PRAGMA _A_ 0 _N_ _N_ _S_ _!_ _F_ _IF_ARGS_ 1 0 X 2 _/\_ u0 -> _APP_ _TYAPP_ _ORIG_ PreludeBuiltin error { u0 } [ _NOREP_S_ "Oops! Entered parError# (a GHC bug -- please report it!)\n" ] _N_ #-}
patError# :: [Char] -> a
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ _!_ _N_ _N_ #-}
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
putChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AL)LU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+putList2Chan :: Chan a -> [a] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ #-}
unGetChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(LA)LU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
\begin{code}
module Channel
(
- {- abstract -}
+ {- abstract type defined -}
Chan,
- newChan, -- :: IO (Chan a)
- putChan, -- :: Chan a -> a -> IO ()
- getChan, -- :: Chan a -> IO a
- dupChan, -- :: Chan a -> IO (Chan a)
- unGetChan, -- :: Chan a -> a -> IO ()
- getChanContents -- :: Chan a -> IO [a]
+ {- creator -}
+ newChan, -- :: IO (Chan a)
+
+ {- operators -}
+ putChan, -- :: Chan a -> a -> IO ()
+ getChan, -- :: Chan a -> IO a
+ dupChan, -- :: Chan a -> IO (Chan a)
+ unGetChan, -- :: Chan a -> a -> IO ()
+
+ {- stream interface -}
+ getChanContents, -- :: Chan a -> IO [a]
+ putList2Chan -- :: Chan a -> [a] -> IO ()
) where
\end{code}
+Operators for interfacing with functional streams.
+
\begin{code}
getChanContents :: Chan a -> IO [a]
-getChanContents ch
- = unsafeInterleavePrimIO (
- getChan ch) `thenPrimIO` \ ~(Right x) ->
- unsafeInterleavePrimIO (
- getChanContents ch) `thenPrimIO` \ ~(Right xs) ->
- return (x:xs)
+getChanContents ch =
+ unsafeInterleavePrimIO (
+ getChan ch `thenPrimIO` \ ~(Right x) ->
+ unsafeInterleavePrimIO (getChanContents ch) `thenPrimIO` \ ~(Right xs) ->
+ returnPrimIO (Right (x:xs)))
+
+putList2Chan :: Chan a -> [a] -> IO ()
+putList2Chan ch ls = sequence (map (putChan ch) ls)
\end{code}
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
putChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AL)LU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+putList2Chan :: Chan a -> [a] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ #-}
unGetChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(LA)LU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
putChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AL)LU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+putList2Chan :: Chan a -> [a] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ #-}
unGetChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(LA)LU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
putChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AL)LU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+putList2Chan :: Chan a -> [a] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ #-}
unGetChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(LA)LU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
putChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(AL)LU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
+putList2Chan :: Chan a -> [a] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ #-}
unGetChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "U(LA)LU(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Concurrent where
-import Channel(Chan(..), dupChan, getChan, getChanContents, newChan, putChan, unGetChan)
+import Channel(Chan(..), dupChan, getChan, getChanContents, newChan, putChan, putList2Chan, unGetChan)
import ChannelVar(CVar(..), getCVar, newCVar, putCVar)
import Merge(mergeIO, nmergeIO)
import Parallel(par, seq)
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
putChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "SLS" _N_ _N_ #-}
+putList2Chan :: Chan a -> [a] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ #-}
unGetChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "SLS" _N_ _N_ #-}
getCVar :: CVar a -> _State _RealWorld -> (Either IOError13 a, _State _RealWorld)
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Concurrent where
-import Channel(Chan(..), dupChan, getChan, getChanContents, newChan, putChan, unGetChan)
+import Channel(Chan(..), dupChan, getChan, getChanContents, newChan, putChan, putList2Chan, unGetChan)
import ChannelVar(CVar(..), getCVar, newCVar, putCVar)
import Merge(mergeIO, nmergeIO)
import Parallel(par, seq)
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
putChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "SLS" _N_ _N_ #-}
+putList2Chan :: Chan a -> [a] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ #-}
unGetChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "SLS" _N_ _N_ #-}
getCVar :: CVar a -> _State _RealWorld -> (Either IOError13 a, _State _RealWorld)
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Concurrent where
-import Channel(Chan(..), dupChan, getChan, getChanContents, newChan, putChan, unGetChan)
+import Channel(Chan(..), dupChan, getChan, getChanContents, newChan, putChan, putList2Chan, unGetChan)
import ChannelVar(CVar(..), getCVar, newCVar, putCVar)
import Merge(mergeIO, nmergeIO)
import Parallel(par, seq)
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
putChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "SLS" _N_ _N_ #-}
+putList2Chan :: Chan a -> [a] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ #-}
unGetChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "SLS" _N_ _N_ #-}
getCVar :: CVar a -> _State _RealWorld -> (Either IOError13 a, _State _RealWorld)
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Concurrent where
-import Channel(Chan(..), dupChan, getChan, getChanContents, newChan, putChan, unGetChan)
+import Channel(Chan(..), dupChan, getChan, getChanContents, newChan, putChan, putList2Chan, unGetChan)
import ChannelVar(CVar(..), getCVar, newCVar, putCVar)
import Merge(mergeIO, nmergeIO)
import Parallel(par, seq)
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
putChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "SLS" _N_ _N_ #-}
+putList2Chan :: Chan a -> [a] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ #-}
unGetChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "SLS" _N_ _N_ #-}
getCVar :: CVar a -> _State _RealWorld -> (Either IOError13 a, _State _RealWorld)
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Concurrent where
-import Channel(Chan(..), dupChan, getChan, getChanContents, newChan, putChan, unGetChan)
+import Channel(Chan(..), dupChan, getChan, getChanContents, newChan, putChan, putList2Chan, unGetChan)
import ChannelVar(CVar(..), getCVar, newCVar, putCVar)
import Merge(mergeIO, nmergeIO)
import Parallel(par, seq)
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "U(P)" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_ #-}
putChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "SLS" _N_ _N_ #-}
+putList2Chan :: Chan a -> [a] -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 212 _N_ _S_ "LSL" _N_ _N_ #-}
unGetChan :: Chan a -> a -> _State _RealWorld -> (Either IOError13 (), _State _RealWorld)
{-# GHC_PRAGMA _A_ 3 _U_ 121 _N_ _S_ "SLS" _N_ _N_ #-}
getCVar :: CVar a -> _State _RealWorld -> (Either IOError13 a, _State _RealWorld)
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
----------------------------------------------------------------------
instance Text Bool where
- readsPrec p
- = readParen (p > 9)
- (\ b -> [ (False, c) | ("False", c) <- lex b ]
- ++ [ (True, c) | ("True", c) <- lex b ])
+ readsPrec p r
+ = readParen False (\ b -> [ (False, c) | ("False", c) <- lex b ]) r
+ ++ readParen False (\ b -> [ (True, c) | ("True", c) <- lex b ]) r
- showsPrec d p r = (if p then "True" else "False") ++ r
+ showsPrec d p = showString (if p then "True" else "False")
-- ToDo: Binary
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_tagCmp = _A_ 2 _U_ 11 _N_ _S_ "EE" _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
minusInt(I# x) (I# y) = I# (minusInt# x y)
timesInt(I# x) (I# y) = I# (timesInt# x y)
quotInt (I# x) (I# y) = I# (quotInt# x y)
-divInt (I# x) (I# y) = I# (divInt# x y)
remInt (I# x) (I# y) = I# (remInt# x y)
negateInt (I# x) = I# (negateInt# x)
gtInt (I# x) (I# y) = gtInt# x y
import Prel ( (&&) )
import Cls
-import Core ( _readList, _showList )
+import Core
import IChar
import IInt
import List ( (++) )
# ifndef USE_FOLDR_BUILD
-- HBC version (stolen)
concat [] = []
-concat ([]:xss) = concat xss -- for better stack behaiour!
-concat ([x]:xss) = x : concat xss -- this should help too ???
-concat (xs:xss) = xs ++ concat xss
+concat ([]:xss) = concat xss -- for better stack behaviour!
+--NO:bad strictness: concat ([x]:xss) = x : concat xss -- this should help too ???
+concat ((y:ys):xss) = y : (ys ++ concat xss)
# else
{-# INLINE concat #-}
concat xs = _build (\ c n -> foldr (\ x y -> foldr c y x) n xs)
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
_foldrPS :: (Char -> a -> a) -> a -> _PackedString -> a
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
+_getPS :: _FILE -> Int -> _State _RealWorld -> (_PackedString, _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
_headPS :: _PackedString -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
_indexPS :: _PackedString -> Int -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
unpackPS# :: Addr# -> [Char]
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _N_ _N_ #-}
+unpackPS2# :: Addr# -> Int# -> [Char]
+ {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "PP" _N_ _N_ #-}
instance Eq _PackedString
{-# GHC_PRAGMA _M_ PreludePS {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_PackedString -> _PackedString -> Bool), (_PackedString -> _PackedString -> Bool)] [_CONSTM_ Eq (==) (_PackedString), _CONSTM_ Eq (/=) (_PackedString)] _N_
(==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
_psToByteArray,
_unpackPS,
- unpackPS#,
+ unpackPS#, unpackPS2#,
-- toCString,
_putPS,
+ _getPS,
_headPS,
_tailPS,
--OLD: packToCString :: [Char] -> _ByteArray Int -- hmmm... weird name
_unpackPS :: _PackedString -> [Char]
-unpackPS# :: Addr# -> [Char] -- calls injected by compiler
+unpackPS# :: Addr# -> [Char] -- calls injected by compiler
+unpackPS2# :: Addr# -> Int# -> [Char] -- calls injected by compiler
--???toCString :: _PackedString -> ByteArray#
_putPS :: _FILE -> _PackedString -> PrimIO () -- ToDo: more sensible type
\end{code}
where
len = case (strlen# addr) of { I# x -> x }
+unpackPS2# addr len -- calls injected by compiler
+ -- this one is for literal strings with NULs in them; rare.
+ = _unpackPS (_packCBytes (I# len) (A# addr))
+
-- OK, but this code gets *hammered*:
-- _unpackPS ps
-- = [ _indexPS ps n | n <- [ 0::Int .. _lengthPS ps - 1 ] ]
returnPrimIO ()
\end{code}
+The dual to @_putPS@, note that the size of the chunk specified
+is the upper bound of the size of the chunk returned.
+
+\begin{code}
+_getPS :: _FILE -> Int -> PrimIO _PackedString
+_getPS file len@(I# len#)
+ | len# <=# 0# = returnPrimIO _nilPS -- I'm being kind here.
+ | otherwise =
+ -- Allocate an array for system call to store its bytes into.
+ new_ps_array len# `thenPrimIO` \ ch_arr ->
+ freeze_ps_array ch_arr `thenPrimIO` \ (_ByteArray _ frozen#) ->
+ let
+ byte_array = _ByteArray (0, I# len#) frozen#
+ in
+ _ccall_ fread byte_array (1::Int) len file `thenPrimIO` \ (I# read#) ->
+ if read# ==# 0# then -- EOF or other error
+ error "_getPS: EOF reached or other error"
+ else
+ {-
+ The system call may not return the number of
+ bytes requested. Instead of failing with an error
+ if the number of bytes read is less than requested,
+ a packed string containing the bytes we did manage
+ to snarf is returned.
+ -}
+ let
+ has_null = byteArrayHasNUL# frozen# read#
+ in
+ returnPrimIO (_PS frozen# read# has_null)
+
+\end{code}
+
%************************************************************************
%* *
\subsection{List-mimicking functions for @_PackedStrings@}
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
_foldrPS :: (Char -> a -> a) -> a -> _PackedString -> a
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
+_getPS :: _FILE -> Int -> _State _RealWorld -> (_PackedString, _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
_headPS :: _PackedString -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
_indexPS :: _PackedString -> Int -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
unpackPS# :: Addr# -> [Char]
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _N_ _N_ #-}
+unpackPS2# :: Addr# -> Int# -> [Char]
+ {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "PP" _N_ _N_ #-}
instance Eq _PackedString
{-# GHC_PRAGMA _M_ PreludePS {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_PackedString -> _PackedString -> Bool), (_PackedString -> _PackedString -> Bool)] [_CONSTM_ Eq (==) (_PackedString), _CONSTM_ Eq (/=) (_PackedString)] _N_
(==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
unpackPS# :: Addr# -> [Char]
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _N_ _N_ #-}
+unpackPS2# :: Addr# -> Int# -> [Char]
+ {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "PP" _N_ _N_ #-}
instance Eq _PackedString
{-# GHC_PRAGMA _M_ PreludePS {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_PackedString -> _PackedString -> Bool), (_PackedString -> _PackedString -> Bool)] [_CONSTM_ Eq (==) (_PackedString), _CONSTM_ Eq (/=) (_PackedString)] _N_
(==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
_foldrPS :: (Char -> a -> a) -> a -> _PackedString -> a
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
+_getPS :: _FILE -> Int -> _State _RealWorld -> (_PackedString, _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
_headPS :: _PackedString -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
_indexPS :: _PackedString -> Int -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
unpackPS# :: Addr# -> [Char]
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _N_ _N_ #-}
+unpackPS2# :: Addr# -> Int# -> [Char]
+ {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "PP" _N_ _N_ #-}
instance Eq _PackedString
{-# GHC_PRAGMA _M_ PreludePS {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_PackedString -> _PackedString -> Bool), (_PackedString -> _PackedString -> Bool)] [_CONSTM_ Eq (==) (_PackedString), _CONSTM_ Eq (/=) (_PackedString)] _N_
(==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
_foldrPS :: (Char -> a -> a) -> a -> _PackedString -> a
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
+_getPS :: _FILE -> Int -> _State _RealWorld -> (_PackedString, _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
_headPS :: _PackedString -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
_indexPS :: _PackedString -> Int -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
unpackPS# :: Addr# -> [Char]
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _N_ _N_ #-}
+unpackPS2# :: Addr# -> Int# -> [Char]
+ {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "PP" _N_ _N_ #-}
instance Eq _PackedString
{-# GHC_PRAGMA _M_ PreludePS {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_PackedString -> _PackedString -> Bool), (_PackedString -> _PackedString -> Bool)] [_CONSTM_ Eq (==) (_PackedString), _CONSTM_ Eq (/=) (_PackedString)] _N_
(==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
_foldrPS :: (Char -> a -> a) -> a -> _PackedString -> a
{-# GHC_PRAGMA _A_ 3 _U_ 221 _N_ _S_ "LLS" _N_ _N_ #-}
+_getPS :: _FILE -> Int -> _State _RealWorld -> (_PackedString, _State _RealWorld)
+ {-# GHC_PRAGMA _A_ 3 _U_ 111 _N_ _S_ "LU(P)U(P)" {_A_ 3 _U_ 122 _N_ _N_ _N_ _N_} _N_ _N_ #-}
_headPS :: _PackedString -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "S" _N_ _N_ #-}
_indexPS :: _PackedString -> Int -> Char
{-# GHC_PRAGMA _A_ 1 _U_ 1 _N_ _S_ "S" _N_ _N_ #-}
unpackPS# :: Addr# -> [Char]
{-# GHC_PRAGMA _A_ 1 _U_ 2 _N_ _S_ "P" _N_ _N_ #-}
+unpackPS2# :: Addr# -> Int# -> [Char]
+ {-# GHC_PRAGMA _A_ 2 _U_ 22 _N_ _S_ "PP" _N_ _N_ #-}
instance Eq _PackedString
{-# GHC_PRAGMA _M_ PreludePS {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 3 _!_ _TUP_2 [(_PackedString -> _PackedString -> Bool), (_PackedString -> _PackedString -> Bool)] [_CONSTM_ Eq (==) (_PackedString), _CONSTM_ Eq (/=) (_PackedString)] _N_
(==) = _A_ 2 _U_ 22 _N_ _S_ "SS" _N_ _N_,
{-# GHC_PRAGMA _M_ PreludeArray {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _M_ PreludeArray {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _M_ PreludeArray {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _M_ PreludeArray {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _M_ PreludeArray {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _M_ PreludeArray {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _M_ PreludeArray {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _M_ PreludeArray {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _M_ PreludeArray {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
{-# GHC_PRAGMA _M_ PreludeArray {-dfun-} _A_ 2 _U_ 22 _N_ _N_ _N_ _N_ #-}
instance Text Bool
{-# GHC_PRAGMA _M_ PreludeCore {-dfun-} _A_ 0 _N_ _N_ _N_ _F_ _IF_ARGS_ 0 0 X 5 _!_ _TUP_4 [(Int -> [Char] -> [(Bool, [Char])]), (Int -> Bool -> [Char] -> [Char]), ([Char] -> [([Bool], [Char])]), ([Bool] -> [Char] -> [Char])] [_CONSTM_ Text readsPrec (Bool), _CONSTM_ Text showsPrec (Bool), _CONSTM_ Text readList (Bool), _CONSTM_ Text showList (Bool)] _N_
- readsPrec = _A_ 1 _U_ 12 _N_ _S_ "U(P)" {_A_ 1 _U_ 22 _N_ _N_ _N_ _N_} _N_ _N_,
+ readsPrec = _A_ 2 _U_ 02 _N_ _S_ "AL" {_A_ 1 _U_ 2 _N_ _N_ _N_ _N_} _N_ _N_,
showsPrec = _A_ 3 _U_ 012 _N_ _S_ "AEL" {_A_ 2 _U_ 12 _N_ _N_ _N_ _N_} _N_ _N_,
readList = _A_ 0 _U_ 2 _N_ _N_ _N_ _N_,
showList = _A_ 0 _U_ 12 _N_ _N_ _N_ _N_ #-}
_bufferMode (_WriteHandle _ m _) = m
_bufferMode (_AppendHandle _ m _) = m
_bufferMode (_ReadWriteHandle _ m _) = m
+_bufferMode (_SocketHandle _ _) = (Just NoBuffering)
_markHandle :: _Handle -> _Handle
_markHandle h@(_ReadHandle fp m b)
_SemiClosedHandle _ _ ->
putMVar handle htype >>
failWith (IllegalOperation "handle is closed")
+{-
_SocketHandle _ _ ->
putMVar handle htype >>
failWith (IllegalOperation "buffering not supported for socket handles")
+-}
other ->
_ccall_ setBuffering (_filePtr other) bsize
`thenPrimIO` \ rc ->
hcon (_WriteHandle _ _ _) = _WriteHandle
hcon (_AppendHandle _ _ _) = _AppendHandle
hcon (_ReadWriteHandle _ _ _) = _ReadWriteHandle
+ hcon (_SocketHandle _ _) = \ a _ v -> _SocketHandle a v
\end{code}
--- /dev/null
+\begin{onlystandalone}
+\documentstyle[11pt,literate,a4wide,titlepage]{article}
+\begin{document}
+\title{Adding Unix Libraries to GHC}
+\author{Darren J Moffat}
+\date{July 1995}
+\maketitle
+\tableofcontents
+\end{onlystandalone}
+
+
+\begin{onlypartofdoc}
+\section[UnixLibs]{Unix Libraries}
+\downsection
+\end{onlypartofdoc}
+
+
+\input{ghc/Socket.lhs}
+\input{ghc/SocketPrim.lhs}
+\input{ghc/BSD.lhs}
+\input{ghc/Readline.lhs}
+%\input{DBM.lhs}
+%\input{WWW.lhs}
+
+
+\begin{onlypartofdoc}
+\upsection
+\end{onlypartofdoc}
+
+\begin{onlystandalone}
+\printindex
+\end{document}
+\end{onlystandalone}
+
+
--- /dev/null
+#include <stdio.h>
+
+main ()
+{
+ int n;
+
+ scanf("%d",&n);
+ n = nfib(n);
+ printf("nfibs=%d\n",n);
+ exit(0);
+}
+
+nfib (n)
+{
+ return(n <= 1 ? 1 : nfib(n-1) + nfib(n-2) + 1);
+}
--- /dev/null
+# WARNING!
+# Note: be careful about running this with an argument > (say) 18 !
+# running this script on '27' will chew up ~80 MB of virtual
+# ram. and its apetite grows per 1.61803 ** $n.
+#
+# Your system admin folk would probably be displeased if you trash
+# other people's work, or disable systems running this script!
+#
+# Usage: perl nfib.prl <number>
+#
+$n = @ARGV[0];
+$f=&fib($n);
+print " $n! = $f\n";
+sub fib {
+ local ($n)=$_[0];
+ if ($n==0) {return (0);}
+ elsif($n==1) {return(1);}
+ return (&fib ($n-1) + &fib($n-2));
+}
GHC_OPTS_norm=-O /*-fsemi-tagging*/ -darity-checks-C-only rts_or_lib(-optc-DGCap,)
GHC_OPTS_p =-hisuf _p.hi -O /*-fsemi-tagging*/ -prof -GPrelude rts_or_lib(-optc-DGCap,)
-GHC_OPTS_t =-hisuf _t.hi -O /*-fsemi-tagging*/ -ticky rts_or_lib(-optc-DGCap,)
+GHC_OPTS_t =-hisuf _t.hi -O /*-fsemi-tagging*/ -ticky -optc-DDEBUG rts_or_lib(-optc-DGCap,)
GHC_OPTS_u =-hisuf _u.hi -O -unregisterised ???? /*-fsemi-tagging*/ -ticky rts_or_lib(-optc-DGCap,)
GHC_OPTS_mc=-hisuf _mc.hi -O -concurrent rts_or_lib(-optc-DGCap,)
GHC_OPTS_mr=-hisuf _mr.hi -O -concurrent -prof -GPrelude rts_or_lib(-optc-DGCap,)
-GHC_OPTS_mt=-hisuf _mt.hi -O -concurrent -ticky rts_or_lib(-optc-DGCap,)
+GHC_OPTS_mt=-hisuf _mt.hi -O -concurrent -ticky -optc-DDEBUG rts_or_lib(-optc-DGCap,)
GHC_OPTS_mp=-hisuf _mp.hi -O -parallel rts_or_lib(-optc-DGCap,)
GHC_OPTS_mg=-hisuf _mg.hi -O -gransim rts_or_lib(-optc-DGCap,)
GHC_OPTS_2s=-hisuf _2s.hi -O -gc-2s rts_or_lib(-optc-DGC2s,)
GHC_OPTS_m =-hisuf _m.hi -user-setup-m rts_or_lib(-optc-DGCap,)
GHC_OPTS_n =-hisuf _n.hi -user-setup-n rts_or_lib(-optc-DGCap,)
GHC_OPTS_o =-hisuf _o.hi -user-setup-o rts_or_lib(-optc-DGCap,)
+GHC_OPTS_A =-hisuf _A.hi -user-setup-A rts_or_lib(-optc-DGCap,)
+GHC_OPTS_B =-hisuf _B.hi -user-setup-B rts_or_lib(-optc-DGCap,)
#endif
/* ProjectVersion is something printable */
#ifndef ProjectVersion
-#define ProjectVersion 0.26
+#define ProjectVersion 0.27
#endif
/* A patchlevel change is something *very minor* */
#ifndef ProjectPatchLevel
#endif
/* GhcBuildeeVersion is something CPP-testable (ProjectVersion * 100) */
#ifndef GhcBuildeeVersion
-#define GhcBuildeeVersion 26
+#define GhcBuildeeVersion 27
#endif
# line 29 "only4-ghc.ljm"
/* state of the source world */
#endif
/* ProjectVersion is something printable */
#ifndef ProjectVersion
-#define ProjectVersion 0.26
+#define ProjectVersion 0.27
#endif
/* A patchlevel change is something *very minor* */
#ifndef ProjectPatchLevel
-#define ProjectPatchLevel patchlevel 1
+#define ProjectPatchLevel patchlevel 0
#endif
/* GhcBuildeeVersion is something CPP-testable (ProjectVersion * 100) */
#ifndef GhcBuildeeVersion
-#define GhcBuildeeVersion 26
+#define GhcBuildeeVersion 27
#endif
\end{code}
GHC_BUILD_OPTS_o = -build-o-not-defined-error
#endif
+#define GhcBuild_A NO /*@GhcBuild_A@*/ /* "user way" A */
+#if GhcBuild_A == YES
+# define IfGhcBuild_A(x) x
+GHC_BUILD_FLAG_A = -build-A-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_A = -build-A-not-defined-error
+#else
+# define IfGhcBuild_A(x) /**/
+GHC_BUILD_FLAG_A = -build-A-not-defined
+GHC_BUILD_OPTS_A = -build-A-not-defined-error
+#endif
+
+#define GhcBuild_B NO /*@GhcBuild_B@*/ /* "user way" B */
+#if GhcBuild_B == YES
+# define IfGhcBuild_B(x) x
+GHC_BUILD_FLAG_B = -build-B-not-defined /* >>>change here<<< if required */
+GHC_BUILD_OPTS_B = -build-B-not-defined-error
+#else
+# define IfGhcBuild_B(x) /**/
+GHC_BUILD_FLAG_B = -build-B-not-defined
+GHC_BUILD_OPTS_B = -build-B-not-defined-error
+#endif
+
/* ======= END OF BUILD INFO ==================================== */
GHC_OPTS, just for fun.
*/
-#if i386_TARGET_ARCH
-# define __plat_specific -mtoggle-sp-mangling
-#else
-# define __plat_specific /*none*/
-#endif
-
-GHC_OPTS = -O2-for-C -optc-DFORCE_GC \
- __plat_specific $(EXTRA_HC_OPTS)
+GHC_OPTS = -O2-for-C $(EXTRA_HC_OPTS)
/* per-build options: shared with libraries */
#define rts_or_lib(r,l) r
gum/Unpack.lc \
main/GranSim.lc \
main/Itimer.lc \
- main/RednCounts.lc \
+ main/Ticky.lc \
main/SMRep.lc \
main/Select.lc \
main/Signals.lc \
main/StgOverflow.lc \
- main/StgTrace.lc \
main/Threads.lc \
+ main/RtsFlags.lc \
main/main.lc \
prims/PrimArith.lc \
prims/PrimMisc.lc \
profiling/Hashing.lc \
profiling/HeapProfile.lc \
profiling/Indexing.lc \
- profiling/LifeProfile.lc \
profiling/Timer.lc \
- storage/Force_GC.lc \
storage/SM1s.lc \
storage/SM2s.lc \
storage/SMap.lc \
io/toLocalTime.lc \
io/toUTCTime.lc \
io/writeFile.lc \
- prims/ByteOps.lc \
- storage/SMalloc.lc __readline_cfile
+ main/Mallocs.lc \
+ prims/ByteOps.lc __readline_cfile
H_FILES = $(RTS_LH:.lh=.h)
C_FILES = $(RTS_LC:.lc=.c) $(RTS_LHC:.lhc=.hc) $(CLIB_LC:.lc=.c)
RTS_OBJS_m = $(RTS_LC:.lc=_m.o) $(RTS_LHC:.lhc=_m.o)
RTS_OBJS_n = $(RTS_LC:.lc=_n.o) $(RTS_LHC:.lhc=_n.o)
RTS_OBJS_o = $(RTS_LC:.lc=_o.o) $(RTS_LHC:.lhc=_o.o)
+RTS_OBJS_A = $(RTS_LC:.lc=_A.o) $(RTS_LHC:.lhc=_A.o)
+RTS_OBJS_B = $(RTS_LC:.lc=_B.o) $(RTS_LHC:.lhc=_B.o)
CLIB_OBJS = $(CLIB_LC:.lc=.o)
CompileClibishly(io/toLocalTime,)
CompileClibishly(io/toUTCTime,)
CompileClibishly(io/writeFile,)
+CompileClibishly(main/Mallocs,)
CompileClibishly(main/TopClosure,) /* NB */
CompileClibishly(main/TopClosure13,) /* ditto */
CompileClibishly(prims/ByteOps,)
-CompileClibishly(storage/SMalloc,)
#if GhcWithReadline == YES
CompileClibishly(io/ghcReadline,)
#endif
# endif
AllTarget(gum/SysMan)
-gum/SysMan : gum/SysMan_mp.o gum/LLComms_mp.o
+gum/SysMan : gum/SysMan_mp.o gum/LLComms_mp.o main/Mallocs.o hooks/OutOfVM.o
$(RM) $@
- $(CC) gum/SysMan_mp.o gum/LLComms_mp.o -o $@ -L$$PVM_ROOT/lib/$$PVM_ARCH -lpvm3 -lgpvm3 __socket_libs
+ $(CC) -o $@ gum/SysMan_mp.o gum/LLComms_mp.o main/Mallocs.o hooks/OutOfVM.o -L$$PVM_ROOT/lib/$$PVM_ARCH -lpvm3 -lgpvm3 __socket_libs
ExtraStuffToClean(gum/SysMan_mp.o gum/SysMan)
# if DoInstallGHCSystem == YES
install :: gum/SysMan
IfGhcBuild_m(BigBuildTarget(_m, $(RTS_OBJS_m)))
IfGhcBuild_n(BigBuildTarget(_n, $(RTS_OBJS_n)))
IfGhcBuild_o(BigBuildTarget(_o, $(RTS_OBJS_o)))
+IfGhcBuild_A(BigBuildTarget(_A, $(RTS_OBJS_A)))
+IfGhcBuild_B(BigBuildTarget(_B, $(RTS_OBJS_B)))
/****************************************************************
IfGhcBuild_l(DoRtsFile(file,isuf,_l, flags $(GHC_OPTS_l))) \
IfGhcBuild_m(DoRtsFile(file,isuf,_m, flags $(GHC_OPTS_m))) \
IfGhcBuild_n(DoRtsFile(file,isuf,_n, flags $(GHC_OPTS_n))) \
-IfGhcBuild_o(DoRtsFile(file,isuf,_o, flags $(GHC_OPTS_o)))
+IfGhcBuild_o(DoRtsFile(file,isuf,_o, flags $(GHC_OPTS_o))) \
+IfGhcBuild_A(DoRtsFile(file,isuf,_A, flags $(GHC_OPTS_A))) \
+IfGhcBuild_B(DoRtsFile(file,isuf,_B, flags $(GHC_OPTS_B)))
/* here we go: */
CompileRTSishly(c-as-asm/CallWrap_C,.c,)
CompileRTSishly(c-as-asm/FreeMallocPtr,.c,)
CompileRTSishly(c-as-asm/HpOverflow,.c,)
-CompileRTSishly(c-as-asm/PerformIO,.hc,-mtoggle-sp-mangling/*toggle it back*/)
+CompileRTSishly(c-as-asm/PerformIO,.hc,-optcO-DIN_GHC_RTS=1)
CompileRTSishly(c-as-asm/StablePtr,.c,)
CompileRTSishly(c-as-asm/StablePtrOps,.c,)
CompileRTSishly(c-as-asm/StgDebug,.c,)
CompileRTSishly(c-as-asm/StgMiniInt,.c,)
-CompileRTSishly(gum/FetchMe,.hc,-mtoggle-sp-mangling/*toggle it back*/)
+CompileRTSishly(gum/FetchMe,.hc,-optcO-DIN_GHC_RTS=1)
CompileRTSishly(gum/GlobAddr,.c,)
CompileRTSishly(gum/HLComms,.c,)
CompileRTSishly(gum/Hash,.c,)
CompileRTSishly(gum/Unpack,.c,)
CompileRTSishly(main/GranSim,.c,)
CompileRTSishly(main/Itimer,.c,)
-CompileRTSishly(main/RednCounts,.c,)
+CompileRTSishly(main/Ticky,.c,)
CompileRTSishly(main/SMRep,.c,)
CompileRTSishly(main/Select,.c,)
CompileRTSishly(main/Signals,.c,)
CompileRTSishly(main/StgOverflow,.c,)
-CompileRTSishly(main/StgStartup,.hc,-mtoggle-sp-mangling/*toggle it back*/)
-CompileRTSishly(main/StgThreads,.hc,-mtoggle-sp-mangling/*toggle it back*/)
-CompileRTSishly(main/StgTrace,.c,)
-CompileRTSishly(main/StgUpdate,.hc,-mtoggle-sp-mangling/*toggle it back*/)
+CompileRTSishly(main/StgStartup,.hc,-optcO-DIN_GHC_RTS=1)
+CompileRTSishly(main/StgThreads,.hc,-optcO-DIN_GHC_RTS=1)
+CompileRTSishly(main/StgUpdate,.hc,-optcO-DIN_GHC_RTS=1)
CompileRTSishly(main/Threads,.c,)
+CompileRTSishly(main/RtsFlags,.c,)
CompileRTSishly(main/main,.c,)
CompileRTSishly(profiling/CostCentre,.c,)
CompileRTSishly(profiling/Hashing,.c,)
CompileRTSishly(profiling/HeapProfile,.c,)
CompileRTSishly(profiling/Indexing,.c,)
-CompileRTSishly(profiling/LifeProfile,.c,)
CompileRTSishly(profiling/Timer,.c,)
CompileRTSishly(prims/PrimArith,.c,)
CompileRTSishly(prims/PrimMisc,.c,)
-CompileRTSishly(storage/Force_GC,.c,)
CompileRTSishly(storage/SM1s,.c,)
CompileRTSishly(storage/SM2s,.c,)
CompileRTSishly(storage/SMap,.c,)
CompileRTSishly(storage/SMextn,.c,)
CompileRTSishly(storage/SMgen,.c,)
CompileRTSishly(storage/SMinit,.c,)
-CompileRTSishly(storage/SMmark,.hc,-optc-DMARK_REG_MAP)
+CompileRTSishly(storage/SMmark,.hc,-optcO-DIN_GHC_RTS=1 -optc-DMARK_REG_MAP)
CompileRTSishly(storage/SMmarking,.c,)
CompileRTSishly(storage/SMscan,.c,)
CompileRTSishly(storage/SMscav,.c,)
CALLER_SAVE_Hp
CALLER_SAVE_HpLim
CALLER_SAVE_Liveness
- CALLER_SAVE_Activity
CALLER_SAVE_Ret
MAGIC_CALL
CALLER_RESTORE_Hp
CALLER_RESTORE_HpLim
CALLER_RESTORE_Liveness
- CALLER_RESTORE_Activity
CALLER_RESTORE_Ret
/* These next two are restore-only */
CALLER_SAVE_Hp
CALLER_SAVE_HpLim
CALLER_SAVE_Liveness
- CALLER_SAVE_Activity
CALLER_SAVE_Ret
MAGIC_CALL
CALLER_RESTORE_Hp
CALLER_RESTORE_HpLim
CALLER_RESTORE_Liveness
- CALLER_RESTORE_Activity
CALLER_RESTORE_Ret
/* These next two are restore-only */
EXTFUN(EnterNodeCode);
+void *__temp_esp, *__temp_eax;
+
void PerformGC_wrapper PROTO((W_)) WRAPPER_NAME(PerformGC);
void PerformGC_wrapper(args)
W_ args;
{
- WRAPPER_SETUP(PerformGC)
+#if i386_TARGET_ARCH
+ void *ret_addr;
+
+ WRAPPER_SETUP(PerformGC,ret_addr,args)
+#else
+ WRAPPER_SETUP(PerformGC, ignore_me, ignore_me)
+#endif
PerformGC(args);
WRAPPER_RETURN(0)
}
# ifdef CONCURRENT
+void __DISCARD__ (STG_NO_ARGS) { /*nothing*/ }
+
void StackOverflow_wrapper PROTO((W_,W_)) WRAPPER_NAME(StackOverflow);
void StackOverflow_wrapper(args1,args2)
W_ args1, args2;
{
- WRAPPER_SETUP(StackOverflow)
+#if i386_TARGET_ARCH
+ void *ret_addr, *ignore_me;
+ WRAPPER_SETUP(StackOverflow,ret_addr,ignore_me)
+#else
+ WRAPPER_SETUP(StackOverflow, ignore_me, ignore_me)
+#endif
if(StackOverflow(args1,args2)) {
WRAPPER_RETURN(1)
}
void Yield_wrapper(args)
W_ args;
{
- WRAPPER_SETUP(Yield)
+#if i386_TARGET_ARCH
+ void *ret_addr, *ignore_me;
+ WRAPPER_SETUP(Yield, ret_addr, ignore_me)
+#else
+ WRAPPER_SETUP(Yield, ignore_me, ignore_me)
+#endif
Yield(args);
WRAPPER_RETURN(0)
}
W_ liveness;
W_ always_reenter_node;
{
- WRAPPER_SETUP(PerformReschedule)
+#if i386_TARGET_ARCH
+ void *ret_addr, *ignore_me;
+ WRAPPER_SETUP(PerformReschedule, ret_addr, ignore_me)
+#else
+ WRAPPER_SETUP(PerformReschedule, ignore_me, ignore_me)
+#endif
PerformReschedule(liveness, always_reenter_node);
WRAPPER_RETURN(0)
}
#endif /* CONCURRENT */
extern smInfo StorageMgrInfo;
-extern void PrintRednCountInfo(STG_NO_ARGS);
-extern I_ showRednCountStats;
-extern I_ SM_word_heap_size;
-extern I_ squeeze_upd_frames;
+extern void PrintTickyInfo(STG_NO_ARGS);
#if defined(GRAN_CHECK) && defined(GRAN)
extern W_ debug;
#endif
-#ifdef GRAN
-extern FILE *main_statsfile; /* Might be of general interest HWL */
-#endif
/* the real work is done by this function --- see wrappers at end */
I_ num_ptr_roots = 0; /* we bump this counter as we
store roots; de-bump it
as we re-store them. */
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
CostCentre Save_CCC;
#endif
/* stop the profiling timer --------------------- */
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
/* STOP_TIME_PROFILER; */
#endif
SAVE_Liveness = liveness;
+ /*
+ fprintf(stderr,"RealGC:liveness=0x%lx,reqsize=0x%lx,reenter=%lx,do_full=%d,context_switch=%ld\n",
+ liveness, reqsize,always_reenter_node,do_full_collection,context_switch);
+ */
+
/*
Even on a uniprocessor, we may have to reenter node after a
context switch. Though it can't turn into a FetchMe, its shape
return;
}
/* Set up to re-enter Node, so as to be sure it's really there. */
- assert(liveness & LIVENESS_R1);
+ ASSERT(liveness & LIVENESS_R1);
TSO_SWITCH(CurrentTSO) = TSO_PC2(CurrentTSO);
TSO_PC2(CurrentTSO) = EnterNodeCode;
}
SAVE_Hp -= reqsize;
if (context_switch && !do_full_collection
-# if defined(USE_COST_CENTRES)
+# if defined(PROFILING)
&& !interval_expired
# endif
) {
TSO_ARG1(CurrentTSO) = reqsize;
TSO_PC1(CurrentTSO) = CheckHeapCode;
# ifdef PAR
- if (do_gr_profile) {
+ if (RTSflags.ParFlags.granSimStats) {
TSO_EXECTIME(CurrentTSO) += CURRENT_TIME - TSO_BLOCKEDAT(CurrentTSO);
}
# endif
}
/* Don't use SET_CCC, because we don't want to bump the sub_scc_count */
-# if defined(USE_COST_CENTRES)
+# if defined(PROFILING)
Save_CCC = CCC;
# endif
+# if defined(PAR)
CCC = (CostCentre)STATIC_CC_REF(CC_GC);
CCC->scc_count++;
+# endif
ReallyPerformThreadGC(reqsize, do_full_collection);
#else /* !CONCURRENT */
-# if defined(USE_COST_CENTRES)
+# if defined(PROFILING)
/* Don't use SET_CCC, because we don't want to bump the sub_scc_count */
Save_CCC = CCC;
CCC = (CostCentre)STATIC_CC_REF(CC_GC);
* Before we garbage collect we may have to squeeze update frames and/or
* black hole the update stack
*/
- if (squeeze_upd_frames) {
- /* Squeeze and/or black hole update frames */
+ if (! RTSflags.GcFlags.squeezeUpdFrames) {
+ BlackHoleUpdateStack();
+
+ } else { /* Squeeze and/or black hole update frames */
I_ displacement;
displacement = SqueezeUpdateFrames(stackInfo.botB + BREL(1), MAIN_SpB, MAIN_SuB);
MAIN_SpB += BREL(displacement);
/* fprintf(stderr, "B size %d, squeezed out %d\n", MAIN_SpB - stackInfo.botB,
displacement); */
- } /* note the conditional else clause below */
-# if defined(SM_DO_BH_UPDATE)
- else
- BlackHoleUpdateStack();
-# endif /* SM_DO_BH_UPDATE */
+ }
- assert(num_ptr_roots <= SM_MAXROOTS);
+ ASSERT(num_ptr_roots <= SM_MAXROOTS);
StorageMgrInfo.rootno = num_ptr_roots;
SAVE_Hp -= reqsize;
GC_result = collectHeap(reqsize, &StorageMgrInfo, do_full_collection);
if ( GC_result == GC_HARD_LIMIT_EXCEEDED ) {
- OutOfHeapHook(reqsize * sizeof(W_), SM_word_heap_size * sizeof(W_)); /*msg*/
+ OutOfHeapHook(reqsize * sizeof(W_)); /*msg*/
shutdownHaskell();
EXIT(EXIT_FAILURE);
} else { /* This should not happen */
fprintf(stderr, "Panic: garbage collector returned %d please report it as a bug to glasgow-haskell-bugs@dcs.gla.ac.uk\n", GC_result );
-# if defined(DO_REDN_COUNTING)
- if (showRednCountStats) {
- PrintRednCountInfo();
- }
+# if defined(TICKY_TICKY)
+ if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
# endif
abort();
}
__DEROOT_PTR_REG(IS_LIVE_R2(liveness),2);
__DEROOT_PTR_REG(IS_LIVE_R1(liveness),1);
- assert(num_ptr_roots == 0); /* we have put it all back */
+ ASSERT(num_ptr_roots == 0); /* we have put it all back */
unblockUserSignals();
#endif /* !CONCURRENT */
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
CCC = Save_CCC;
RESTART_TIME_PROFILER;
}
/* Set up to re-enter Node, so as to be sure it's really there. */
- assert(liveness & LIVENESS_R1);
+ ASSERT(liveness & LIVENESS_R1);
TSO_SWITCH(CurrentTSO) = TSO_PC2(CurrentTSO);
TSO_PC2(CurrentTSO) = (void *) EnterNodeCode;
}
(SPARK_NODE(spark) == Nil_closure) ) {
# if defined(GRAN_CHECK) && defined(GRAN)
if ( debug & 0x40 )
- fprintf(main_statsfile,"PruneSparks: Warning: spark @ 0x%lx points to NULL or Nil_closure\n", spark);
+ fprintf(RTSflags.GcFlags.statsFile,"PruneSparks: Warning: spark @ 0x%lx points to NULL or Nil_closure\n", spark);
# endif
if (do_qp_prof)
QP_Event0(threadId++, SPARK_NODE(spark));
SPARK_NEXT(prev) = NULL;
PendingSparksTl[proc][pool] = prev;
if (prunedSparks>0)
- fprintf(main_statsfile,"Pruning and disposing %lu excess sparks (> %lu) on proc %ld in PruneSparks\n",
+ fprintf(RTSflags.GcFlags.statsFile,"Pruning and disposing %lu excess sparks (> %lu) on proc %ld in PruneSparks\n",
prunedSparks,(W_) MAX_SPARKS,proc);
} /* forall pool ... */
} /* forall proc ... */
as we re-store them. */
P_ stack, tso, next;
- /* Discard the saved stack and TSO space */
+ /* Discard the saved stack and TSO space.
+ What's going on here: TSOs and StkOs are on the mutables
+ list (mutable things in the old generation). Here, we change
+ them to immutable, so that the scavenger (which chks all
+ mutable objects) can detect their immutability and remove
+ them from the list. Setting to MUTUPLE_VHS as the size is
+ essentially saying "No pointers in here" (i.e., empty).
+
+ Without this change of status, these
+ objects might not really die, probably with some horrible
+ disastrous consequence that we don't want to think about.
+ Will & Phil 95/10
+ */
for(stack = AvailableStack; stack != Nil_closure; stack = next) {
next = STKO_LINK(stack);
# if defined(GRAN_CHECK) && defined(GRAN)
if ( debug & 0x40 )
- fprintf(main_statsfile,"Saving RunnableThreadsHd %d (proc: %d) -- 0x%lx\n",
+ fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsHd %d (proc: %d) -- 0x%lx\n",
num_ptr_roots,proc,RunnableThreadsHd[proc]);
# endif
# if defined(GRAN_CHECK) && defined(GRAN)
if ( debug & 0x40 )
- fprintf(main_statsfile,"Saving RunnableThreadsTl %d (proc: %d) -- 0x%lx\n",
+ fprintf(RTSflags.GcFlags.statsFile,"Saving RunnableThreadsTl %d (proc: %d) -- 0x%lx\n",
num_ptr_roots,proc,RunnableThreadsTl[proc]);
# endif
StorageMgrInfo.roots[num_ptr_roots++] = RunnableThreadsTl[proc];
# if defined(GRAN_CHECK) && defined(GRAN)
if ( debug & 0x40 )
- fprintf(main_statsfile,"Saving CurrentTSO %d -- 0x%lx\n",
+ fprintf(RTSflags.GcFlags.statsFile,"Saving CurrentTSO %d -- 0x%lx\n",
num_ptr_roots,CurrentTSO);
# endif
if (collectHeap(reqsize, &StorageMgrInfo, do_full_collection) != GC_SUCCESS) {
- OutOfHeapHook(reqsize * sizeof(W_), SM_word_heap_size * sizeof(W_)); /*msg*/
+ OutOfHeapHook(reqsize * sizeof(W_)); /*msg*/
-# if defined(DO_REDN_COUNTING)
- if (showRednCountStats) {
- PrintRednCountInfo();
- }
+# if defined(TICKY_TICKY)
+ if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
# endif
EXIT(EXIT_FAILURE);
}
# if defined(GRAN_CHECK) && defined(GRAN)
if ( debug & 0x40 )
- fprintf(main_statsfile,"Restoring CurrentTSO %d -- new: 0x%lx\n",
+ fprintf(RTSflags.GcFlags.statsFile,"Restoring CurrentTSO %d -- new: 0x%lx\n",
num_ptr_roots-1,StorageMgrInfo.roots[num_ptr_roots-1]);
# endif
# if defined(GRAN_CHECK) && defined(GRAN)
if ( debug & 0x40 )
- fprintf(main_statsfile,"Restoring RunnableThreadsTl %d (proc: %d) -- new: 0x%lx\n",
+ fprintf(RTSflags.GcFlags.statsFile,"Restoring RunnableThreadsTl %d (proc: %d) -- new: 0x%lx\n",
num_ptr_roots-1,proc,StorageMgrInfo.roots[num_ptr_roots-1]);
# endif
# if defined(GRAN_CHECK) && defined(GRAN)
if ( debug & 0x40 )
- fprintf(main_statsfile,"Restoring RunnableThreadsHd %d (proc: %d) -- new: 0x%lx\n",
+ fprintf(RTSflags.GcFlags.statsFile,"Restoring RunnableThreadsHd %d (proc: %d) -- new: 0x%lx\n",
num_ptr_roots,proc,StorageMgrInfo.roots[num_ptr_roots]);
# endif
pending updates to avoid space leaks from them.
\begin{code}
-#if !defined(CONCURRENT) && defined(SM_DO_BH_UPDATE)
+#if !defined(CONCURRENT)
static
void
{
P_ PtrToUpdateFrame;
- if (noBlackHoles)
+ if (! RTSflags.GcFlags.lazyBlackHoling)
return;
PtrToUpdateFrame = MAIN_SuB;
PtrToUpdateFrame = GRAB_SuB(PtrToUpdateFrame);
}
}
-#endif /* CONCURRENT && SM_DO_BH_UPDATE */
+#endif /* CONCURRENT */
\end{code}
\begin{code}
#if defined(CONCURRENT) && !defined(GRAN)
void
-PerformReschedule(liveness, always_reenter_node)
- W_ liveness;
- W_ always_reenter_node;
-
+PerformReschedule(W_ liveness, W_ always_reenter_node)
{ }
#endif
\end{code}
used to load the STG registers.
*/
-#if defined (DO_SPAT_PROFILING)
- SET_ACTIVITY(ACT_REDN); /* init: do this first, so we count the restore insns */
-#endif
-
- /* Load up the real registers from the *_SAVE locns.
- */
+ /* Load up the real registers from the *_SAVE locns. */
RestoreAllStgRegs(); /* inline! */
/* ------- STG registers are now valid! -------------------------*/
{
FUNBEGIN;
-#if defined (DO_SPAT_PROFILING)
- SET_ACTIVITY(ACT_REDN); /* init: do this first so we count restore insns */
-#endif
-
/* Load up the real registers from the *_SAVE locns. */
#if defined(__STG_GCC_REGS__)
RestoreAllStgRegs(); /* inline! */
{
FUNBEGIN;
-#if defined (DO_SPAT_PROFILING)
- SET_ACTIVITY(ACT_REDN); /* init: do this first so we count restore insns */
-#endif
-
/* Load up the real registers from the *_SAVE locns. */
#if defined(__STG_GCC_REGS__)
RestoreAllStgRegs(); /* inline! */
extern StgPtr unstable_Closure;
-#ifndef __STG_TAILJUMPS__
-extern int doSanityChks;
-extern void checkAStack(STG_NO_ARGS);
-#endif
-
void
enterStablePtr(stableIndex, startCode)
StgStablePtr stableIndex;
StgFunPtr startCode;
{
- unstable_Closure = _deRefStablePointer(stableIndex, StorageMgrInfo.StablePointerTable);
+ unstable_Closure
+ = _deRefStablePointer(stableIndex, StorageMgrInfo.StablePointerTable);
/* ToDo: Set arity to right value - if necessary */
-#if defined(__STG_TAILJUMPS__)
- miniInterpret(startCode);
-#else
- if (doSanityChks)
- miniInterpret_debug(startCode, checkAStack);
- else
miniInterpret(startCode);
-#endif /* not tail-jumping */
-
}
\end{code}
DEBUG_UPDATES(frames) Print "frames" update frames
DEBUG_REGS() Print register values
DEBUG_MP() Print the MallocPtr Lists
+ DEBUG_TSO(tso) (CONCURRENT) Print a Thread State Object
-\begin{code}
-#if defined(RUNTIME_DEBUGGING)
+Not yet implemented:
+ DEBUG_STKO(stko) (CONCURRENT) Print a STacK Object
+\begin{code}
#include "rtsdefs.h"
\end{code}
ToDo: At least add some #ifdefs
\begin{code}
-#include <a.out.h>
-#include <stab.h>
+/* #include <a.out.h> */
+/* #include <stab.h> */
/* #include <nlist.h> */
#include <stdio.h>
static int table_size;
static struct entry* table;
-static
-void reset_table( int size )
+static void
+reset_table( int size )
{
max_table_size = size;
table_size = 0;
- table = (struct entry *) malloc( size * sizeof( struct entry ) );
+ table = (struct entry *) stgMallocBytes(size * sizeof(struct entry), "reset_table");
}
-static
-void prepare_table()
+static void
+prepare_table()
{
/* Could sort it... */
}
-static
-void insert( unsigned value, int index, char *name )
+static void
+insert( unsigned value, int index, char *name )
{
if ( table_size >= max_table_size ) {
fprintf( stderr, "Symbol table overflow\n" );
- exit( 1 );
+ EXIT( 1 );
}
table[table_size].value = value;
table[table_size].index = index;
table_size = table_size + 1;
}
-static
-int lookup( unsigned value, int *result )
+static int
+lookup( unsigned value, int *result )
{
int i;
for( i = 0; i < table_size && table[i].value != value; ++i ) {
}
}
-static int lookup_name( char *name, unsigned *result )
+static int
+lookup_name( char *name, unsigned *result )
{
int i;
for( i = 0; i < table_size && strcmp(name,table[i].name) != 0; ++i ) {
}
}
+#if 0 /* OMIT load-symbol stuff cos it doesn't work on Alphas */
+
/* Fairly ad-hoc piece of code that seems to filter out a lot of
rubbish like the obj-splitting symbols */
-static
-int isReal( unsigned char type, char *name )
+static int
+isReal( unsigned char type, char *name )
{
int external = type & N_EXT;
int tp = type & N_TYPE;
}
}
-void DEBUG_LoadSymbols( char *name )
+void
+DEBUG_LoadSymbols( char *name )
{
FILE *binary;
if (fread( &header, sizeof( struct exec ), 1, binary ) != 1) {
fprintf( stderr, "Can't read symbol table header.\n" );
- exit( 1 );
+ EXIT( 1 );
}
if ( N_BADMAG( header ) ) {
fprintf( stderr, "Bad magic number in symbol table header.\n" );
- exit( 1 );
+ EXIT( 1 );
}
num_syms = sym_size / sizeof( struct nlist );
fseek( binary, sym_offset, FROM_START );
- symbol_table = (struct nlist *) malloc( sym_size );
- if (symbol_table == NULL) {
- fprintf( stderr, "Can't allocate symbol table of size %d\n", sym_size );
- exit( 1 );
- }
-
+ symbol_table = (struct nlist *) stgMallocBytes(sym_size, "symbol table (DEBUG_LoadSymbols)");
printf("Reading %d symbols\n", num_syms);
if (fread( symbol_table, sym_size, 1, binary ) != 1) {
fprintf( stderr, "Can't read symbol table\n");
- exit( 1 );
+ EXIT( 1 );
}
-
-
str_offset = N_STROFF( header );
fseek( binary, str_offset, FROM_START );
if (fread( &str_size, 4, 1, binary ) != 1) {
fprintf( stderr, "Can't read string table size\n");
- exit( 1 );
+ EXIT( 1 );
}
/* apparently the size of the string table includes the 4 bytes that
* store the size...
*/
- string_table = (char *) malloc( str_size );
- if (string_table == NULL) {
- fprintf( stderr, "Can't allocate string table of size %d\n", str_size );
- exit( 1 );
- }
+ string_table = (char *) stgMallocBytes(str_size, "string table (DEBUG_LoadSymbols)");
if (fread( string_table+4, str_size-4, 1, binary ) != 1) {
fprintf( stderr, "Can't read string table\n");
- exit( 1 );
+ EXIT( 1 );
}
num_real_syms = 0;
prepare_table();
}
+#endif /* 0 */
\end{code}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\begin{code}
/* Determine the size and number of pointers for this kind of closure */
-static
-void
+static void
getClosureShape( P_ node, int *vhs, int *size, int *ptrs, char **type )
{
/* The result is used for printing out closure contents. If the
}
}
-static
-void
+static void
printWord( W_ word )
{
printf("0x%08lx", word);
}
-static
-void
+static void
printAddress( P_ address )
{
-#ifdef PAR
+# ifdef CONCURRENT
PP_ SpA = STKO_SpA(SAVE_StkO);
PP_ SuA = STKO_SuA(SAVE_StkO);
P_ SpB = STKO_SpB(SAVE_StkO);
P_ SuB = STKO_SuB(SAVE_StkO);
-#else
+# else
PP_ SpA = SAVE_SpA;
PP_ SuA = SAVE_SuA;
P_ SpB = SAVE_SpB;
P_ SuB = SAVE_SuB;
-#endif
+# endif
P_ Hp = SAVE_Hp;
PP_ botA = stackInfo.botA;
/* The @-1@s in stack comparisions are because we sometimes use the
address of just below the stack... */
+#if 0
if (lookupForName( address, &name )) {
printZcoded( name );
- } else {
+ }
+ else
+#endif
+ {
if (DEBUG_details > 1) {
printWord( (W_) address );
printf(" : ");
}
}
-static
-void
+static void
printIndentation( int indentation )
{
int i;
}
/* The weight parameter is used to (eventually) break cycles */
-static
-void
+static void
printStandardShapeClosure(
int indentation,
int weight,
P_ closure, int vhs, int size, int noPtrs
)
{
-#ifdef PAR
+#ifdef CONCURRENT
PP_ SpA = STKO_SpA(SAVE_StkO);
PP_ SuA = STKO_SuA(SAVE_StkO);
P_ SpB = STKO_SpB(SAVE_StkO);
}
}
-void DEBUG_PrintA( int depth, int weight )
+void
+DEBUG_PrintA( int depth, int weight )
{
PP_ SpA = SAVE_SpA;
PP_ SuA = SAVE_SuA;
}
}
-void DEBUG_PrintB( int depth, int weight )
+void
+DEBUG_PrintB( int depth, int weight )
{
PP_ SpA = SAVE_SpA;
PP_ SuA = SAVE_SuA;
\begin{code}
/* How many real stacks are there on SpA and SpB? */
-static
-int numStacks( )
+static int
+numStacks( )
{
-#ifdef PAR
+#ifdef CONCURRENT
PP_ SpA = STKO_SpA(SAVE_StkO);
PP_ SuA = STKO_SuA(SAVE_StkO);
P_ SpB = STKO_SpB(SAVE_StkO);
return depth;
}
-static
-void printLocalAStack( int depth, int indentation, int weight, PP_ SpA, int size )
+static void
+printLocalAStack( int depth, int indentation, int weight, PP_ SpA, int size )
{
int i;
}
}
-static
-void printLocalBStack( int depth, int indentation, int weight, P_ SpB, int size )
+static void
+printLocalBStack( int depth, int indentation, int weight, P_ SpB, int size )
{
int i;
}
}
-static
-void printEnvironment( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
+static void
+printEnvironment( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
{
int sizeA = SUBTRACT_A_STK(SpA, SuA);
int sizeB = SUBTRACT_B_STK(SpB, SuB);
\begin{code}
static int maxDepth = 5;
-static
-int printCases( int depth, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
+static int
+printCases( int depth, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
{
int indentation;
/* ToDo: pay more attention to format of vector tables in SMupdate.lh */
-static
-int isVTBLEntry( P_ entry )
+static int
+isVTBLEntry( P_ entry )
{
char *raw;
}
}
-static
-void printVectorTable( int indentation, PP_ vtbl )
+static void
+printVectorTable( int indentation, PP_ vtbl )
{
if (isVTBLEntry( (P_) vtbl )) { /* Direct return */
printName( (P_) vtbl );
}
}
-static
-void printContinuations( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
+static void
+printContinuations( int depth, int indentation, int weight, PP_ SpA, PP_ SuA, P_ SpB, P_ SuB )
{
if (depth < maxDepth && SUBTRACT_B_STK(SuB, stackInfo.botB) >= 0) {
PP_ nextSpA, nextSuA;
}
}
-
-void DEBUG_Where( int depth, int weight )
+void
+DEBUG_Where( int depth, int weight )
{
-#ifdef PAR
+#ifdef CONCURRENT
PP_ SpA = STKO_SpA(SAVE_StkO);
PP_ SuA = STKO_SuA(SAVE_StkO);
P_ SpB = STKO_SpB(SAVE_StkO);
\begin{code}
-#if defined(RUNTIME_DEBUGGING)
-
void
DEBUG_INFO_TABLE(node)
-P_ node;
+ P_ node;
{
int vhs, size, ptrs; /* not used */
char *ip_type;
fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
#endif /* PAR */
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
fprintf(stderr,"Cost Centre: 0x%lx\n",INFO_CAT(info_ptr));
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING */
#if defined(_INFO_COPYING)
fprintf(stderr,"Evacuate Entry: 0x%lx;\tScavenge Entry: 0x%lx\n",
void
DEBUG_REGS()
{
-#ifdef PAR
+#ifdef CONCURRENT
PP_ SpA = STKO_SpA(SAVE_StkO);
PP_ SuA = STKO_SuA(SAVE_StkO);
P_ SpB = STKO_SpB(SAVE_StkO);
fprintf(stderr,"Dble: %8g, %8g\n",DblReg1,DblReg2);
}
+#ifndef CONCURRENT
+
void
DEBUG_MP()
{
*/
}
-#if defined(GCap) || defined(GCgn)
+# if defined(GCap) || defined(GCgn)
fprintf(stderr,"\nOldMallocPtr List\n\n");
for(mp = StorageMgrInfo.OldMallocPtrList;
DEBUG_PRINT_NODE(mp);
*/
}
-#endif /* GCap || GCgn */
+# endif /* GCap || GCgn */
fprintf(stderr, "\n");
}
-#ifndef PAR
void
DEBUG_SPT(int weight)
{
fprintf(stderr, "\n\n");
}
-#endif /* !PAR */
-
+#endif /* !CONCURRENT */
/*
These routines crawl over the A and B stacks, printing
a maximum "lines" lines at the top of the stack.
*/
-
#define STACK_VALUES_PER_LINE 5
-#if !defined(PAR)
+#ifndef CONCURRENT
/* (stack stuff is really different on parallel machines) */
void
DEBUG_ASTACK(lines)
-I_ lines;
+ I_ lines;
{
PP_ SpA = SAVE_SpA;
PP_ SuA = SAVE_SuA;
fprintf(stderr, "\n");
}
-
void
DEBUG_BSTACK(lines)
-I_ lines;
+ I_ lines;
{
PP_ SpA = SAVE_SpA;
PP_ SuA = SAVE_SuA;
}
fprintf(stderr, "\n");
}
-#endif /* not parallel */
+#endif /* not concurrent */
/*
This should disentangle update frames from both stacks.
*/
-#if ! defined(PAR)
+#ifndef CONCURRENT
void
DEBUG_UPDATES(limit)
-I_ limit;
+ I_ limit;
{
PP_ SpA = SAVE_SpA;
PP_ SuA = SAVE_SuA;
P_ SpB = SAVE_SpB;
P_ SuB = SAVE_SuB;
- P_ updatee, retreg;
- PP_ sua;
- P_ sub;
- PP_ spa = SuA;
- P_ spb = SuB;
- I_ count = 0;
+ P_ updatee, retreg;
+ PP_ sua, spa;
+ P_ sub, spb;
+ I_ count = 0;
fprintf(stderr,"Update Frame Stack Dump:\n\n");
- for(spb = SuB;
+ for(spa = SuA, spb = SuB;
SUBTRACT_B_STK(spb, stackInfo.botB) > 0 && count++ < limit;
- /* re-init given explicitly */)
- {
+ spa = GRAB_SuA(spb), spb = GRAB_SuB(spb) ) {
+
updatee = GRAB_UPDATEE(spb); /* Thing to be updated */
retreg = (P_) GRAB_RET(spb); /* Return vector below */
- fprintf(stderr,"SuA: 0x%08lx, SuB: 0x%08lx, Updatee 0x%08lx, RetReg 0x%x\n",
+ fprintf(stderr,"SuA: 0x%08lx, SuB: 0x%08lx, Updatee 0x%08lx (Info 0x%08lx), RetReg 0x%x\n",
(W_) spa, (W_) spb,
- (W_) updatee, (W_) retreg);
+ (W_) updatee, (W_) INFO_PTR(updatee), (W_) retreg);
+ }
+}
+
+#endif /* not concurrent */
+\end{code}
- spa = GRAB_SuA(spb); /* Next SuA, SuB */
- spb = GRAB_SuB(spb);
+\begin{code}
+#ifdef CONCURRENT
+
+void
+DEBUG_TSO(P_ tso)
+{
+ STGRegisterTable *r = TSO_INTERNAL_PTR(tso);
+ W_ liveness = r->rLiveness;
+ I_ i;
+
+ fprintf(stderr,"TSO:\ntso=%lx, regs=%lx, liveness=%lx\nlink=%lx,name=%lx,id=%lx,type=%lx,pc1=%lx,arg1=%lx,switch=%lx\n"
+ , tso
+ , r
+ , liveness
+ , TSO_LINK(tso)
+ , TSO_NAME(tso)
+ , TSO_ID(tso)
+ , TSO_TYPE(tso)
+ , TSO_PC1(tso)
+ , TSO_ARG1(tso)
+ , TSO_SWITCH(tso)
+ );
+
+ for (i = 0; liveness != 0; liveness >>= 1, i++) {
+ if (liveness & 1) {
+ fprintf(stderr, "live reg %d (%lx)\n",i, r->rR[i].p);
+ } else {
+ fprintf(stderr, "reg %d (%lx) not live\n", i, r->rR[i].p);
+ }
}
}
-#endif /* not parallel */
-
-#endif /* RUNTIME_DEBUGGING */
-#endif /* PAR || RUNTIME_DEBUGGING */
+#endif /* concurrent */
\end{code}
\begin{code}
#if defined(__STG_TAILJUMPS__) && defined(__GNUC__)
-#if i386_TARGET_ARCH || i486_TARGET_ARCH
-/* All together now: "Hack me gently, hack me dead ..." */
-P_ SP_stack[8]; /* two/three? is all that is really needed, I think (WDP) */
-I_ SP_stack_ptr = -1;
-#endif
-
void
miniInterpret(start_cont)
StgFunPtr start_cont;
/* ToDo: save real register in something somewhere */
longjmp(jmp_environment, 1);
}
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[StgMiniInt-portable-debugging]{Debugging mini-interpreter for ``portable~C''}
-%* *
-%************************************************************************
-
-See comments about @jmp_environment@ in section above.
-
-The debugging mini-interpreter, which is invoked if suitable RTS flags
-are given, offers two extra ``features:''
-\begin{description}
-
-\item[Circular buffer of last @NUM_SAVED_CONTINUATIONS@ continuations:]
-These are in @savedCont@, with @savedContCtr@ pointing to where the
-last one was slotted in.
-
-Reference is frequently made to this buffer when \tr{gdb}-ing broken C
-out of the compiler!
-
-\item[Hygiene-checking:]
-
-This version of the mini-interpreter can be given a hygiene-checking
-function which will be invoked each time 'round the loop. Again,
-given suitable RTS flags, we pass along a routine that walks over the
-stack checking for Bad Stuff. An example might be: pointers from the
-A stack into the wrong semi-space of the heap (indicating a
-garbage-collection bug)...
-\end{description}
-
-\begin{code}
-extern I_ doSanityChks; /* ToDo: move tidily */
-
-#define NUM_SAVED_CONTINUATIONS 32 /* For debug */
-I_ totalContCtr;
-I_ savedContCtr;
-StgFunPtr savedCont[NUM_SAVED_CONTINUATIONS];
-
-void miniInterpret_debug(start_cont, hygiene)
- StgFunPtr start_cont;
- void (*hygiene)();
-{
- StgFunPtr continuation = (StgFunPtr) start_cont;
- StgFunPtr next_continuation;
- jmp_buf save_buf;
- bcopy((char *) jmp_environment, (char *) save_buf, sizeof(jmp_buf));
- /* Save jmp_environment for previous call to miniInterpret */
-
- if (setjmp(jmp_environment) == 0) {
-
- totalContCtr = 0;
- savedContCtr = 0;
- savedCont[0] = start_cont;
-
- while ( 1 ) {
- next_continuation = (StgFunPtr) (continuation)();
-
- totalContCtr += 1;
- savedContCtr = (savedContCtr + 1) % NUM_SAVED_CONTINUATIONS;
- savedCont[savedContCtr] = next_continuation;
-
- continuation = next_continuation;
-
- /* hygiene chk can't be at start of loop, because it's the
- first continuation-thingy that loads up the registers.
- */
- if (doSanityChks && hygiene) {
- (hygiene)();
- }
- }
- }
- /* Restore jmp_environment for previous call */
- bcopy((char *) save_buf, (char *) jmp_environment, sizeof(jmp_buf));
-
- /* ToDo: restore real registers ... (see longjmp) */
- return;
- /*
- Note that on returning (after miniInterpretEnd is called)
- the values variables declared as real machine registers
- will be undefined.
- */
-}
-
-/* debugging version uses same "miniInterpretEnd" as the regular one */
#endif /* ! __STG_TAILJUMPS__ */
\end{code}
QP_Event1("GR", CurrentTSO);
}
- if(do_gr_profile) {
+ if (RTSflags.ParFlags.granSimStats) {
/* Note that CURRENT_TIME may perform an unsafe call */
TIME now = CURRENT_TIME;
TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
QP_Event1("GR", CurrentTSO);
}
- if(do_gr_profile) {
+ if (RTSflags.ParFlags.granSimStats) {
/* Note that CURRENT_TIME may perform an unsafe call */
TIME now = CURRENT_TIME;
TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
if ((gl = freeGALAList) != NULL) {
freeGALAList = gl->next;
- } else if ((gl = (GALA *) malloc(GCHUNK * sizeof(GALA))) != NULL) {
+ } else {
+ gl = (GALA *) stgMallocBytes(GCHUNK * sizeof(GALA), "allocGALA");
+
freeGALAList = gl + 1;
for (p = freeGALAList; p < gl + GCHUNK - 1; p++)
p->next = p + 1;
p->next = NULL;
- } else {
- fflush(stdout);
- fprintf(stderr, "VM exhausted\n");
- EXIT(EXIT_FAILURE);
}
return gl;
}
static int nextPE = 0;
W_
-taskIDtoPE(gtid)
-GLOBAL_TASK_ID gtid;
+taskIDtoPE(GLOBAL_TASK_ID gtid)
{
return (W_) lookupHashTable(taskIDtoPEtable, gtid);
}
GALA *gala;
/* We never look for GA's on indirections */
- ASSERT(INFO_PTR(addr) != (W_) Ind_info);
+ ASSERT(INFO_PTR(addr) != (W_) Ind_info_TO_USE);
if ((gala = lookupHashTable(LAtoGALAtable, (W_) addr)) == NULL)
return NULL;
else
GALAlookup(ga)
globalAddr *ga;
{
- W_ pga = PACK_GA(taskIDtoPE(ga->loc.gc.gtid), ga->loc.gc.slot);
+ W_ pga = PackGA(taskIDtoPE(ga->loc.gc.gtid), ga->loc.gc.slot);
GALA *gala;
P_ la;
else {
la = gala->la;
/*
- * Bypass any indirections when returning a local closure to the caller.
- * Note that we do not short-circuit the entry in the GALA tables right
- * now, because we would have to do a hash table delete and insert in
- * the LAtoGALAtable to keep that table up-to-date for preferred GALA pairs.
- * That's probably a bit expensive.
+ * Bypass any indirections when returning a local closure to
+ * the caller. Note that we do not short-circuit the entry in
+ * the GALA tables right now, because we would have to do a
+ * hash table delete and insert in the LAtoGALAtable to keep
+ * that table up-to-date for preferred GALA pairs. That's
+ * probably a bit expensive.
*/
while (IS_INDIRECTION(INFO_PTR(la)))
la = (P_) IND_CLOSURE_PTR(la);
\begin{code}
static GALA *
-allocIndirection(addr)
-P_ addr;
+allocIndirection(P_ addr)
{
GALA *gala;
{
GALA *oldGALA = lookupHashTable(LAtoGALAtable, (W_) addr);
GALA *newGALA = allocIndirection(addr);
- W_ pga = PACK_GA(thisPE, newGALA->ga.loc.gc.slot);
+ W_ pga = PackGA(thisPE, newGALA->ga.loc.gc.slot);
ASSERT(GALAlookup(&(newGALA->ga)) == NULL);
{
GALA *oldGALA = lookupHashTable(LAtoGALAtable, (W_) addr);
GALA *newGALA = allocGALA();
- W_ pga = PACK_GA(taskIDtoPE(ga->loc.gc.gtid), ga->loc.gc.slot);
+ W_ pga = PackGA(taskIDtoPE(ga->loc.gc.gtid), ga->loc.gc.slot);
ASSERT(ga->loc.gc.gtid != mytid);
ASSERT(ga->weight > 0);
addWeight(ga)
globalAddr *ga;
{
- W_ pga = PACK_GA(taskIDtoPE(ga->loc.gc.gtid), ga->loc.gc.slot);
+ W_ pga = PackGA(taskIDtoPE(ga->loc.gc.gtid), ga->loc.gc.slot);
GALA *gala = (GALA *) lookupHashTable(pGAtoGALAtable, pga);
#ifdef DEBUG_WEIGHT
insertHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala);
}
}
+\end{code}
+
+\begin{code}
+W_
+PackGA (pe, slot)
+ W_ pe;
+ int slot;
+{
+ int pe_shift = (BITS_IN(W_)*3)/4;
+ int pe_bits = BITS_IN(W_) - pe_shift;
+
+ if ( pe_bits < 8 || slot >= (1L << pe_shift) ) { /* big trouble */
+ fflush(stdout);
+ fprintf(stderr, "PackGA: slot# too big (%d) or not enough pe_bits (%d)\n",slot,pe_bits);
+ EXIT(EXIT_FAILURE);
+ }
+
+ return((((W_)(pe)) << pe_shift) | ((W_)(slot)));
+
+ /* the idea is to use 3/4 of the bits (e.g., 24) for indirection-
+ table "slot", and 1/4 for the pe# (e.g., 8).
+
+ We check for too many bits in "slot", and double-check (at
+ compile-time?) that we have enough bits for "pe". We *don't*
+ check for too many bits in "pe", because SysMan enforces a
+ MAX_PEs limit at the very very beginning.
+
+ Phil & Will 95/08
+ */
+}
#endif /* PAR -- whole file */
\end{code}
sends it.
\begin{code}
+static W_ *gumPackBuffer;
+
+void
+InitMoreBuffers(STG_NO_ARGS)
+{
+ gumPackBuffer
+ = (W_ *) stgMallocWords(RTSflags.ParFlags.packBufferSize, "initMoreBuffers");
+}
+
void
sendFetch(rga, lga, load)
globalAddr *rga, *lga;
\begin{code}
static void
-unpackFetch(lga, rga, load)
-globalAddr *lga, *rga;
-int *load;
+unpackFetch(globalAddr *lga, globalAddr *rga, int *load)
{
long buf[6];
\begin{code}
static void
-blockFetch(bf, bh)
-P_ bf;
-P_ bh;
+blockFetch(P_ bf, P_ bh)
{
switch (INFO_TYPE(INFO_PTR(bh))) {
case INFO_BH_TYPE:
#ifdef GC_MUT_REQUIRED
/*
- * If we modify a black hole in the old generation, we have to make sure it
- * goes on the mutables list
+ * If we modify a black hole in the old generation, we have to
+ * make sure it goes on the mutables list
*/
if (bh <= StorageMgrInfo.OldLim) {
next = BF_LINK(bf);
/*
- * Find the target at the end of the indirection chain, and process it in
- * much the same fashion as the original target of the fetch. Though we
- * hope to find graph here, we could find a black hole (of any flavor) or
- * even a FetchMe.
+ * Find the target at the end of the indirection chain, and
+ * process it in much the same fashion as the original target
+ * of the fetch. Though we hope to find graph here, we could
+ * find a black hole (of any flavor) or even a FetchMe.
*/
closure = BF_NODE(bf);
while (IS_INDIRECTION(INFO_PTR(closure)))
\begin{code}
static void
-unpackResume(lga, nelem, data)
-globalAddr *lga;
-int *nelem;
-StgWord *data;
+unpackResume(globalAddr *lga, int *nelem, W_ *data)
{
long buf[3];
int ngas;
globalAddr *gagamap;
{
- long buffer[PACK_BUFFER_SIZE - PACK_HDR_SIZE];
+ static long *buffer;
long *p;
int i;
-
CostCentre Save_CCC = CCC;
+ buffer = (long *) gumPackBuffer;
+
CCC = (CostCentre)STATIC_CC_REF(CC_MSG);
CCC->scc_count++;
\begin{code}
static void
-unpackAck(ngas, gagamap)
-int *ngas;
-globalAddr *gagamap;
+unpackAck(int *ngas, globalAddr *gagamap)
{
long GAarraysize;
long buf[6];
\begin{code}
static void
-unpackFish(origPE, age, history, hunger)
-GLOBAL_TASK_ID *origPE;
-int *age, *history, *hunger;
+unpackFish(GLOBAL_TASK_ID *origPE, int *age, int *history, int *hunger)
{
long buf[4];
\begin{code}
static void
-unpackFree(nelem, data)
-int *nelem;
-W_ *data;
+unpackFree(int *nelem, W_ *data)
{
long buf[1];
\begin{code}
static void
-unpackSchedule(nelem, data)
-int *nelem;
-W_ *data;
+unpackSchedule(int *nelem, W_ *data)
{
long buf[1];
unpackFish(&origPE, &age, &history, &hunger);
- /* Ignore our own fish if we're busy; otherwise send it out after a delay */
if (origPE == mytid) {
fishing = rtsFalse;
} else {
processFree(STG_NO_ARGS)
{
int nelem;
- W_ freeBuffer[PACK_BUFFER_SIZE];
+ static W_ *freeBuffer;
int i;
globalAddr ga;
+ freeBuffer = gumPackBuffer;
unpackFree(&nelem, freeBuffer);
#ifdef FREE_DEBUG
fprintf(stderr, "Rcvd Free (%d GAs)\n", nelem / 2);
\begin{code}
static void
-processResume(sender)
-GLOBAL_TASK_ID sender;
+processResume(GLOBAL_TASK_ID sender)
{
int nelem;
- W_ packBuffer[PACK_BUFFER_SIZE], nGAs;
+ W_ nGAs;
+ static W_ *packBuffer;
P_ newGraph;
P_ old;
globalAddr lga;
globalAddr *gagamap;
+ packBuffer = gumPackBuffer;
unpackResume(&lga, &nelem, packBuffer);
#ifdef RESUME_DEBUG
/*
* We always unpack the incoming graph, even if we've received the
- * requested node in some other data packet (and already awakened the
- * blocking queue).
+ * requested node in some other data packet (and already awakened
+ * the blocking queue).
*/
if (SAVE_Hp + packBuffer[0] >= SAVE_HpLim) {
ReallyPerformThreadGC(packBuffer[0], rtsFalse);
old = GALAlookup(&lga);
- if (do_gr_profile) {
+ if (RTSflags.ParFlags.granSimStats) {
P_ tso = NULL;
if (INFO_TYPE(INFO_PTR(old)) == INFO_FMBQ_TYPE) {
ASSERT(newGraph != NULL);
/*
- * Sometimes, unpacking will common up the resumee with the incoming graph,
- * but if it hasn't, we'd better do so now.
+ * Sometimes, unpacking will common up the resumee with the
+ * incoming graph, but if it hasn't, we'd better do so now.
*/
if (INFO_TYPE(INFO_PTR(old)) == INFO_FMBQ_TYPE)
\begin{code}
static void
-processSchedule(sender)
-GLOBAL_TASK_ID sender;
+processSchedule(GLOBAL_TASK_ID sender)
{
int nelem;
int space_required;
rtsBool success;
- W_ packBuffer[PACK_BUFFER_SIZE], nGAs;
+ static W_ *packBuffer;
+ W_ nGAs;
P_ newGraph;
globalAddr *gagamap;
+ packBuffer = gumPackBuffer; /* HWL */
unpackSchedule(&nelem, packBuffer);
#ifdef SCHEDULE_DEBUG
#endif
/*
- * For now, the graph is a closure to be sparked as an advisory spark, but in
- * future it may be a complete spark with required/advisory status, priority
- * etc.
+ * For now, the graph is a closure to be sparked as an advisory
+ * spark, but in future it may be a complete spark with
+ * required/advisory status, priority etc.
*/
space_required = packBuffer[0];
#endif
/*
- * For each (oldGA, newGA) pair, set the GA of the corresponding thunk to the
- * newGA, convert the thunk to a FetchMe, and return the weight from the oldGA.
+ * For each (oldGA, newGA) pair, set the GA of the corresponding
+ * thunk to the newGA, convert the thunk to a FetchMe, and return
+ * the weight from the oldGA.
*/
for (gaga = gagamap; gaga < gagamap + nGAs * 2; gaga += 2) {
P_ old = GALAlookup(gaga);
convertToFetchMe(old, ga);
} else {
/*
- * Oops...we've got this one already; update the RBH to point to
- * the object we already know about, whatever it happens to be.
+ * Oops...we've got this one already; update the RBH to
+ * point to the object we already know about, whatever it
+ * happens to be.
*/
CommonUp(old, new);
/*
- * Increase the weight of the object by the amount just received
- * in the second part of the ACK pair.
+ * Increase the weight of the object by the amount just
+ * received in the second part of the ACK pair.
*/
(void) addWeight(gaga + 1);
}
CCC = (CostCentre)STATIC_CC_REF(CC_MSG);
do {
- if (cc_profiling) {
+ if (RTSflags.CcFlags.doCostCentres) {
CCC = (CostCentre)STATIC_CC_REF(CC_IDLE);
CCC->scc_count++;
}
break;
- /* Anything we're not prepared to deal with. Note that ALL opcodes are discarded
- during termination -- this helps prevent bizarre race conditions.
- */
+ /* Anything we're not prepared to deal with. Note that ALL
+ * opcodes are discarded during termination -- this helps
+ * prevent bizarre race conditions.
+ */
default:
if (!GlobalStopPending)
{
/* Allocate the freeMsg buffers just once and then hang onto them. */
if (freeMsgIndex == NULL) {
- freeMsgIndex = (int *) malloc(nPEs * sizeof(int));
- freeMsgBuffer = (PP_) malloc(nPEs * sizeof(long *));
- if (freeMsgIndex == NULL || freeMsgBuffer == NULL) {
- fflush(stdout);
- fprintf(stderr, "VM exhausted\n");
- EXIT(EXIT_FAILURE);
- }
+
+ freeMsgIndex = (int *) stgMallocBytes(nPEs * sizeof(int), "prepareFreeMsgBuffers (Index)");
+ freeMsgBuffer = (PP_) stgMallocBytes(nPEs * sizeof(long *), "prepareFreeMsgBuffers (Buffer)");
+
for(i = 0; i < nPEs; i++) {
- if(i != thisPE &&
- (freeMsgBuffer[i] = (P_) malloc(PACK_BUFFER_SIZE * sizeof(W_))) == NULL) {
- fflush(stdout);
- fprintf(stderr, "VM exhausted\n");
- EXIT(EXIT_FAILURE);
+ if (i != thisPE) {
+ freeMsgBuffer[i] = (P_) stgMallocWords(RTSflags.ParFlags.packBufferSize,
+ "prepareFreeMsgBuffers (Buffer #i)");
}
}
}
ASSERT(GALAlookup(ga) == NULL);
- if ((i = freeMsgIndex[pe]) + 2 >= PACK_BUFFER_SIZE) {
+ if ((i = freeMsgIndex[pe]) + 2 >= RTSflags.ParFlags.packBufferSize) {
#ifdef FREE_DEBUG
fprintf(stderr, "Filled a free message buffer\n");
#endif
\begin{code}
static int
-hash(table, key)
-HashTable *table;
-StgWord key;
+hash(HashTable *table, W_ key)
{
int bucket;
\begin{code}
static void
-allocSegment(table, segment)
-HashTable *table;
-int segment;
+allocSegment(HashTable *table, int segment)
{
- if ((table->dir[segment] = (HashList **) malloc(HSEGSIZE * sizeof(HashList *))) == NULL) {
- fflush(stdout);
- fprintf(stderr, "VM exhausted\n");
- EXIT(EXIT_FAILURE);
- }
+ table->dir[segment] = (HashList **) stgMallocBytes(HSEGSIZE * sizeof(HashList *), "allocSegment");
}
\end{code}
\begin{code}
static void
-expand(table)
-HashTable *table;
+expand(HashTable *table)
{
int oldsegment;
int oldindex;
if ((hl = freeList) != NULL) {
freeList = hl->next;
- } else if ((hl = (HashList *) malloc(HCHUNK * sizeof(HashList))) != NULL) {
+ } else {
+ hl = (HashList *) stgMallocBytes(HCHUNK * sizeof(HashList), "allocHashList");
+
freeList = hl + 1;
for (p = freeList; p < hl + HCHUNK - 1; p++)
p->next = p + 1;
p->next = NULL;
- } else {
- fflush(stdout);
- fprintf(stderr, "VM exhausted\n");
- EXIT(EXIT_FAILURE);
}
return hl;
}
static void
-freeHashList(hl)
-HashList *hl;
+freeHashList(HashList *hl)
{
hl->next = freeList;
freeList = hl;
HashTable *table;
HashList **hb;
- if ((table = (HashTable *) malloc(sizeof(HashTable))) == NULL) {
- fflush(stdout);
- fprintf(stderr, "VM exhausted\n");
- EXIT(EXIT_FAILURE);
- }
+ table = (HashTable *) stgMallocBytes(sizeof(HashTable),"allocHashTable");
+
allocSegment(table, 0);
+
for (hb = table->dir[0]; hb < table->dir[0] + HSEGSIZE; hb++)
*hb = NULL;
+
table->split = 0;
table->max = HSEGSIZE;
table->mask1 = HSEGSIZE - 1;
return ("Unknown PE Opcode");
}
-void NullException(STG_NO_ARGS)
+void
+NullException(STG_NO_ARGS)
{
fprintf(stderr,"Null_Exception: called");
}
-void (*ExceptionHandler)() = NullException;
-
+void (*ExceptionHandler)() = NullException;
\end{code}
@trace_SendOp@ handles the tracing of messages at the OS level. If
rtsBool PETrace = rtsFalse, IMUTrace = rtsFalse, SystemTrace = rtsFalse, ReplyTrace = rtsFalse;
static void
-trace_SendOp(op, dest, data1, data2)
-OPCODE op;
-GLOBAL_TASK_ID dest;
-unsigned data1, data2;
+trace_SendOp(OPCODE op, GLOBAL_TASK_ID dest, unsigned int data1, unsigned int data2)
{
char *OpName;
\end{verbatim}
\begin{code}
-
-#ifdef __STDC__
void
SendOpV(OPCODE op, GLOBAL_TASK_ID task, int n, ...)
-#else
-void
-SendOpV(op, task, n, va_alist)
-OPCODE op;
-GLOBAL_TASK_ID task;
-int n;
-va_dcl
-#endif
{
va_list ap;
int i;
StgWord arg;
-#ifdef __STDC__
va_start(ap, n);
-#else
- va_start(ap);
-#endif
trace_SendOp(op, task, 0, 0);
\begin{code}
-#ifdef __STDC__
void
SendOpNV(OPCODE op, GLOBAL_TASK_ID task, int nelem, StgWord *datablock, int narg, ...)
-#else
-void
-SendOpNV(op, task, nelem, datablock, narg, va_alist)
-OPCODE op;
-GLOBAL_TASK_ID task;
-int nelem;
-StgWord *datablock;
-int narg;
-va_dcl
-#endif
{
va_list ap;
int i;
StgWord arg;
-#ifdef __STDC__
va_start(ap, narg);
-#else
- va_start(ap);
-#endif
trace_SendOp(op, task, 0, 0);
/* fprintf(stderr,"SendOpNV: op = %x, task = %x, narg = %d, nelem = %d\n",op,task,narg,nelem); */
array of Global Task Ids.
\begin{code}
-
-static char *
-xmalloc(n)
-unsigned n;
-{
- char *p = malloc(n);
-
- if (p == NULL) {
- fprintf(stderr, "Memory allocation of %u bytes failed\n", n);
- EXIT(EXIT_FAILURE);
- }
- return p;
-}
-
GLOBAL_TASK_ID *
PEStartUp(nPEs)
unsigned nPEs;
{
int i;
PACKET addr;
- long *buffer = (long *) xmalloc(sizeof(long) * nPEs);
- GLOBAL_TASK_ID *PEs = (GLOBAL_TASK_ID *) xmalloc(sizeof(GLOBAL_TASK_ID) * nPEs);
+ long *buffer = (long *) stgMallocBytes(sizeof(long) * nPEs, "PEStartUp (buffer)");
+ GLOBAL_TASK_ID *PEs
+ = (GLOBAL_TASK_ID *) stgMallocBytes(sizeof(GLOBAL_TASK_ID) * nPEs, "PEStartUp (PEs)");
mytid = _my_gtid; /* Initialise PVM and get task id into global
* variable */
Static data and code declarations.
\begin{code}
-static W_ PackBuffer[PACK_BUFFER_SIZE+PACK_HDR_SIZE];
+static W_ *PackBuffer = NULL; /* size: can be set via option */
+
static W_ packlocn, clqsize, clqpos;
static W_ unpackedsize;
static W_ reservedPAsize; /*Space reserved for primitive arrays*/
{
/* Ensure enough heap for all possible RBH_Save closures */
+ ASSERT(RTSflags.ParFlags.packBufferSize > 0);
+
if (SAVE_Hp + PACK_HEAP_REQUIRED > SAVE_HpLim)
return NULL;
PackBuffer[0] = unpackedsize;
/* Set the size parameter */
- ASSERT(packlocn <= PACK_BUFFER_SIZE);
+ ASSERT(packlocn <= RTSflags.ParFlags.packBufferSize);
*packbuffersize = packlocn;
DonePacking();
W_ size, ptrs, nonptrs, vhs;
int i, clpacklocn;
- while ((P_) INFO_PTR(closure) == Ind_info) { /* Don't pack indirection
- * closures */
+ while (IS_INDIRECTION(INFO_PTR(closure))) {
+ /* Don't pack indirection closures */
#ifdef PACK_DEBUG
fprintf(stderr, "Shorted an indirection at %x", closure);
#endif
P_ info;
/*
- * PLCs reside on all of the PEs already. Just pack the address as a GA (a
- * bit of a kludge, since an address may not fit in *any* of the individual
- * GA fields). Const, charlike and small intlike closures are converted into
+ * PLCs reside on all of the PEs already. Just pack the
+ * address as a GA (a bit of a kludge, since an address may
+ * not fit in *any* of the individual GA fields). Const,
+ * charlike and small intlike closures are converted into
* PLCs.
*/
switch (INFO_TYPE(INFO_PTR(closure))) {
\begin{code}
static void
Pack(data)
-W_ data;
+ W_ data;
{
- ASSERT(packlocn < PACK_BUFFER_SIZE);
- PackBuffer[packlocn++] = data;
+ ASSERT(packlocn < RTSflags.ParFlags.packBufferSize);
+ PackBuffer[packlocn++] = data;
}
\end{code}
@InitPacking@ initialises the packing buffer etc.
\begin{code}
+void
+InitPackBuffer(STG_NO_ARGS)
+{
+ if (PackBuffer == NULL) { /* not yet allocated */
+
+ PackBuffer = (W_ *) stgMallocWords(RTSflags.ParFlags.packBufferSize+PACK_HDR_SIZE,
+ "InitPackBuffer");
+
+ InitPendingGABuffer(RTSflags.ParFlags.packBufferSize);
+ AllocClosureQueue(RTSflags.ParFlags.packBufferSize);
+ }
+}
+
static void
InitPacking(STG_NO_ARGS)
{
+ /* InitPackBuffer(); now done in ParInit HWL_ */
+
packlocn = PACK_HDR_SIZE;
unpackedsize = 0;
reservedPAsize = 0;
\begin{code}
static int
-OffsetFor(closure)
-P_ closure;
+OffsetFor(P_ closure)
{
return (int) (W_) lookupHashTable(offsettable, (W_) closure);
}
{
if (RoomInBuffer &&
(packlocn + reservedPAsize + size +
- ((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= PACK_BUFFER_SIZE)) {
+ ((clqsize - clqpos) + ptrs) * PACK_FETCHME_SIZE >= RTSflags.ParFlags.packBufferSize)) {
#ifdef PACK_DEBUG
fprintf(stderr, "Buffer full\n");
#endif
\begin{code}
static W_ clqpos, clqsize;
-static P_ ClosureQueue[PACK_BUFFER_SIZE];
+
+static P_ *ClosureQueue = NULL; /* HWL: init in main */
\end{code}
@InitClosureQueue@ initialises the closure queue.
\begin{code}
void
+AllocClosureQueue(size)
+ W_ size;
+{
+ ASSERT(ClosureQueue == NULL);
+ ClosureQueue = (P_ *) stgMallocWords(size, "AllocClosureQueue");
+}
+
+void
InitClosureQueue(STG_NO_ARGS)
{
clqpos = clqsize = 0;
+
+ if ( ClosureQueue == NULL ) {
+ AllocClosureQueue(RTSflags.ParFlags.packBufferSize);
+ }
}
\end{code}
QueueClosure(closure)
P_ closure;
{
- if(clqsize < PACK_BUFFER_SIZE)
+ if(clqsize < RTSflags.ParFlags.packBufferSize)
ClosureQueue[clqsize++] = closure;
else
{
\begin{code}
rtsBool TraceSparks = rtsFalse; /* Enable the spark trace mode */
-rtsBool OutputDisabled = rtsFalse; /* Disable output for performance purposes */
rtsBool SparkLocally = rtsFalse; /* Use local threads if possible */
rtsBool DelaySparks = rtsFalse; /* Use delayed sparking */
rtsBool LocalSparkStrategy = rtsFalse; /* Either delayed threads or local threads */
rtsBool GlobalSparkStrategy = rtsFalse; /* Export all threads */
-rtsBool ParallelStats = rtsFalse; /* Gather parallel statistics */
rtsBool DeferGlobalUpdates = rtsFalse; /* Defer updating of global nodes */
rtsBool fishing = rtsFalse; /* We have no fish out in the stream */
\end{code}
return;
/* Show that we've started */
- if (IAmMainThread && !OutputDisabled)
+ if (IAmMainThread && ! RTSflags.ParFlags.outputDisabled)
fprintf(stderr, "Starting main program...\n");
-
/* Record the start time for statistics purposes. */
main_start_time = usertime();
/* fprintf(stderr, "Start time is %u\n", main_start_time); */
else
WaitForPEOp(PP_FINISH, SysManTask);
PEShutDown();
- fprintf(stderr,"Processor %lx shutting down, %ld Threads run\n", mytid, threadId);
+ fprintf(stderr,"PE %lx shutting down, %ld Threads run, %ld Sparks Ignored\n", (W_) mytid, threadId, sparksIgnored);
/* And actually terminate -- always with code 0 */
longjmp(exit_parallel_system, 1);
void
initParallelSystem(STG_NO_ARGS)
{
-
- /* Don't buffer standard channels... */
- setbuf(stdout,NULL);
- setbuf(stderr,NULL);
-
- srand48(time(NULL) * getpid()); /*Initialise Random-number generator seed*/
-
- OkToGC = rtsFalse; /* Must not GC till we have set up the environment */
- /* because C is hanging onto heap pointers */
- /* maybe bogus for the new RTS? -- KH */
- /* And for the GUM system? PWT */
+ /* Don't buffer standard channels... */
+ setbuf(stdout,NULL);
+ setbuf(stderr,NULL);
+
+ srand48(time(NULL) * getpid()); /*Initialise Random-number generator seed*/
+
+ OkToGC = rtsFalse; /* Must not GC till we have set up the environment */
+ /* because C is hanging onto heap pointers */
+ /* maybe bogus for the new RTS? -- KH */
+ /* And for the GUM system? PWT */
+ InitPackBuffer();
+ InitMoreBuffers();
}
\end{code}
#include "rtsdefs.h"
\end{code}
-Turn a closure into a revertable black hole. After the conversion,
+Turn a closure into a revertible black hole. After the conversion,
the first two words of the closure will be a link to the mutables
list (if appropriate for the garbage collector), and a pointer
to the blocking queue. The blocking queue is terminated by a 2-word
\end{code}
\begin{code}
-main(argc, argv)
-int argc;
-char **argv;
+main(int argc, char **argv)
{
int rbufid;
int opcode, nbytes;
#endif
}
- /* Join the PE sysman groups in order to allow barrier synchronisation */
+ /*
+ SysMan joins PECTLGROUP, so that it can wait (at the
+ barrier sysnchronisation a few instructions later) for the
+ other PE-tasks to start.
+
+ Other comments on PVM groupery:
+
+ The manager group (MGRGROUP) is vestigial at the moment. It
+ may eventually include a statistics manager, garbage
+ collector manager.
+
+ I suspect that you're [Kei Davis] right: Sysman shouldn't
+ be in PEGROUP, it's a hangover from GRIP.
+
+ (Phil Trinder, 95/10)
+ */
checkerr(pvm_joingroup(PECTLGROUP));
#if 0
fprintf(stderr, "Joined PECTLGROUP /* PWT */\n");
}
}
}
+ return(0);
}
\end{code}
Local Definitions.
\begin{code}
-static globalAddr PendingGABuffer[(PACK_BUFFER_SIZE-PACK_HDR_SIZE)*2];
+static globalAddr *PendingGABuffer; /* HWL; init in main; */
+
+void
+InitPendingGABuffer(size)
+W_ size;
+{
+ PendingGABuffer
+ = (globalAddr *) stgMallocBytes((size-PACK_HDR_SIZE)*2*sizeof(globalAddr), "InitPendingGABuffer");
+}
\end{code}
@CommonUp@ commons up two closures which we have discovered to be
\begin{code}
void
-CommonUp(src, dst)
-P_ src;
-P_ dst;
+CommonUp(P_ src, P_ dst)
{
P_ bqe;
W_ pptr = 0, pptrs = 0, pvhs;
int i;
+ globalAddr *gaga;
+
+ InitPackBuffer(); /* in case it isn't already init'd */
- globalAddr *gaga = PendingGABuffer;
+ gaga = PendingGABuffer;
InitClosureQueue();
graph[FIXED_HS + i + vhs + ptrs] = *bufptr++;
/* Indirections are never packed */
- ASSERT(INFO_PTR(graph) != (W_) Ind_info);
+ ASSERT(INFO_PTR(graph) != (W_) Ind_info_TO_USE);
/* Add to queue for processing */
QueueClosure(graph);
#include "rtsdefs.h"
void
-OutOfHeapHook (request_size, heap_size)
+OutOfHeapHook (request_size)
W_ request_size; /* in bytes */
- W_ heap_size; /* in bytes */
{
+ W_ heap_size = RTSflags.GcFlags.heapSize * sizeof(W_); /* i.e., in bytes */
+
fprintf(stderr, "Heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse `+RTS -H<size>' to increase the total heap size.\n",
request_size,
heap_size);
#include "rtsdefs.h"
void
-MallocFailHook (request_size)
+MallocFailHook (request_size, msg)
I_ request_size; /* in bytes */
+ char *msg;
{
- fprintf(stderr, "malloc: failed on request for %lu bytes\n", request_size);
+ fprintf(stderr, "malloc: failed on request for %lu bytes; message: %s\n", request_size, msg);
}
\end{code}
\begin{code}
#include "rtsdefs.h"
-#include "storage/SMinternal.h" /* DEFAULT_* here */
-I_ SM_word_heap_size = DEFAULT_HEAP_SIZE;
-StgFloat SM_pc_free_heap = DEFAULT_PC_FREE;
-I_ SM_word_stk_size = DEFAULT_STACKS_SIZE;
+void
+defaultsHook (void)
+{ /* this is called *after* RTSflags has had
+ its defaults set, but *before* we start
+ processing the RTS command-line options.
+
+ This default version does *nothing*.
+ The user may provide a more interesting
+ one.
+ */
+}
\end{code}
int dirtyEnv = 0;
/*
- * For some reason, OSF turns off the prototype for this if we're _POSIX_SOURCE.
- * Seems to me that this ought to be an ANSI-ism rather than a POSIX-ism,
- * but no matter.
+ * For some reason, OSF turns off the prototype for this if we're
+ * _POSIX_SOURCE. Seems to me that this ought to be an ANSI-ism
+ * rather than a POSIX-ism, but no matter. (JSM(?))
*/
char *
-strdup(const char *src)
+strdup(char *src) /* should be "const char *" but then some
+ bozo OS (e.g., AIX) will come along and disagree.
+ The alt is to rename this routine (WDP 96/01) */
{
int len = strlen(src) + 1;
char *dst;
* seconds to overflow 31 bits.
*/
-StgAddr
-getCPUTime(STG_NO_ARGS)
+StgByteArray
+getCPUTime(cpuStruct)
+StgByteArray cpuStruct;
{
- static StgInt cpu[4];
+ StgInt *cpu=(StgInt *)cpuStruct;
#if defined(HAVE_GETRUSAGE) && ! irix_TARGET_OS
struct rusage t;
return NULL;
# endif
#endif
- return (StgAddr) cpu;
+ return (StgByteArray) cpuStruct;
}
\end{code}
/* For cleanup of partial answer on error */
static void
-freeEntries(entries, count)
- char **entries;
- int count;
+freeEntries(char **entries, int count)
{
int i;
\begin{code}
#include "rtsdefs.h"
+
+#include "ghcReadline.h" /* to make sure the code here agrees...*/
\end{code}
Wrapper around the callback mechanism to allow Haskell side functions
in the global variable $rl_return$.
\begin{code}
-
-int current_narg, rl_return, current_kc;
+I_ current_narg, rl_return, current_kc;
char* rl_prompt_hack;
StgStablePtr cbackList;
-int genericRlCback (int narg,int kc)
+I_
+genericRlCback (I_ narg, I_ kc)
{
current_narg = narg;
current_kc = kc;
#endif
StgAddr
-showTime(size, d)
+showTime(size, d, buf)
StgInt size;
StgByteArray d;
+StgByteArray buf;
{
time_t t;
struct tm *tm;
- static char buf[32];
switch(size) {
default:
- return (StgAddr) "ClockTime.show{LibTime}: out of range";
+ return (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: out of range");
case 0:
t = 0;
break;
case -1:
t = - (time_t) ((StgInt *)d)[0];
if (t > 0)
- return (StgAddr) "ClockTime.show{LibTime}: out of range";
+ return
+ (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: out of range");
break;
case 1:
t = (time_t) ((StgInt *)d)[0];
if (t < 0)
- return (StgAddr) "ClockTime.show{LibTime}: out of range";
+ return (StgAddr) strcpy(buf, "ClockTime.show{LibTime}: out of range");
break;
}
tm = localtime(&t);
- if (tm != NULL && strftime(buf, sizeof(buf), "%a %b %d %T %Z %Y", tm) > 0)
- return (StgAddr) buf;
- return (StgAddr) "ClockTime.show{LibTime}: internal error";
+ if (tm != NULL && strftime(buf, 32 /*Magic number*/, "%a %b %d %T %Z %Y", tm) > 0)
+ return (StgAddr)buf;
+ return (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: internal error");
}
\end{code}
#include "timezone.h"
StgAddr
-toClockSec(year, mon, mday, hour, min, sec, tz)
+toClockSec(year, mon, mday, hour, min, sec, tz, res)
StgInt year;
StgInt mon;
StgInt mday;
StgInt min;
StgInt sec;
StgInt tz;
+StgByteArray res;
{
struct tm tm;
- static time_t t;
+ time_t t;
tm.tm_year = year - 1900;
tm.tm_mon = mon;
#endif
if (t == (time_t) -1)
return NULL;
- else
- return &t;
+
+ *(time_t *)res = t;
+ return res;
}
\end{code}
#include "stgio.h"
#include "timezone.h"
-StgAddr
-toLocalTime(size, d)
+StgAddr
+toLocalTime(size, d, res)
StgInt size;
StgByteArray d;
+StgByteArray res;
{
+ struct tm *tm,*tmp=(struct tm *)res;
time_t t;
- struct tm *tm;
- static struct tm cache_tm;
switch(size) {
default:
if (tm == NULL)
return NULL;
- cache_tm = *tm;
- return &cache_tm;
+ /*
+ localtime() may return a ptr to statically allocated storage,
+ so to make toLocalTime reentrant, we manually copy
+ the structure into the (struct tm *) passed in.
+ */
+ tmp->tm_sec = tm->tm_sec;
+ tmp->tm_min = tm->tm_min;
+ tmp->tm_hour = tm->tm_hour;
+ tmp->tm_mday = tm->tm_mday;
+ tmp->tm_mon = tm->tm_mon;
+ tmp->tm_year = tm->tm_year;
+ tmp->tm_wday = tm->tm_wday;
+ tmp->tm_yday = tm->tm_yday;
+ tmp->tm_isdst = tm->tm_isdst;
+ /*
+ If you don't have tm_zone in (struct tm), but
+ you get at it via the shared tmzone[], you'll
+ lose. Same goes for the tm_gmtoff field.
+
+ */
+#if HAVE_TM_ZONE
+ strcpy(tmp->tm_zone,tm->tm_zone);
+ tmp->tm_gmtoff = tm->tm_gmtoff;
+#endif
+
+ return (StgAddr)res;
}
\end{code}
#include "timezone.h"
StgAddr
-toUTCTime(size, d)
+toUTCTime(size, d, res)
StgInt size;
StgByteArray d;
+StgByteArray res;
{
time_t t;
- struct tm *tm;
- static struct tm cache_tm;
+ struct tm *tm,*tmp=(struct tm *)res;
switch(size) {
default:
if (tm == NULL)
return NULL;
- cache_tm = *tm;
- return &cache_tm;
+ /*
+ gmtime() may return a ptr to statically allocated storage,
+ so to make toUTCTime reentrant, we manually copy
+ the structure into the (struct tm *) passed in.
+ */
+ tmp->tm_sec = tm->tm_sec;
+ tmp->tm_min = tm->tm_min;
+ tmp->tm_hour = tm->tm_hour;
+ tmp->tm_mday = tm->tm_mday;
+ tmp->tm_mon = tm->tm_mon;
+ tmp->tm_year = tm->tm_year;
+ tmp->tm_wday = tm->tm_wday;
+ tmp->tm_yday = tm->tm_yday;
+ tmp->tm_isdst = tm->tm_isdst;
+ /*
+ If you don't have tm_zone in (struct tm), but
+ you get at it via the shared tmzone[], you'll
+ lose. Same goes for the tm_gmtoff field.
+
+ */
+#if HAVE_TM_ZONE
+ strcpy(tmp->tm_zone,tm->tm_zone);
+ tmp->tm_gmtoff = tm->tm_gmtoff;
+#endif
+
+ return (StgAddr)res;
}
\end{code}
P_ tso, node;
sparkq spark;
{
- eventq newentry = (eventq) xmalloc(sizeof(struct event));
+ eventq newentry = (eventq) stgMallocBytes(sizeof(struct event), "newevent");
EVENT_PROC(newentry) = proc;
EVENT_CREATOR(newentry) = creator;
void
DumpGranEventAndNode(name, tso, node, proc)
-enum gran_event_types name;
-P_ tso, node;
-PROC proc;
+ enum gran_event_types name;
+ P_ tso, node;
+ PROC proc;
{
PROC pe = CURRENT_PROC;
W_ id;
if (name > GR_EVENT_MAX)
name = GR_EVENT_MAX;
- if (do_gr_binary) {
+ if (RTSflags.ParFlags.granSimStats_Binary) {
grputw(name);
grputw(pe);
abort(); /* die please: a single word doesn't represent long long times */
ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/);
- if (do_gr_binary) {
+ if (RTSflags.ParFlags.granSimStats_Binary) {
grputw(name);
grputw(pe);
abort(); /* die please: a single word doesn't represent long long times */
char time_string[500]; /* ToDo: kill magic constant */
ullong_format_string(CURRENT_TIME, time_string, rtsFalse/*no commas!*/);
- if (do_gr_binary) {
+ if (RTSflags.ParFlags.granSimStats_Binary) {
grputw(GR_END);
grputw(pe);
abort(); /* die please: a single word doesn't represent long long times */
I_ i;
if (do_gr_sim) {
- char *extension = do_gr_binary ? "gb" : "gr";
+ char *extension = RTSflags.ParFlags.granSimStats_Binary ? "gb" : "gr";
sprintf(gr_filename, GR_FILENAME_FMT, prog_argv[0], extension);
gran_load_cost, gran_store_cost, gran_float_cost, gran_heapalloc_cost);
fputs("\n\n++++++++++++++++++++\n\n", gr_file);
}
- if (do_gr_binary)
+ if (RTSflags.ParFlags.granSimStats_Binary)
grputw(sizeof(TIME));
Idlers = max_proc;
#ifdef PAR
char gr_filename[STATS_FILENAME_MAXLEN];
-I_ do_gr_profile = 0;
I_ do_sp_profile = 0;
-I_ do_gr_binary = 0;
void
init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv)
-char *prog_argv[], *rts_argv[];
-int prog_argc, rts_argc;
+ char *prog_argv[], *rts_argv[];
+ int prog_argc, rts_argc;
{
int i;
- char *extension = do_gr_binary ? "gb" : "gr";
+ char *extension = RTSflags.ParFlags.granSimStats_Binary ? "gb" : "gr";
sprintf(gr_filename, GR_FILENAME_FMT_GUM, prog_argv[0], thisPE, extension);
fprintf(gr_file, "PE %2u [%lu]: TIME\n", thisPE, (TIME) startTime);
}
- if (do_gr_binary)
+ if (RTSflags.ParFlags.granSimStats_Binary)
grputw(sizeof(TIME));
}
#endif /* PAR */
\begin{code}
-#if defined(USE_COST_CENTRES) || defined(CONCURRENT)
+#if defined(PROFILING) || defined(CONCURRENT)
# include "platform.h"
}
# endif
-#endif /* USE_COST_CENTRES || CONCURRENT */
+#endif /* PROFILING || CONCURRENT */
\end{code}
--- /dev/null
+%---------------------------------------------------------------*
+%
+\section{Wrappers around malloc}
+%
+%---------------------------------------------------------------*
+
+Routines that deal with memory allocation:
+
+A LONG-AGO WISH: All dynamic allocation must be done before the stacks
+and heap are allocated. This allows us to use the lower level sbrk
+routines if required.
+
+ANOTHER ONE: Should allow use of valloc to align on page boundary.
+
+\begin{code}
+#include "rtsdefs.h"
+
+char *
+stgMallocBytes(n, msg)
+ I_ n;
+ char *msg;
+{
+ char *space;
+
+ if ((space = (char *) malloc((size_t) n)) == NULL) {
+ fflush(stdout);
+ MallocFailHook((W_) n, msg); /*msg*/
+ EXIT(EXIT_FAILURE);
+ }
+ return space;
+}
+
+char *
+stgMallocWords(n, msg)
+ I_ n;
+ char *msg;
+{
+ return(stgMallocBytes(n * sizeof(W_), msg));
+}
+\end{code}
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1992-1993
-%
-%************************************************************************
-%* *
-\section[RednCounts.lc]{Stuff for ``ticky-ticky'' profiling}
-%* *
-%************************************************************************
-
-Goes with \tr{imports/RednCounts.lh}; more documentation there.
-
-%************************************************************************
-%* *
-\subsection[RednCounts-counters]{Declare all the counters}
-%* *
-%************************************************************************
-
-\begin{code}
-#define NULL_REG_MAP /* Not threaded */
-
-#include "../storage/SMinternal.h" /* Bad boy, Will (ToDo) */
-
-#if defined(DO_REDN_COUNTING)
-
-extern FILE *tickyfile;
-
-I_ ALLOC_HEAP_ctr = 0;
-I_ ALLOC_HEAP_tot = 0;
-
-PP_ max_SpA; /* set in re_enterable_part_of_main */
-P_ max_SpB;
-
-/* not used at all
-I_ A_STK_REUSE_ctr = 0;
-I_ B_STK_REUSE_ctr = 0;
-*/
-I_ A_STK_STUB_ctr = 0;
-
-I_ ALLOC_FUN_ctr = 0;
-I_ ALLOC_FUN_adm = 0;
-I_ ALLOC_FUN_gds = 0;
-I_ ALLOC_FUN_slp = 0;
-I_ ALLOC_FUN_hst[5] = {0,0,0,0,0};
-I_ ALLOC_THK_ctr = 0;
-I_ ALLOC_THK_adm = 0;
-I_ ALLOC_THK_gds = 0;
-I_ ALLOC_THK_slp = 0;
-I_ ALLOC_THK_hst[5] = {0,0,0,0,0};
-I_ ALLOC_CON_ctr = 0;
-I_ ALLOC_CON_adm = 0;
-I_ ALLOC_CON_gds = 0;
-I_ ALLOC_CON_slp = 0;
-I_ ALLOC_CON_hst[5] = {0,0,0,0,0};
-I_ ALLOC_TUP_ctr = 0;
-I_ ALLOC_TUP_adm = 0;
-I_ ALLOC_TUP_gds = 0;
-I_ ALLOC_TUP_slp = 0;
-I_ ALLOC_TUP_hst[5] = {0,0,0,0,0};
-I_ ALLOC_BH_ctr = 0;
-I_ ALLOC_BH_adm = 0;
-I_ ALLOC_BH_gds = 0;
-I_ ALLOC_BH_slp = 0;
-I_ ALLOC_BH_hst[5] = {0,0,0,0,0};
-/*
-I_ ALLOC_PAP_ctr = 0;
-I_ ALLOC_PAP_adm = 0;
-I_ ALLOC_PAP_gds = 0;
-I_ ALLOC_PAP_slp = 0;
-I_ ALLOC_PAP_hst[5] = {0,0,0,0,0};
-*/
-I_ ALLOC_PRIM_ctr = 0;
-I_ ALLOC_PRIM_adm = 0;
-I_ ALLOC_PRIM_gds = 0;
-I_ ALLOC_PRIM_slp = 0;
-I_ ALLOC_PRIM_hst[5] = {0,0,0,0,0};
-/*
-I_ ALLOC_UPD_CON_ctr = 0;
-I_ ALLOC_UPD_CON_adm = 0;
-I_ ALLOC_UPD_CON_gds = 0;
-I_ ALLOC_UPD_CON_slp = 0;
-I_ ALLOC_UPD_CON_hst[5] = {0,0,0,0,0};
-*/
-I_ ALLOC_UPD_PAP_ctr = 0;
-I_ ALLOC_UPD_PAP_adm = 0;
-I_ ALLOC_UPD_PAP_gds = 0;
-I_ ALLOC_UPD_PAP_slp = 0;
-I_ ALLOC_UPD_PAP_hst[5] = {0,0,0,0,0};
-
-#ifdef CONCURRENT
-I_ ALLOC_STK_ctr = 0;
-I_ ALLOC_STK_adm = 0;
-I_ ALLOC_STK_gds = 0;
-I_ ALLOC_STK_slp = 0;
-I_ ALLOC_STK_hst[5] = {0,0,0,0,0};
-I_ ALLOC_TSO_ctr = 0;
-I_ ALLOC_TSO_adm = 0;
-I_ ALLOC_TSO_gds = 0;
-I_ ALLOC_TSO_slp = 0;
-I_ ALLOC_TSO_hst[5] = {0,0,0,0,0};
-
-#ifdef PAR
-I_ ALLOC_FMBQ_ctr = 0;
-I_ ALLOC_FMBQ_adm = 0;
-I_ ALLOC_FMBQ_gds = 0;
-I_ ALLOC_FMBQ_slp = 0;
-I_ ALLOC_FMBQ_hst[5] = {0,0,0,0,0};
-I_ ALLOC_FME_ctr = 0;
-I_ ALLOC_FME_adm = 0;
-I_ ALLOC_FME_gds = 0;
-I_ ALLOC_FME_slp = 0;
-I_ ALLOC_FME_hst[5] = {0,0,0,0,0};
-I_ ALLOC_BF_ctr = 0;
-I_ ALLOC_BF_adm = 0;
-I_ ALLOC_BF_gds = 0;
-I_ ALLOC_BF_slp = 0;
-I_ ALLOC_BF_hst[5] = {0,0,0,0,0};
-#endif
-#endif
-
-I_ ENT_VIA_NODE_ctr = 0;
-I_ ENT_CON_ctr = 0;
-I_ ENT_FUN_STD_ctr = 0;
-I_ ENT_FUN_DIRECT_ctr = 0;
-I_ ENT_IND_ctr = 0;
-I_ ENT_PAP_ctr = 0;
-I_ ENT_THK_ctr = 0;
-
-I_ RET_NEW_IN_HEAP_ctr = 0;
-I_ RET_NEW_IN_REGS_ctr = 0;
-I_ RET_OLD_IN_HEAP_ctr = 0;
-I_ RET_OLD_IN_REGS_ctr = 0;
-I_ RET_SEMI_BY_DEFAULT_ctr = 0;
-I_ RET_SEMI_IN_HEAP_ctr = 0;
-I_ RET_SEMI_IN_REGS_ctr = 0;
-I_ VEC_RETURN_ctr = 0;
-
-I_ ReturnInRegsNodeValid = 0; /* i.e., False */
-
-I_ UPDF_OMITTED_ctr = 0;
-I_ UPDF_STD_PUSHED_ctr = 0;
-I_ UPDF_CON_PUSHED_ctr = 0;
-I_ UPDF_HOLE_PUSHED_ctr = 0;
-
-I_ UPDF_RCC_PUSHED_ctr = 0;
-I_ UPDF_RCC_OMITTED_ctr = 0;
-
-I_ UPD_EXISTING_ctr = 0;
-I_ UPD_CON_W_NODE_ctr = 0;
-I_ UPD_CON_IN_PLACE_ctr = 0;
-I_ UPD_CON_IN_NEW_ctr = 0;
-I_ UPD_PAP_IN_PLACE_ctr = 0;
-I_ UPD_PAP_IN_NEW_ctr = 0;
-
-I_ UPD_ENTERED_ctr = 0;
-I_ UPD_ENTERED_AGAIN_ctr = 0;
-
-I_ UPD_NEW_IND_ctr = 0;
-I_ UPD_NEW_IN_PLACE_PTRS_ctr = 0;
-I_ UPD_NEW_IN_PLACE_NOPTRS_ctr = 0;
-I_ UPD_OLD_IND_ctr = 0;
-I_ UPD_OLD_IN_PLACE_PTRS_ctr = 0;
-I_ UPD_OLD_IN_PLACE_NOPTRS_ctr = 0;
-
-I_ UPD_IN_PLACE_COPY_ctr = 0;
-\end{code}
-
-\begin{code}
-#if 0
-/* testing only */
-void
-TICKY_PARANOIA(const char *file, I_ line)
-{
- I_ tot_adm_wds = /* total number of admin words allocated */
- ALLOC_FUN_adm + ALLOC_THK_adm + ALLOC_CON_adm + ALLOC_TUP_adm +
- ALLOC_BH_adm /*+ ALLOC_PAP_adm*/ /*+ ALLOC_UPD_CON_adm*/ + ALLOC_UPD_PAP_adm +
- ALLOC_PRIM_adm;
- I_ tot_gds_wds = /* total number of words of ``good stuff'' allocated */
- ALLOC_FUN_gds + ALLOC_THK_gds + ALLOC_CON_gds + ALLOC_TUP_gds +
- ALLOC_BH_gds /*+ ALLOC_PAP_gds*/ /*+ ALLOC_UPD_CON_gds*/ + ALLOC_UPD_PAP_gds +
- ALLOC_PRIM_gds;
- I_ tot_slp_wds = /* total number of ``slop'' words allocated */
- ALLOC_FUN_slp + ALLOC_THK_slp + ALLOC_CON_slp + ALLOC_TUP_slp +
- ALLOC_BH_slp /*+ ALLOC_PAP_slp*/ /*+ ALLOC_UPD_CON_slp*/ + ALLOC_UPD_PAP_slp +
- ALLOC_PRIM_slp;
- I_ tot_wds = /* total words */
- tot_adm_wds + tot_gds_wds + tot_slp_wds;
- if (ALLOC_HEAP_tot != tot_wds) {
- fprintf(stderr, "Eek! %ld != %ld, %s, %d\n",ALLOC_HEAP_tot, tot_wds, file, line);
- } else {
- fprintf(stderr, "OK. %ld != %ld, %s, %d\n",ALLOC_HEAP_tot, tot_wds, file, line);
- }
-}
-#endif /* 0 */
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[RednCounts-print]{Print out all the counters}
-%* *
-%************************************************************************
-
-\begin{code}
-extern void printRegisteredCounterInfo (STG_NO_ARGS); /* fwd decl */
-
-#define INTAVG(a,b) ((b == 0) ? 0.0 : ((StgDouble) (a) / (StgDouble) (b)))
-#define PC(a) (100.0 * a)
-
-#define AVG(thing) \
- StgDouble CAT2(avg,thing) = INTAVG(CAT2(tot,thing),CAT2(ctr,thing))
-
-void
-PrintRednCountInfo()
-{
- I_ tot_allocs = /* total number of things allocated */
- ALLOC_FUN_ctr + ALLOC_THK_ctr + ALLOC_CON_ctr + ALLOC_TUP_ctr +
-#ifdef CONCURRENT
- ALLOC_STK_ctr + ALLOC_TSO_ctr +
-#ifdef PAR
- ALLOC_FMBQ_ctr + ALLOC_FME_ctr + ALLOC_BF_ctr +
-#endif
-#endif
- ALLOC_BH_ctr /*+ ALLOC_PAP_ctr*/ /*+ ALLOC_UPD_CON_ctr*/ + ALLOC_UPD_PAP_ctr +
- ALLOC_PRIM_ctr;
- I_ tot_adm_wds = /* total number of admin words allocated */
- ALLOC_FUN_adm + ALLOC_THK_adm + ALLOC_CON_adm + ALLOC_TUP_adm +
-#ifdef CONCURRENT
- ALLOC_STK_adm + ALLOC_TSO_adm +
-#ifdef PAR
- ALLOC_FMBQ_adm + ALLOC_FME_adm + ALLOC_BF_adm +
-#endif
-#endif
- ALLOC_BH_adm /*+ ALLOC_PAP_adm*/ /*+ ALLOC_UPD_CON_adm*/ + ALLOC_UPD_PAP_adm +
- ALLOC_PRIM_adm;
- I_ tot_gds_wds = /* total number of words of ``good stuff'' allocated */
- ALLOC_FUN_gds + ALLOC_THK_gds + ALLOC_CON_gds + ALLOC_TUP_gds +
-#ifdef CONCURRENT
- ALLOC_STK_gds + ALLOC_TSO_gds +
-#ifdef PAR
- ALLOC_FMBQ_gds + ALLOC_FME_gds + ALLOC_BF_gds +
-#endif
-#endif
- ALLOC_BH_gds /*+ ALLOC_PAP_gds*/ /*+ ALLOC_UPD_CON_gds*/ + ALLOC_UPD_PAP_gds +
- ALLOC_PRIM_gds;
- I_ tot_slp_wds = /* total number of ``slop'' words allocated */
- ALLOC_FUN_slp + ALLOC_THK_slp + ALLOC_CON_slp + ALLOC_TUP_slp +
-#ifdef CONCURRENT
- ALLOC_STK_slp + ALLOC_TSO_slp +
-#ifdef PAR
- ALLOC_FMBQ_slp + ALLOC_FME_slp + ALLOC_BF_slp +
-#endif
-#endif
- ALLOC_BH_slp /*+ ALLOC_PAP_slp*/ /*+ ALLOC_UPD_CON_slp*/ + ALLOC_UPD_PAP_slp +
- ALLOC_PRIM_slp;
- I_ tot_wds = /* total words */
- tot_adm_wds + tot_gds_wds + tot_slp_wds;
-
- I_ tot_enters =
- ENT_CON_ctr + ENT_FUN_DIRECT_ctr +
- ENT_IND_ctr + ENT_PAP_ctr + ENT_THK_ctr;
- I_ jump_direct_enters =
- tot_enters - ENT_VIA_NODE_ctr;
- I_ bypass_enters =
- ENT_FUN_DIRECT_ctr -
- (ENT_FUN_STD_ctr - UPD_PAP_IN_PLACE_ctr - UPD_PAP_IN_NEW_ctr);
-
- I_ tot_returns_in_regs =
- RET_NEW_IN_REGS_ctr + RET_OLD_IN_REGS_ctr + RET_SEMI_IN_REGS_ctr;
- I_ tot_returns_in_heap =
- RET_NEW_IN_HEAP_ctr + RET_OLD_IN_HEAP_ctr + RET_SEMI_IN_HEAP_ctr + RET_SEMI_BY_DEFAULT_ctr/*???*/;
- I_ tot_returns_of_new =
- RET_NEW_IN_REGS_ctr + RET_NEW_IN_HEAP_ctr;
- I_ tot_returns_of_old = /* NB: NOT USED ???! 94/05 WDP */
- RET_OLD_IN_REGS_ctr + RET_OLD_IN_HEAP_ctr +
- RET_SEMI_BY_DEFAULT_ctr + RET_SEMI_IN_HEAP_ctr + RET_SEMI_IN_REGS_ctr /*???*/;
-
- I_ tot_returns =
- tot_returns_in_regs + tot_returns_in_heap;
-
- I_ tot_upd_frames =
- UPDF_STD_PUSHED_ctr + UPDF_CON_PUSHED_ctr; /*DBH*/
-
- I_ con_updates =
- UPD_CON_W_NODE_ctr + UPD_CON_IN_PLACE_ctr + UPD_CON_IN_NEW_ctr;
- I_ pap_updates =
- UPD_PAP_IN_PLACE_ctr + UPD_PAP_IN_NEW_ctr;
- I_ tot_updates =
- UPD_EXISTING_ctr + con_updates + pap_updates;
- I_ tot_in_place_updates =
- UPD_CON_IN_PLACE_ctr + UPD_PAP_IN_PLACE_ctr;
-
- I_ tot_new_updates =
- UPD_NEW_IN_PLACE_NOPTRS_ctr + UPD_NEW_IN_PLACE_PTRS_ctr + UPD_NEW_IND_ctr;
- I_ tot_old_updates =
- UPD_OLD_IN_PLACE_NOPTRS_ctr + UPD_OLD_IN_PLACE_PTRS_ctr + UPD_OLD_IND_ctr;
- I_ tot_gengc_updates =
- tot_new_updates + tot_old_updates;
-
- fprintf(tickyfile,"\n\nALLOCATIONS: %ld (%ld words total: %ld admin, %ld goods, %ld slop)\n",
- tot_allocs, tot_wds, tot_adm_wds, tot_gds_wds, tot_slp_wds);
- fprintf(tickyfile,"\t\t\t\ttotal words:\t 2 3 4 5 6+\n");
-
-#define ALLOC_HISTO_MAGIC(categ) \
- (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[0], CAT3(ALLOC_,categ,_ctr)))), \
- (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[1], CAT3(ALLOC_,categ,_ctr)))), \
- (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[2], CAT3(ALLOC_,categ,_ctr)))), \
- (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[3], CAT3(ALLOC_,categ,_ctr)))), \
- (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[4], CAT3(ALLOC_,categ,_ctr))))
-
- fprintf(tickyfile,"%7ld (%5.1f%%) function values",
- ALLOC_FUN_ctr,
- PC(INTAVG(ALLOC_FUN_ctr, tot_allocs)));
- if (ALLOC_FUN_ctr != 0)
- fprintf(tickyfile,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(FUN));
-
- fprintf(tickyfile,"\n%7ld (%5.1f%%) thunks",
- ALLOC_THK_ctr,
- PC(INTAVG(ALLOC_THK_ctr, tot_allocs)));
- if (ALLOC_THK_ctr != 0)
- fprintf(tickyfile,"\t\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(THK));
-
- fprintf(tickyfile,"\n%7ld (%5.1f%%) data values",
- ALLOC_CON_ctr,
- PC(INTAVG(ALLOC_CON_ctr, tot_allocs)));
- if (ALLOC_CON_ctr != 0)
- fprintf(tickyfile,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(CON));
-
- fprintf(tickyfile,"\n%7ld (%5.1f%%) big tuples",
- ALLOC_TUP_ctr,
- PC(INTAVG(ALLOC_TUP_ctr, tot_allocs)));
- if (ALLOC_TUP_ctr != 0)
- fprintf(tickyfile,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(TUP));
-
- fprintf(tickyfile,"\n%7ld (%5.1f%%) black holes",
- ALLOC_BH_ctr,
- PC(INTAVG(ALLOC_BH_ctr, tot_allocs)));
- if (ALLOC_BH_ctr != 0)
- fprintf(tickyfile,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(BH));
-
- fprintf(tickyfile,"\n%7ld (%5.1f%%) prim things",
- ALLOC_PRIM_ctr,
- PC(INTAVG(ALLOC_PRIM_ctr, tot_allocs)));
- if (ALLOC_PRIM_ctr != 0)
- fprintf(tickyfile,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(PRIM));
-
-#if 0
- fprintf(tickyfile,"\n%7ld (%5.1f%%) partial applications",
- ALLOC_PAP_ctr,
- PC(INTAVG(ALLOC_PAP_ctr, tot_allocs)));
- if (ALLOC_PAP_ctr != 0)
- fprintf(tickyfile,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(PAP));
-#endif /* 0 */
-
- fprintf(tickyfile,"\n%7ld (%5.1f%%) partial applications",
- ALLOC_UPD_PAP_ctr,
- PC(INTAVG(ALLOC_UPD_PAP_ctr, tot_allocs)));
- if (ALLOC_UPD_PAP_ctr != 0)
- fprintf(tickyfile,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(UPD_PAP));
-
-#if 0
- fprintf(tickyfile,"\n%7ld (%5.1f%%) data-value updates",
- ALLOC_UPD_CON_ctr,
- PC(INTAVG(ALLOC_UPD_CON_ctr, tot_allocs)));
- if (ALLOC_UPD_CON_ctr != 0)
- fprintf(tickyfile,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(UPD_CON));
-#endif /* 0 */
-
-#ifdef CONCURRENT
- fprintf(tickyfile,"\n%7ld (%5.1f%%) stack objects",
- ALLOC_STK_ctr,
- PC(INTAVG(ALLOC_STK_ctr, tot_allocs)));
- if (ALLOC_STK_ctr != 0)
- fprintf(tickyfile,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(STK));
- fprintf(tickyfile,"\n%7ld (%5.1f%%) thread state objects",
- ALLOC_TSO_ctr,
- PC(INTAVG(ALLOC_TSO_ctr, tot_allocs)));
- if (ALLOC_TSO_ctr != 0)
- fprintf(tickyfile,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(TSO));
-#ifdef PAR
- fprintf(tickyfile,"\n%7ld (%5.1f%%) thread state objects",
- ALLOC_FMBQ_ctr,
- PC(INTAVG(ALLOC_FMBQ_ctr, tot_allocs)));
- if (ALLOC_FMBQ_ctr != 0)
- fprintf(tickyfile,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(FMBQ));
- fprintf(tickyfile,"\n%7ld (%5.1f%%) thread state objects",
- ALLOC_FME_ctr,
- PC(INTAVG(ALLOC_FME_ctr, tot_allocs)));
- if (ALLOC_FME_ctr != 0)
- fprintf(tickyfile,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(FME));
- fprintf(tickyfile,"\n%7ld (%5.1f%%) thread state objects",
- ALLOC_BF_ctr,
- PC(INTAVG(ALLOC_BF_ctr, tot_allocs)));
- if (ALLOC_BF_ctr != 0)
- fprintf(tickyfile,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(BF));
-#endif
-#endif
- fprintf(tickyfile,"\n");
-
- fprintf(tickyfile,"\nTotal storage-manager allocations: %ld (%ld words)\n\t[%ld words lost to speculative heap-checks]\n", ALLOC_HEAP_ctr, ALLOC_HEAP_tot, ALLOC_HEAP_tot - tot_wds);
-
- fprintf(tickyfile,"\nSTACK USAGE:\n"); /* NB: some bits are direction sensitive */
- fprintf(tickyfile,"\tA stack slots stubbed: %ld\n", A_STK_STUB_ctr);
-/* not used at all
- fprintf(tickyfile,"\tA stack slots re-used: %ld\n", A_STK_REUSE_ctr);
- fprintf(tickyfile,"\tB stack slots re-used: %ld\n", B_STK_REUSE_ctr);
-*/
-#ifndef CONCURRENT
- fprintf(tickyfile,"\tA stack max. depth: %ld words\n",
- (I_) (stackInfo.botA - max_SpA));
- fprintf(tickyfile,"\tB stack max. depth: %ld words\n",
- (I_) (max_SpB - stackInfo.botB)); /* And cheating, too (ToDo) */
-#endif
-
- fprintf(tickyfile,"\nENTERS: %ld of which %ld (%.1f%%) direct to the entry code\n\t\t [the rest indirected via Node's info ptr]\n",
- tot_enters,
- jump_direct_enters,
- PC(INTAVG(jump_direct_enters,tot_enters)));
- fprintf(tickyfile,"%7ld (%5.1f%%) thunks\n",
- ENT_THK_ctr,
- PC(INTAVG(ENT_THK_ctr,tot_enters)));
- fprintf(tickyfile,"%7ld (%5.1f%%) data values\n",
- ENT_CON_ctr,
- PC(INTAVG(ENT_CON_ctr,tot_enters)));
- fprintf(tickyfile,"%7ld (%5.1f%%) function values\n\t\t [of which %ld (%.1f%%) bypassed arg-satisfaction chk]\n",
- ENT_FUN_DIRECT_ctr,
- PC(INTAVG(ENT_FUN_DIRECT_ctr,tot_enters)),
- bypass_enters,
- PC(INTAVG(bypass_enters,ENT_FUN_DIRECT_ctr)));
- fprintf(tickyfile,"%7ld (%5.1f%%) partial applications\n",
- ENT_PAP_ctr,
- PC(INTAVG(ENT_PAP_ctr,tot_enters)));
- fprintf(tickyfile,"%7ld (%5.1f%%) indirections\n",
- ENT_IND_ctr,
- PC(INTAVG(ENT_IND_ctr,tot_enters)));
-
- fprintf(tickyfile,"\nRETURNS: %ld\n", tot_returns);
- fprintf(tickyfile,"%7ld (%5.1f%%) in registers [the rest in the heap]\n",
- tot_returns_in_regs,
- PC(INTAVG(tot_returns_in_regs,tot_returns)));
- fprintf(tickyfile,"%7ld (%5.1f%%) from entering a new constructor\n\t\t [the rest from entering an existing constructor]\n",
- tot_returns_of_new,
- PC(INTAVG(tot_returns_of_new,tot_returns)));
- fprintf(tickyfile,"%7ld (%5.1f%%) vectored [the rest unvectored]\n",
- VEC_RETURN_ctr,
- PC(INTAVG(VEC_RETURN_ctr,tot_returns)));
-
- fprintf(tickyfile,"\nUPDATE FRAMES: %ld (%ld omitted from thunks)\n",
- tot_upd_frames,
- UPDF_OMITTED_ctr);
- fprintf(tickyfile,"%7ld (%5.1f%%) standard frames\n",
- UPDF_STD_PUSHED_ctr,
- PC(INTAVG(UPDF_STD_PUSHED_ctr,tot_upd_frames)));
- fprintf(tickyfile,"%7ld (%5.1f%%) constructor frames\n",
- UPDF_CON_PUSHED_ctr,
- PC(INTAVG(UPDF_CON_PUSHED_ctr,tot_upd_frames)));
- fprintf(tickyfile,"\t\t [of which %ld (%.1f%%) were for black-holes]\n",
- UPDF_HOLE_PUSHED_ctr,
- PC(INTAVG(UPDF_HOLE_PUSHED_ctr,UPDF_CON_PUSHED_ctr))); /*DBH*/
-
- if (UPDF_RCC_PUSHED_ctr != 0)
- fprintf(tickyfile,"%7ld restore cost centre frames (%ld omitted)\n",
- UPDF_RCC_PUSHED_ctr,
- UPDF_RCC_OMITTED_ctr);
-
- fprintf(tickyfile,"\nUPDATES: %ld\n", tot_updates);
- fprintf(tickyfile,"%7ld (%5.1f%%) data values\n\t\t [%ld in place, %ld allocated new space, %ld with Node]\n",
- con_updates,
- PC(INTAVG(con_updates,tot_updates)),
- UPD_CON_IN_PLACE_ctr, UPD_CON_IN_NEW_ctr, UPD_CON_W_NODE_ctr);
- fprintf(tickyfile,"%7ld (%5.1f%%) partial applications\n\t\t [%ld in place, %ld allocated new space]\n",
- pap_updates,
- PC(INTAVG(pap_updates,tot_updates)),
- UPD_PAP_IN_PLACE_ctr, UPD_PAP_IN_NEW_ctr);
- fprintf(tickyfile,"%7ld (%5.1f%%) updates to existing heap objects\n",
- UPD_EXISTING_ctr,
- PC(INTAVG(UPD_EXISTING_ctr,tot_updates)));
- fprintf(tickyfile,"%7ld (%5.1f%%) in-place updates copied\n",
- UPD_IN_PLACE_COPY_ctr,
- PC(INTAVG(UPD_IN_PLACE_COPY_ctr,tot_in_place_updates)));
- if (UPD_ENTERED_ctr != 0) {
- fprintf(tickyfile,"%7ld (%5.1f%%) subsequently entered\n",
- UPD_ENTERED_ctr,
- PC(INTAVG(UPD_ENTERED_ctr,tot_updates)));
- fprintf(tickyfile,"%7ld (%5.1f%%) subsequently entered more than once\n",
- UPD_ENTERED_AGAIN_ctr,
- PC(INTAVG(UPD_ENTERED_AGAIN_ctr,tot_updates)));
- }
-
- if (tot_gengc_updates != 0) {
- fprintf(tickyfile,"\nNEW GEN UPDATES: %ld (%5.1f%%)\n",
- tot_new_updates,
- PC(INTAVG(tot_new_updates,tot_gengc_updates)));
- fprintf(tickyfile,"%7ld (%5.1f%%) indirections\n",
- UPD_NEW_IND_ctr,
- PC(INTAVG(UPD_NEW_IND_ctr,tot_gengc_updates)));
- fprintf(tickyfile,"%7ld (%5.1f%%) inplace with ptrs\n",
- UPD_NEW_IN_PLACE_PTRS_ctr,
- PC(INTAVG(UPD_NEW_IN_PLACE_PTRS_ctr,tot_gengc_updates)));
- fprintf(tickyfile,"%7ld (%5.1f%%) inplace without ptrs\n",
- UPD_NEW_IN_PLACE_NOPTRS_ctr,
- PC(INTAVG(UPD_NEW_IN_PLACE_NOPTRS_ctr,tot_gengc_updates)));
- fprintf(tickyfile,"\nOLD GEN UPDATES: %ld (%5.1f%%)\n",
- tot_old_updates,
- PC(INTAVG(tot_old_updates,tot_gengc_updates)));
- fprintf(tickyfile,"%7ld (%5.1f%%) indirections\n",
- UPD_OLD_IND_ctr,
- PC(INTAVG(UPD_OLD_IND_ctr,tot_gengc_updates)));
- fprintf(tickyfile,"%7ld (%5.1f%%) inplace with ptrs\n",
- UPD_OLD_IN_PLACE_PTRS_ctr,
- PC(INTAVG(UPD_OLD_IN_PLACE_PTRS_ctr,tot_gengc_updates)));
- fprintf(tickyfile,"%7ld (%5.1f%%) inplace without ptrs\n",
- UPD_OLD_IN_PLACE_NOPTRS_ctr,
- PC(INTAVG(UPD_OLD_IN_PLACE_NOPTRS_ctr,tot_gengc_updates)));
- }
-
- printRegisteredCounterInfo();
-
- fprintf(tickyfile,"\n**************************************************\n");
- fprintf(tickyfile,"%6ld ALLOC_HEAP_ctr\n", ALLOC_HEAP_ctr);
- fprintf(tickyfile,"%6ld ALLOC_HEAP_tot\n", ALLOC_HEAP_tot);
-
-#ifndef CONCURRENT
- fprintf(tickyfile,"%6ld HWM_SpA\n", (I_) (stackInfo.botA - max_SpA));
- fprintf(tickyfile,"%6ld HWM_SpB\n", (I_) (max_SpB - stackInfo.botB));
-#endif
-
- fprintf(tickyfile,"%6ld ALLOC_FUN_ctr\n", ALLOC_FUN_ctr);
- fprintf(tickyfile,"%6ld ALLOC_FUN_adm\n", ALLOC_FUN_adm);
- fprintf(tickyfile,"%6ld ALLOC_FUN_gds\n", ALLOC_FUN_gds);
- fprintf(tickyfile,"%6ld ALLOC_FUN_slp\n", ALLOC_FUN_slp);
- fprintf(tickyfile,"%6ld ALLOC_THK_ctr\n", ALLOC_THK_ctr);
- fprintf(tickyfile,"%6ld ALLOC_THK_adm\n", ALLOC_THK_adm);
- fprintf(tickyfile,"%6ld ALLOC_THK_gds\n", ALLOC_THK_gds);
- fprintf(tickyfile,"%6ld ALLOC_THK_slp\n", ALLOC_THK_slp);
- fprintf(tickyfile,"%6ld ALLOC_CON_ctr\n", ALLOC_CON_ctr);
- fprintf(tickyfile,"%6ld ALLOC_CON_adm\n", ALLOC_CON_adm);
- fprintf(tickyfile,"%6ld ALLOC_CON_gds\n", ALLOC_CON_gds);
- fprintf(tickyfile,"%6ld ALLOC_CON_slp\n", ALLOC_CON_slp);
- fprintf(tickyfile,"%6ld ALLOC_TUP_ctr\n", ALLOC_TUP_ctr);
- fprintf(tickyfile,"%6ld ALLOC_TUP_adm\n", ALLOC_TUP_adm);
- fprintf(tickyfile,"%6ld ALLOC_TUP_gds\n", ALLOC_TUP_gds);
- fprintf(tickyfile,"%6ld ALLOC_TUP_slp\n", ALLOC_TUP_slp);
- fprintf(tickyfile,"%6ld ALLOC_BH_ctr\n", ALLOC_BH_ctr);
- fprintf(tickyfile,"%6ld ALLOC_BH_adm\n", ALLOC_BH_adm);
- fprintf(tickyfile,"%6ld ALLOC_BH_gds\n", ALLOC_BH_gds);
- fprintf(tickyfile,"%6ld ALLOC_BH_slp\n", ALLOC_BH_slp);
-/*
- fprintf(tickyfile,"%6ld ALLOC_PAP_ctr\n", ALLOC_PAP_ctr);
- fprintf(tickyfile,"%6ld ALLOC_PAP_adm\n", ALLOC_PAP_adm);
- fprintf(tickyfile,"%6ld ALLOC_PAP_gds\n", ALLOC_PAP_gds);
- fprintf(tickyfile,"%6ld ALLOC_PAP_slp\n", ALLOC_PAP_slp);
-*/
- fprintf(tickyfile,"%6ld ALLOC_PRIM_ctr\n", ALLOC_PRIM_ctr);
- fprintf(tickyfile,"%6ld ALLOC_PRIM_adm\n", ALLOC_PRIM_adm);
- fprintf(tickyfile,"%6ld ALLOC_PRIM_gds\n", ALLOC_PRIM_gds);
- fprintf(tickyfile,"%6ld ALLOC_PRIM_slp\n", ALLOC_PRIM_slp);
-/*
- fprintf(tickyfile,"%6ld ALLOC_UPD_CON_ctr\n", ALLOC_UPD_CON_ctr);
- fprintf(tickyfile,"%6ld ALLOC_UPD_CON_adm\n", ALLOC_UPD_CON_adm);
- fprintf(tickyfile,"%6ld ALLOC_UPD_CON_gds\n", ALLOC_UPD_CON_gds);
- fprintf(tickyfile,"%6ld ALLOC_UPD_CON_slp\n", ALLOC_UPD_CON_slp);
-*/
- fprintf(tickyfile,"%6ld ALLOC_UPD_PAP_ctr\n", ALLOC_UPD_PAP_ctr);
- fprintf(tickyfile,"%6ld ALLOC_UPD_PAP_adm\n", ALLOC_UPD_PAP_adm);
- fprintf(tickyfile,"%6ld ALLOC_UPD_PAP_gds\n", ALLOC_UPD_PAP_gds);
- fprintf(tickyfile,"%6ld ALLOC_UPD_PAP_slp\n", ALLOC_UPD_PAP_slp);
-
-#ifdef CONCURRENT
- fprintf(tickyfile,"%6ld ALLOC_STK_ctr\n", ALLOC_STK_ctr);
- fprintf(tickyfile,"%6ld ALLOC_STK_adm\n", ALLOC_STK_adm);
- fprintf(tickyfile,"%6ld ALLOC_STK_gds\n", ALLOC_STK_gds);
- fprintf(tickyfile,"%6ld ALLOC_STK_slp\n", ALLOC_STK_slp);
- fprintf(tickyfile,"%6ld ALLOC_TSO_ctr\n", ALLOC_TSO_ctr);
- fprintf(tickyfile,"%6ld ALLOC_TSO_adm\n", ALLOC_TSO_adm);
- fprintf(tickyfile,"%6ld ALLOC_TSO_gds\n", ALLOC_TSO_gds);
- fprintf(tickyfile,"%6ld ALLOC_TSO_slp\n", ALLOC_TSO_slp);
-#ifdef PAR
- fprintf(tickyfile,"%6ld ALLOC_FMBQ_ctr\n", ALLOC_FMBQ_ctr);
- fprintf(tickyfile,"%6ld ALLOC_FMBQ_adm\n", ALLOC_FMBQ_adm);
- fprintf(tickyfile,"%6ld ALLOC_FMBQ_gds\n", ALLOC_FMBQ_gds);
- fprintf(tickyfile,"%6ld ALLOC_FMBQ_slp\n", ALLOC_FMBQ_slp);
- fprintf(tickyfile,"%6ld ALLOC_FME_ctr\n", ALLOC_FME_ctr);
- fprintf(tickyfile,"%6ld ALLOC_FME_adm\n", ALLOC_FME_adm);
- fprintf(tickyfile,"%6ld ALLOC_FME_gds\n", ALLOC_FME_gds);
- fprintf(tickyfile,"%6ld ALLOC_FME_slp\n", ALLOC_FME_slp);
- fprintf(tickyfile,"%6ld ALLOC_BF_ctr\n", ALLOC_BF_ctr);
- fprintf(tickyfile,"%6ld ALLOC_BF_adm\n", ALLOC_BF_adm);
- fprintf(tickyfile,"%6ld ALLOC_BF_gds\n", ALLOC_BF_gds);
- fprintf(tickyfile,"%6ld ALLOC_BF_slp\n", ALLOC_BF_slp);
-#endif
-#endif
-
- fprintf(tickyfile,"%6ld ENT_VIA_NODE_ctr\n", ENT_VIA_NODE_ctr);
- fprintf(tickyfile,"%6ld ENT_CON_ctr\n", ENT_CON_ctr);
- fprintf(tickyfile,"%6ld ENT_FUN_STD_ctr\n", ENT_FUN_STD_ctr);
- fprintf(tickyfile,"%6ld ENT_FUN_DIRECT_ctr\n", ENT_FUN_DIRECT_ctr);
- fprintf(tickyfile,"%6ld ENT_IND_ctr\n", ENT_IND_ctr);
- fprintf(tickyfile,"%6ld ENT_PAP_ctr\n", ENT_PAP_ctr);
- fprintf(tickyfile,"%6ld ENT_THK_ctr\n", ENT_THK_ctr);
-
- fprintf(tickyfile,"%6ld RET_NEW_IN_HEAP_ctr\n", RET_NEW_IN_HEAP_ctr);
- fprintf(tickyfile,"%6ld RET_NEW_IN_REGS_ctr\n", RET_NEW_IN_REGS_ctr);
- fprintf(tickyfile,"%6ld RET_OLD_IN_HEAP_ctr\n", RET_OLD_IN_HEAP_ctr);
- fprintf(tickyfile,"%6ld RET_OLD_IN_REGS_ctr\n", RET_OLD_IN_REGS_ctr);
- fprintf(tickyfile,"%6ld RET_SEMI_BY_DEFAULT_ctr\n", RET_SEMI_BY_DEFAULT_ctr);
- fprintf(tickyfile,"%6ld RET_SEMI_IN_HEAP_ctr\n", RET_SEMI_IN_HEAP_ctr);
- fprintf(tickyfile,"%6ld RET_SEMI_IN_REGS_ctr\n", RET_SEMI_IN_REGS_ctr);
- fprintf(tickyfile,"%6ld VEC_RETURN_ctr\n", VEC_RETURN_ctr);
-
- fprintf(tickyfile,"%6ld UPDF_OMITTED_ctr\n", UPDF_OMITTED_ctr);
- fprintf(tickyfile,"%6ld UPDF_STD_PUSHED_ctr\n", UPDF_STD_PUSHED_ctr);
- fprintf(tickyfile,"%6ld UPDF_CON_PUSHED_ctr\n", UPDF_CON_PUSHED_ctr);
- fprintf(tickyfile,"%6ld UPDF_HOLE_PUSHED_ctr\n", UPDF_HOLE_PUSHED_ctr);
-
- fprintf(tickyfile,"%6ld UPDF_RCC_PUSHED_ctr\n", UPDF_RCC_PUSHED_ctr);
- fprintf(tickyfile,"%6ld UPDF_RCC_OMITTED_ctr\n", UPDF_RCC_OMITTED_ctr);
-
- fprintf(tickyfile,"%6ld UPD_EXISTING_ctr\n", UPD_EXISTING_ctr);
- fprintf(tickyfile,"%6ld UPD_CON_W_NODE_ctr\n", UPD_CON_W_NODE_ctr);
- fprintf(tickyfile,"%6ld UPD_CON_IN_PLACE_ctr\n", UPD_CON_IN_PLACE_ctr);
- fprintf(tickyfile,"%6ld UPD_CON_IN_NEW_ctr\n", UPD_CON_IN_NEW_ctr);
- fprintf(tickyfile,"%6ld UPD_PAP_IN_PLACE_ctr\n", UPD_PAP_IN_PLACE_ctr);
- fprintf(tickyfile,"%6ld UPD_PAP_IN_NEW_ctr\n", UPD_PAP_IN_NEW_ctr);
- fprintf(tickyfile,"%6ld UPD_ENTERED_ctr\n", UPD_ENTERED_ctr);
- fprintf(tickyfile,"%6ld UPD_ENTERED_AGAIN_ctr\n",UPD_ENTERED_AGAIN_ctr);
-
- fprintf(tickyfile,"%6ld UPD_NEW_IND_ctr\n", UPD_NEW_IND_ctr);
- fprintf(tickyfile,"%6ld UPD_NEW_IN_PLACE_PTRS_ctr\n", UPD_NEW_IN_PLACE_PTRS_ctr);
- fprintf(tickyfile,"%6ld UPD_NEW_IN_PLACE_NOPTRS_ctr\n", UPD_NEW_IN_PLACE_NOPTRS_ctr);
- fprintf(tickyfile,"%6ld UPD_OLD_IND_ctr\n", UPD_OLD_IND_ctr);
- fprintf(tickyfile,"%6ld UPD_OLD_IN_PLACE_PTRS_ctr\n", UPD_OLD_IN_PLACE_PTRS_ctr);
- fprintf(tickyfile,"%6ld UPD_OLD_IN_PLACE_NOPTRS_ctr\n", UPD_OLD_IN_PLACE_NOPTRS_ctr);
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[RednCounts-ent-counters]{Handle named entry counters}
-%* *
-%************************************************************************
-
-Data structure used in ``registering'' one of these counters.
-\begin{code}
-struct ent_counter *ListOfEntryCtrs = NULL; /* root of list of them */
-\end{code}
-
-To print out all the registered-counter info:
-\begin{code}
-void
-printRegisteredCounterInfo ( STG_NO_ARGS )
-{
- struct ent_counter *p;
-
- if ( ListOfEntryCtrs != NULL ) {
- fprintf(tickyfile,"\n**************************************************\n");
- }
-
- for (p = ListOfEntryCtrs; p != NULL; p = p->link) {
- /* common stuff first; then the wrapper info if avail */
- fprintf(tickyfile, "%-40s%u\t%u\t%u\t%-16s%ld",
- p->f_str,
- p->arity,
- p->Astk_args,
- p->Bstk_args,
- p->f_arg_kinds,
- p->ctr);
-
- if ( p->wrap_str == NULL ) {
- fprintf(tickyfile, "\n");
-
- } else {
- fprintf(tickyfile, "\t%s\t%s\n",
- p->wrap_str,
- p->wrap_arg_kinds);
- }
- }
-}
-\end{code}
-
-That's all, folks.
-\begin{code}
-#endif /* DO_REDN_COUNTING */
-\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1995
+%
+\section{Runtime-system runtime flags}
+
+Everything to do with RTS runtime flags, including RTS parameters
+that can be set by them, either directly or indirectly.
+
+@rtsFlags.lh@ defines the data structure that holds all of them.
+
+\begin{code}
+#include "rtsdefs.h"
+
+struct RTS_FLAGS RTSflags; /* actually declare the data structure */
+struct ALL_FLAGS AllFlags;
+
+/* some fwd decls */
+static I_ decode(const char *);
+static void bad_option(const char *);
+static FILE * open_stats_file (I_ arg,
+ int argc, char *argv[], int rts_argc, char *rts_argv[],
+ const char *FILENAME_FMT);
+
+/* extern decls */
+long strtol PROTO((const char *, char **, int));
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Initial default values for @RTSFlags@}
+%* *
+%************************************************************************
+
+\begin{code}
+void
+initRtsFlagsDefaults (STG_NO_ARGS)
+{
+ RTSflags.GcFlags.statsFile = NULL;
+ RTSflags.GcFlags.giveStats = NO_GC_STATS;
+
+ RTSflags.GcFlags.stksSize = 0x10002; /* 2^16 = 16Kwords = 64Kbytes */
+ RTSflags.GcFlags.heapSize = 0x100002; /* 2^20 = 1Mwords = 4Mbytes */
+ RTSflags.GcFlags.allocAreaSize = 0x4002; /* 2^14 = 16Kwords = 64Kbytes;
+ plus 2 cache-friendly words */
+ RTSflags.GcFlags.allocAreaSizeGiven = rtsFalse;
+ RTSflags.GcFlags.specifiedOldGenSize= 0; /* means: use all heap available */
+ RTSflags.GcFlags.pcFreeHeap = 3; /* 3% */
+ /* minAllocAreaSize is derived; set in initSM,
+ after we know pcFreeHeap and heapSize */
+
+ RTSflags.GcFlags.force2s = rtsFalse;
+ RTSflags.GcFlags.forceGC = rtsFalse;
+ RTSflags.GcFlags.forcingInterval = 5000000; /* 5MB (or words?) */
+ RTSflags.GcFlags.ringBell = rtsFalse;
+ RTSflags.GcFlags.trace = 0; /* not turned on */
+
+ RTSflags.GcFlags.lazyBlackHoling = rtsTrue;
+ RTSflags.GcFlags.doSelectorsAtGC = rtsTrue;
+ RTSflags.GcFlags.squeezeUpdFrames = rtsTrue;
+
+#if defined(PROFILING) || defined(PAR)
+ RTSflags.CcFlags.doCostCentres = 0;
+ RTSflags.CcFlags.sortBy = SORTCC_TIME;
+
+ /* "ctxtSwitchTicks", "profilerTicks", & "msecsPerTick" are
+ derived info, so they are set after ctxtSwitchTime has been
+ determined.
+ */
+#endif /* PROFILING or PAR */
+
+#ifdef PROFILING
+ RTSflags.ProfFlags.doHeapProfile = rtsFalse;
+#endif /* PROFILING */
+
+#ifdef CONCURRENT
+ RTSflags.ConcFlags.ctxtSwitchTime = CS_MIN_MILLISECS; /* In milliseconds */
+ RTSflags.ConcFlags.maxThreads = 32;
+ RTSflags.ConcFlags.stkChunkSize = 1024;
+ RTSflags.ConcFlags.maxLocalSparks = 500;
+#endif /* CONCURRENT */
+
+#ifdef PAR
+ RTSflags.ParFlags.parallelStats = rtsFalse;
+ RTSflags.ParFlags.granSimStats = rtsFalse;
+ RTSflags.ParFlags.granSimStats_Binary = rtsFalse;
+
+ RTSflags.ParFlags.outputDisabled = rtsFalse;
+
+ RTSflags.ParFlags.packBufferSize = 1024;
+#endif /* PAR */
+
+#ifdef TICKY_TICKY
+ RTSflags.TickyFlags.showTickyStats = rtsFalse;
+ RTSflags.TickyFlags.tickyFile = NULL;
+
+ AllFlags.doUpdEntryCounts = rtsTrue; /*ToDo:move? */
+#endif
+}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Usage message for runtime-system (RTS) flags}
+%* *
+%************************************************************************
+
+\begin{code}
+static const char *
+usage_text[] = {
+"",
+"Usage: <prog> <args> [+RTS <rtsopts> | -RTS <args>] ... --RTS <args>",
+"",
+" +RTS Indicates run time system options follow",
+" -RTS Indicates program arguments follow",
+" --RTS Indicates that ALL subsequent arguments will be given to the",
+" program (including any of these RTS flags)",
+"",
+"The following run time system options are available:",
+"",
+" -? -f Prints this message and exits; the program is not executed",
+"",
+" -K<size> Sets the stack size (default 64k) Egs: -K32k -K512k",
+" -H<size> Sets the heap size (default 4M) -H512k -H16M",
+" -s<file> Summary GC statistics (default file: <program>.stat)",
+" -S<file> Detailed GC statistics (with -Sstderr going to stderr)",
+"",
+#if defined(GCap)
+" -M<n>% Sets minimum size of alloc area as % of heap (default 3%)",
+" -A<size> Fixes size of alloc area, overriding any minimum (-A gives 64k)",
+" -G<size> Fixes size of major generation (default is dynamic threshold)",
+" -F2s Forces program compiled for Appel gc to use 2s collection",
+#else
+# if defined(GCgn)
+" -A<size> Specifies size of alloc area (default 64k)",
+" -G<size> Fixes size of major generation (default is available heap)",
+" -F2s Forces program compiled for Gen gc to use 2s collection",
+# else
+" -M<n>% Minimum % of heap which must be available (default 3%)",
+" -A<size> Fixes size of heap area allocated between GCs (-A gives 64k)",
+# endif
+#endif
+" -j<size> Forces major GC at every <size> bytes allocated",
+#if defined(GCdu)
+" -u<percent> Fixes residency threshold at which mode switches (range 0.0..0.95)",
+#endif
+"",
+" -N No black-holing during GC (for use when a signal handler is present)",
+" -Z Don't squeeze out update frames on stack overflow",
+" -B Sound the bell at the start of each (major) garbage collection",
+#if defined(PROFILING) || defined(PAR)
+"",
+" -p<sort> Produce cost centre time profile (output file <program>.prof)",
+" sort: T = time (default), A = alloc, C = cost centre label",
+" -P<sort> Produce serial time profile (output file <program>.time)",
+" and a -p profile with detailed caf/enter/tick/alloc info",
+# if defined(PROFILING)
+"",
+" -h<break-down> Heap residency profile (output file <program>.hp)",
+" break-down: C = cost centre (default), M = module, G = group",
+" D = closure description, Y = type description",
+" T<ints>,<start> = time closure created",
+" ints: no. of interval bands plotted (default 18)",
+" start: seconds after which intervals start (default 0.0)",
+" A subset of closures may be selected by the attached cost centre using:",
+" -c{mod:lab,mod:lab...}, specific module:label cost centre(s)",
+" -m{mod,mod...} all cost centres from the specified modules(s)",
+" -g{grp,grp...} all cost centres from the specified group(s)",
+" Selections can also be made by description, type, kind and age:",
+" -d{des,des...} closures with specified closure descriptions",
+" -y{typ,typ...} closures with specified type descriptions",
+" -k{knd,knd...} closures of the specified kinds",
+" -a<age> closures which survived <age> complete intervals",
+" The selection logic used is summarised as follows:",
+" ([-c] or [-m] or [-g]) and ([-d] or [-y] or [-k]) and [-a]",
+" where an option is true if not specified",
+# endif
+"",
+" -z<tbl><size> set hash table <size> for <tbl> (C, M, G, D or Y)",
+"",
+" -i<secs> Number of seconds in a profiling interval (default 1.0):",
+" heap profile (-h) and/or serial time profile (-P) frequency",
+#endif /* PROFILING or PAR */
+"",
+#if defined(TICKY_TICKY)
+" -r<file> Produce reduction profiling statistics (with -rstderr for stderr)",
+"",
+#endif
+" -T<level> Trace garbage collection execution (debugging)",
+#ifdef CONCURRENT
+"",
+# ifdef PAR
+" -N<n> Use <n> PVMish processors in parallel (default: 2)",
+/* NB: the -N<n> is implemented by the driver!! */
+# endif
+" -C<secs> Context-switch interval in seconds",
+" (0 or no argument means switch as often as possible)",
+" the default is .01 sec; resolution is .01 sec",
+" -e<size> Size of spark pools (default 100)",
+# ifdef PAR
+" -q Enable activity profile (output files in ~/<program>*.gr)",
+" -qb Enable binary activity profile (output file /tmp/<program>.gb)",
+" -Q<size> Set pack-buffer size (default: 1024)",
+# else
+" -q[v] Enable quasi-parallel profile (output file <program>.qp)",
+# endif
+" -t<num> Set maximum number of advisory threads per PE (default 32)",
+" -o<num> Set stack chunk size (default 1024)",
+# ifdef PAR
+" -d Turn on PVM-ish debugging",
+" -O Disable output for performance measurement",
+# endif /* PAR */
+#endif /* CONCURRENT */
+"",
+"Other RTS options may be available for programs compiled a different way.",
+"The GHC User's Guide has full details.",
+"",
+0
+};
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Processing command-line arguments to set @RTSFlags@}
+%* *
+%************************************************************************
+
+\begin{code}
+#define RTS 1
+#define PGM 0
+
+#ifndef atof
+extern double atof();
+/* no proto because some machines use const and some do not */
+#endif
+
+static __inline__ rtsBool
+strequal(const char *a, const char * b)
+{
+ return(strcmp(a, b) == 0);
+}
+
+void
+setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[])
+{
+ rtsBool error = rtsFalse;
+ I_ mode;
+ I_ arg, total_arg;
+ char *last_slash;
+
+ /* Remove directory from argv[0] -- default files in current directory */
+
+ if ((last_slash = (char *) strrchr(argv[0], '/')) != NULL)
+ strcpy(argv[0], last_slash+1);
+
+ /* Split arguments (argv) into PGM (argv) and RTS (rts_argv) parts */
+ /* argv[0] must be PGM argument -- leave in argv */
+
+ total_arg = *argc;
+ arg = 1;
+
+ *argc = 1;
+ *rts_argc = 0;
+
+ for (mode = PGM; arg < total_arg && ! strequal("--RTS", argv[arg]); arg++) {
+ if (strequal("+RTS", argv[arg])) {
+ mode = RTS;
+ }
+ 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 == PGM) {
+ argv[(*argc)++] = argv[arg];
+ }
+ else {
+ fflush(stdout);
+ fprintf(stderr, "setupRtsFlags: Too many RTS arguments (max %d)\n",
+ MAX_RTS_ARGS-1);
+ EXIT(EXIT_FAILURE);
+ }
+ }
+ if (arg < total_arg) {
+ /* arg must be --RTS; process remaining program arguments */
+ while (++arg < total_arg) {
+ argv[(*argc)++] = argv[arg];
+ }
+ }
+ argv[*argc] = (char *) 0;
+ rts_argv[*rts_argc] = (char *) 0;
+
+ /* Process RTS (rts_argv) part: mainly to determine statsfile */
+
+ for (arg = 0; arg < *rts_argc; arg++) {
+ if (rts_argv[arg][0] != '-') {
+ fflush(stdout);
+ fprintf(stderr, "setupRtsFlags: Unexpected RTS argument: %s\n",
+ rts_argv[arg]);
+ error = rtsTrue;
+
+ } else {
+ switch(rts_argv[arg][1]) {
+
+ /* process: general args, then PROFILING-only ones,
+ then CONCURRENT-only, PARallel-only, GRAN-only,
+ TICKY-only (same order as defined in RtsFlags.lh);
+ within those groups, mostly in case-insensitive
+ alphabetical order.
+ */
+
+#ifdef TICKY_TICKY
+# define TICKY_BUILD_ONLY(x) x
+#else
+# define TICKY_BUILD_ONLY(x) \
+fprintf(stderr, "setupRtsFlags: GHC not built for: ticky-ticky stats\n"); \
+error = rtsTrue;
+#endif
+
+#if (defined(PROFILING) || defined(PAR))
+# define COST_CENTRE_USING_BUILD_ONLY(x) x
+#else
+# define COST_CENTRE_USING_BUILD_ONLY(x) \
+fprintf(stderr, "setupRtsFlags: GHC not built for: -prof or -parallel\n"); \
+error = rtsTrue;
+#endif
+
+#ifdef PROFILING
+# define PROFILING_BUILD_ONLY(x)
+#else
+# define PROFILING_BUILD_ONLY(x) \
+fprintf(stderr, "setupRtsFlags: GHC not built for: -prof\n"); \
+error = rtsTrue;
+#endif
+
+#ifdef CONCURRENT
+# define CONCURRENT_BUILD_ONLY(x)
+#else
+# define CONCURRENT_BUILD_ONLY(x) \
+fprintf(stderr, "setupRtsFlags: GHC not built for: -concurrent\n"); \
+error = rtsTrue;
+#endif
+
+#ifdef PAR
+# define PAR_BUILD_ONLY(x)
+#else
+# define PAR_BUILD_ONLY(x) \
+fprintf(stderr, "setupRtsFlags: GHC not built for: -parallel\n"); \
+error = rtsTrue;
+#endif
+
+#ifdef GRAN
+# define GRAN_BUILD_ONLY(x)
+#else
+# define GRAN_BUILD_ONLY(x) \
+fprintf(stderr, "setupRtsFlags: GHC not built for: -gransim\n"); \
+error = rtsTrue;
+#endif
+
+ /* =========== GENERAL ========================== */
+ case '?':
+ case 'f':
+ error = rtsTrue;
+ break;
+
+ case 'A':
+ RTSflags.GcFlags.allocAreaSize
+ = decode(rts_argv[arg]+2) / sizeof(W_);
+ RTSflags.GcFlags.allocAreaSizeGiven = rtsTrue;
+ break;
+
+ case 'B':
+ RTSflags.GcFlags.ringBell = rtsTrue;
+ break;
+
+ case 'F':
+ if (strequal(rts_argv[arg]+2, "2s")) {
+ RTSflags.GcFlags.force2s = rtsTrue;
+ } else {
+ bad_option( rts_argv[arg] );
+ }
+ break;
+
+ case 'G':
+ RTSflags.GcFlags.specifiedOldGenSize
+ = decode(rts_argv[arg]+2) / sizeof(W_);
+ break;
+
+ case 'K':
+ RTSflags.GcFlags.stksSize = decode(rts_argv[arg]+2) / sizeof(W_);
+
+ if (RTSflags.GcFlags.stksSize == 0) bad_option( rts_argv[arg] );
+ break;
+
+ case 'H':
+ RTSflags.GcFlags.heapSize = decode(rts_argv[arg]+2) / sizeof(W_);
+ /* user give size in *bytes* but "heapSize" is in *words* */
+
+ if (RTSflags.GcFlags.heapSize <= 0) bad_option(rts_argv[arg]);
+ break;
+
+ case 'j': /* force GC option */
+ RTSflags.GcFlags.forceGC = rtsTrue;
+ if (rts_argv[arg][2]) {
+ RTSflags.GcFlags.forcingInterval
+ = decode(rts_argv[arg]+2) / sizeof(W_);
+ }
+ break;
+
+ case 'M':
+ RTSflags.GcFlags.pcFreeHeap = atof(rts_argv[arg]+2);
+
+ if (RTSflags.GcFlags.pcFreeHeap < 0 || RTSflags.GcFlags.pcFreeHeap > 100)
+ bad_option( rts_argv[arg] );
+ break;
+
+ case 'N':
+ RTSflags.GcFlags.lazyBlackHoling = rtsFalse;
+ break;
+
+ case 'n':
+ RTSflags.GcFlags.doSelectorsAtGC = rtsFalse;
+ break;
+
+ case 'S': /* NB: no difference at present ! */
+ case 's':
+ RTSflags.GcFlags.giveStats ++; /* will be VERBOSE_GC_STATS */
+#ifdef PAR
+ /* Opening all those files would almost certainly fail... */
+ RTSflags.ParFlags.parallelStats = rtsTrue;
+ RTSflags.GcFlags.statsFile = stderr; /* temporary; ToDo: rm */
+#else
+ RTSflags.GcFlags.statsFile
+ = open_stats_file(arg, *argc, argv,
+ *rts_argc, rts_argv, STAT_FILENAME_FMT);
+
+ if (RTSflags.GcFlags.statsFile == NULL) error = rtsTrue;
+#endif
+ break;
+
+ case 'T':
+ if (rts_argv[arg][2] != '\0')
+ RTSflags.GcFlags.trace
+ = (W_) strtol(rts_argv[arg]+2, (char **)NULL, 0);
+ else
+ RTSflags.GcFlags.trace = 1; /* slightly weird; why, really? */
+ break;
+
+ case 'Z':
+ RTSflags.GcFlags.squeezeUpdFrames = rtsFalse;
+ break;
+
+ /* =========== PROFILING ========================== */
+
+ case 'P': /* detailed cost centre profiling (time/alloc) */
+ COST_CENTRE_USING_BUILD_ONLY(
+ RTSflags.CcFlags.doCostCentres++;
+ )
+ case 'p': /* cost centre profiling (time/alloc) */
+ COST_CENTRE_USING_BUILD_ONLY(
+ { char ch;
+ RTSflags.CcFlags.doCostCentres++;
+
+ for (ch = 2; rts_argv[arg][ch]; ch++) {
+ switch (rts_argv[arg][2]) {
+ case SORTCC_LABEL:
+ case SORTCC_TIME:
+ case SORTCC_ALLOC:
+ RTSflags.CcFlags.sortBy = rts_argv[arg][ch];
+ break;
+ default:
+ fprintf(stderr, "Invalid profiling sort option %s\n", rts_argv[arg]);
+ error = 1;
+ }}}
+ ) break;
+
+ case 'i': /* serial profiling -- initial timer interval */
+ COST_CENTRE_USING_BUILD_ONLY(
+ interval_ticks = (I_) ((atof(rts_argv[arg]+2) * TICK_FREQUENCY));
+ if (interval_ticks <= 0)
+ interval_ticks = 1;
+ ) break;
+
+ case 'h': /* serial heap profile */
+ PROFILING_BUILD_ONLY(
+ switch (rts_argv[arg][2]) {
+ case '\0':
+ case CCchar:
+ RTSflags.ProfFlags.doHeapProfile = HEAP_BY_CC;
+ break;
+ case MODchar:
+ RTSflags.ProfFlags.doHeapProfile = HEAP_BY_MOD;
+ break;
+ case GRPchar:
+ RTSflags.ProfFlags.doHeapProfile = HEAP_BY_GRP;
+ break;
+ case DESCRchar:
+ RTSflags.ProfFlags.doHeapProfile = HEAP_BY_DESCR;
+ break;
+ case TYPEchar:
+ RTSflags.ProfFlags.doHeapProfile = HEAP_BY_TYPE;
+ break;
+ case TIMEchar:
+ RTSflags.ProfFlags.doHeapProfile = HEAP_BY_TIME;
+ if (rts_argv[arg][3]) {
+ char *start_str = strchr(rts_argv[arg]+3, ',');
+ I_ intervals;
+ if (start_str) *start_str = '\0';
+
+ if ((intervals = decode(rts_argv[arg]+3)) != 0) {
+ time_intervals = (hash_t) intervals;
+ /* ToDo: and what if it *is* zero intervals??? */
+ }
+ if (start_str) {
+ earlier_ticks = (I_)((atof(start_str + 1) * TICK_FREQUENCY));
+ }
+ }
+ break;
+ default:
+ fprintf(stderr, "Invalid heap profile option: %s\n",
+ rts_argv[arg]);
+ error = 1;
+ }
+ ) break;
+
+ case 'z': /* size of index tables */
+ PROFILING_BUILD_ONLY(
+ switch (rts_argv[arg][2]) {
+ case CCchar:
+ max_cc_no = (hash_t) decode(rts_argv[arg]+3);
+ if (max_cc_no == 0) {
+ fprintf(stderr, "Bad number of cost centres %s\n", rts_argv[arg]);
+ error = 1;
+ }
+ break;
+ case MODchar:
+ max_mod_no = (hash_t) decode(rts_argv[arg]+3);
+ if (max_mod_no == 0) {
+ fprintf(stderr, "Bad number of modules %s\n", rts_argv[arg]);
+ error = 1;
+ }
+ break;
+ case GRPchar:
+ max_grp_no = (hash_t) decode(rts_argv[arg]+3);
+ if (max_grp_no == 0) {
+ fprintf(stderr, "Bad number of groups %s\n", rts_argv[arg]);
+ error = 1;
+ }
+ break;
+ case DESCRchar:
+ max_descr_no = (hash_t) decode(rts_argv[arg]+3);
+ if (max_descr_no == 0) {
+ fprintf(stderr, "Bad number of closure descriptions %s\n", rts_argv[arg]);
+ error = 1;
+ }
+ break;
+ case TYPEchar:
+ max_type_no = (hash_t) decode(rts_argv[arg]+3);
+ if (max_type_no == 0) {
+ fprintf(stderr, "Bad number of type descriptions %s\n", rts_argv[arg]);
+ error = 1;
+ }
+ break;
+ default:
+ fprintf(stderr, "Invalid index table size option: %s\n",
+ rts_argv[arg]);
+ error = 1;
+ }
+ ) break;
+
+ case 'c': /* cost centre label select */
+ case 'm': /* cost centre module select */
+ case 'g': /* cost centre group select */
+ case 'd': /* closure descr select */
+ case 'y': /* closure type select */
+ case 'k': /* closure kind select */
+ PROFILING_BUILD_ONLY(
+
+ left = strchr(rts_argv[arg], '{');
+ right = strrchr(rts_argv[arg], '}');
+ if (! left || ! right ||
+ strrchr(rts_argv[arg], '{') != left ||
+ strchr(rts_argv[arg], '}') != right) {
+ fprintf(stderr, "Invalid heap profiling selection bracketing\n %s\n", rts_argv[arg]);
+ error = 1;
+ } else {
+ *right = '\0';
+ switch (rts_argv[arg][1]) {
+ case 'c': /* cost centre label select */
+ select_cc = left + 1;
+ break;
+ case 'm': /* cost centre module select */
+ select_mod = left + 1;
+ break;
+ case 'g': /* cost centre group select */
+ select_grp = left + 1;
+ break;
+ case 'd': /* closure descr select */
+ select_descr = left + 1;
+ break;
+ case 't': /* closure type select */
+ select_type = left + 1;
+ break;
+ case 'k': /* closure kind select */
+ select_kind = left + 1;
+ break;
+ }
+ }
+ ) break;
+
+ /* =========== CONCURRENT ========================= */
+ case 'C': /* context switch interval */
+ CONCURRENT_BUILD_ONLY (
+ if (rts_argv[arg][2] == '\0')
+ RTSflags.ConcFlags.ctxtSwitchTime = 0;
+ else {
+ I_ cst; /* tmp */
+
+ /* Convert to milliseconds */
+ cst = (I_) ((atof(rts_argv[arg]+2) * 1000));
+ cst = (cst / CS_MIN_MILLISECS) * CS_MIN_MILLISECS;
+ if (cst < CS_MIN_MILLISECS)
+ cst = CS_MIN_MILLISECS;
+
+ RTSflags.ConcFlags.ctxtSwitchTime = cst;
+ }
+ ) break;
+
+ case 't':
+ CONCURRENT_BUILD_ONLY(
+ if (rts_argv[arg][2] != '\0') {
+ RTSflags.ConcFlags.maxThreads
+ = strtol(rts_argv[arg]+2, (char **) NULL, 10);
+ } else {
+ fprintf(stderr, "setupRtsFlags: missing size for -t\n");
+ error = rtsTrue;
+ }
+ ) break;
+
+ case 'o':
+ CONCURRENT_BUILD_ONLY (
+ if (rts_argv[arg][2] != '\0') {
+ I_ size = decode(rts_argv[arg]+2);
+
+ if (size < MIN_STKO_CHUNK_SIZE)
+ size = MIN_STKO_CHUNK_SIZE;
+
+ RTSflags.ConcFlags.stkChunkSize = size;
+ } else {
+ fprintf(stderr, "setupRtsFlags: missing size for -o\n");
+ error = rtsTrue;
+ }
+ ) break;
+
+ /* =========== PARALLEL =========================== */
+ case 'e':
+ CONCURRENT_BUILD_ONLY(
+ if (rts_argv[arg][2] != '\0') { /* otherwise, stick w/ the default */
+
+ RTSflags.ConcFlags.maxLocalSparks
+ = strtol(rts_argv[arg]+2, (char **) NULL, 10);
+
+ if (RTSflags.ConcFlags.maxLocalSparks <= 0) {
+ fprintf(stderr, "setupRtsFlags: bad value for -e\n");
+ error = rtsTrue;
+ }
+ }
+ ) break;
+
+ case 'O':
+ PAR_BUILD_ONLY(
+ RTSflags.ParFlags.outputDisabled = rtsTrue;
+ ) break;
+
+ case 'q': /* activity profile option */
+ PAR_BUILD_ONLY(
+ if (rts_argv[arg][2] == 'b')
+ RTSflags.ParFlags.granSimStats_Binary = rtsTrue;
+ else
+ RTSflags.ParFlags.granSimStats = rtsTrue;
+ ) break;
+
+#if 0 /* or??? */
+ case 'q': /* quasi-parallel profile option */
+ GRAN_BUILD_ONLY (
+ if (rts_argv[arg][2] == 'v')
+ do_qp_prof = 2;
+ else
+ do_qp_prof++;
+ ) break;
+#endif /* 0??? */
+
+ case 'Q': /* Set pack buffer size */
+ PAR_BUILD_ONLY(
+ if (rts_argv[arg][2] != '\0') {
+ RTSflags.ParFlags.packBufferSize = decode(rts_argv[arg]+2);
+ } else {
+ fprintf(stderr, "setupRtsFlags: missing size of PackBuffer (for -Q)\n");
+ error = rtsTrue;
+ }
+ ) break;
+
+ /* =========== GRAN =============================== */
+
+ case 'b':
+ GRAN_BUILD_ONLY(
+ process_gran_option();
+ ) break;
+
+ /* =========== TICKY ============================== */
+
+ case 'r': /* Basic profiling stats */
+ TICKY_BUILD_ONLY(
+
+ RTSflags.TickyFlags.showTickyStats = rtsTrue;
+ RTSflags.TickyFlags.tickyFile
+ = open_stats_file(arg, *argc, argv,
+ *rts_argc, rts_argv, TICKY_FILENAME_FMT);
+
+ if (RTSflags.TickyFlags.tickyFile == NULL) error = rtsTrue;
+ ) break;
+
+ /* =========== OH DEAR ============================ */
+ default:
+ fprintf(stderr, "setupRtsFlags: Unknown RTS option: %s\n",rts_argv[arg]);
+ error = rtsTrue;
+ break;
+ }
+ }
+ }
+ if (error) {
+ const char **p;
+
+ fflush(stdout);
+ for (p = usage_text; *p; p++)
+ fprintf(stderr, "%s\n", *p);
+ EXIT(EXIT_FAILURE);
+ }
+
+}
+
+#ifdef GRAN
+static void
+process_gran_option()
+{
+ if (rts_argv[arg][2] != '\0') {
+
+ /* Should we emulate hbcpp */
+ if(strequal((rts_argv[arg]+2),"roken")) {
+ ++DoAlwaysCreateThreads;
+ strcpy(rts_argv[arg]+2,"oring");
+ }
+
+ /* or a ridiculously idealised simulator */
+ if(strequal((rts_argv[arg]+2),"oring")) {
+ gran_latency = gran_fetchtime = gran_additional_latency =
+ gran_gunblocktime = gran_lunblocktime
+ = gran_threadcreatetime = gran_threadqueuetime
+ = gran_threadscheduletime = gran_threaddescheduletime
+ = gran_threadcontextswitchtime
+ = 0;
+
+ gran_mpacktime = gran_munpacktime = 0;
+
+ gran_arith_cost = gran_float_cost = gran_load_cost
+ = gran_store_cost = gran_branch_cost = 0;
+
+ gran_heapalloc_cost = 1;
+
+ /* ++DoFairSchedule; */
+ ++DoStealThreadsFirst;
+ ++DoThreadMigration;
+ RTSflags.ParFlags.granSimStats = rtsTrue;
+ }
+
+ /* or a ridiculously idealised simulator */
+ if(strequal((rts_argv[arg]+2),"onzo")) {
+ gran_latency = gran_fetchtime = gran_additional_latency =
+ gran_gunblocktime = gran_lunblocktime
+ = gran_threadcreatetime = gran_threadqueuetime
+ = gran_threadscheduletime = gran_threaddescheduletime
+ = gran_threadcontextswitchtime
+ = 0;
+
+ gran_mpacktime = gran_munpacktime = 0;
+
+ /* Keep default values for these
+ gran_arith_cost = gran_float_cost = gran_load_cost
+ = gran_store_cost = gran_branch_cost = 0;
+ */
+
+ gran_heapalloc_cost = 1;
+
+ /* ++DoFairSchedule; */ /* -b-R */
+ /* ++DoStealThreadsFirst; */ /* -b-T */
+ ++DoReScheduleOnFetch; /* -bZ */
+ ++DoThreadMigration; /* -bM */
+ RTSflags.ParFlags.granSimStats = rtsTrue; /* -bP */
+# if defined(GRAN_CHECK) && defined(GRAN)
+ debug = 0x20; /* print event statistics */
+# endif
+ }
+
+ /* Communication and task creation cost parameters */
+ else switch(rts_argv[arg][2]) {
+ case 'l':
+ if (rts_argv[arg][3] != '\0')
+ {
+ gran_gunblocktime = gran_latency = decode(rts_argv[arg]+3);
+ gran_fetchtime = 2* gran_latency;
+ }
+ else
+ gran_latency = LATENCY;
+ break;
+
+ case 'a':
+ if (rts_argv[arg][3] != '\0')
+ gran_additional_latency = decode(rts_argv[arg]+3);
+ else
+ gran_additional_latency = ADDITIONAL_LATENCY;
+ break;
+
+ case 'm':
+ if (rts_argv[arg][3] != '\0')
+ gran_mpacktime = decode(rts_argv[arg]+3);
+ else
+ gran_mpacktime = MSGPACKTIME;
+ break;
+
+ case 'x':
+ if (rts_argv[arg][3] != '\0')
+ gran_mtidytime = decode(rts_argv[arg]+3);
+ else
+ gran_mtidytime = 0;
+ break;
+
+ case 'r':
+ if (rts_argv[arg][3] != '\0')
+ gran_munpacktime = decode(rts_argv[arg]+3);
+ else
+ gran_munpacktime = MSGUNPACKTIME;
+ break;
+
+ case 'f':
+ if (rts_argv[arg][3] != '\0')
+ gran_fetchtime = decode(rts_argv[arg]+3);
+ else
+ gran_fetchtime = FETCHTIME;
+ break;
+
+ case 'n':
+ if (rts_argv[arg][3] != '\0')
+ gran_gunblocktime = decode(rts_argv[arg]+3);
+ else
+ gran_gunblocktime = GLOBALUNBLOCKTIME;
+ break;
+
+ case 'u':
+ if (rts_argv[arg][3] != '\0')
+ gran_lunblocktime = decode(rts_argv[arg]+3);
+ else
+ gran_lunblocktime = LOCALUNBLOCKTIME;
+ break;
+
+ /* Thread-related metrics */
+ case 't':
+ if (rts_argv[arg][3] != '\0')
+ gran_threadcreatetime = decode(rts_argv[arg]+3);
+ else
+ gran_threadcreatetime = THREADCREATETIME;
+ break;
+
+ case 'q':
+ if (rts_argv[arg][3] != '\0')
+ gran_threadqueuetime = decode(rts_argv[arg]+3);
+ else
+ gran_threadqueuetime = THREADQUEUETIME;
+ break;
+
+ case 'c':
+ if (rts_argv[arg][3] != '\0')
+ gran_threadscheduletime = decode(rts_argv[arg]+3);
+ else
+ gran_threadscheduletime = THREADSCHEDULETIME;
+
+ gran_threadcontextswitchtime = gran_threadscheduletime
+ + gran_threaddescheduletime;
+ break;
+
+ case 'd':
+ if (rts_argv[arg][3] != '\0')
+ gran_threaddescheduletime = decode(rts_argv[arg]+3);
+ else
+ gran_threaddescheduletime = THREADDESCHEDULETIME;
+
+ gran_threadcontextswitchtime = gran_threadscheduletime
+ + gran_threaddescheduletime;
+ break;
+
+ /* Instruction Cost Metrics */
+ case 'A':
+ if (rts_argv[arg][3] != '\0')
+ gran_arith_cost = decode(rts_argv[arg]+3);
+ else
+ gran_arith_cost = ARITH_COST;
+ break;
+
+ case 'F':
+ if (rts_argv[arg][3] != '\0')
+ gran_float_cost = decode(rts_argv[arg]+3);
+ else
+ gran_float_cost = FLOAT_COST;
+ break;
+
+ case 'B':
+ if (rts_argv[arg][3] != '\0')
+ gran_branch_cost = decode(rts_argv[arg]+3);
+ else
+ gran_branch_cost = BRANCH_COST;
+ break;
+
+ case 'L':
+ if (rts_argv[arg][3] != '\0')
+ gran_load_cost = decode(rts_argv[arg]+3);
+ else
+ gran_load_cost = LOAD_COST;
+ break;
+
+ case 'S':
+ if (rts_argv[arg][3] != '\0')
+ gran_store_cost = decode(rts_argv[arg]+3);
+ else
+ gran_store_cost = STORE_COST;
+ break;
+
+ case 'H':
+ if (rts_argv[arg][3] != '\0')
+ gran_heapalloc_cost = decode(rts_argv[arg]+3);
+ else
+ gran_heapalloc_cost = 0;
+ break;
+
+ case 'y':
+ if (rts_argv[arg][3] != '\0')
+ FetchStrategy = decode(rts_argv[arg]+3);
+ else
+ FetchStrategy = 4; /* default: fetch everything */
+ break;
+
+ /* General Parameters */
+ case 'p':
+ if (rts_argv[arg][3] != '\0')
+ {
+ max_proc = decode(rts_argv[arg]+3);
+ if(max_proc > MAX_PROC || max_proc < 1)
+ {
+ fprintf(stderr,"setupRtsFlags: no more than %u processors allowed\n", MAX_PROC);
+ error = rtsTrue;
+ }
+ }
+ else
+ max_proc = MAX_PROC;
+ break;
+
+ case 'C':
+ ++DoAlwaysCreateThreads;
+ ++DoThreadMigration;
+ break;
+
+ case 'G':
+ ++DoGUMMFetching;
+ break;
+
+ case 'M':
+ ++DoThreadMigration;
+ break;
+
+ case 'R':
+ ++DoFairSchedule;
+ break;
+
+ case 'T':
+ ++DoStealThreadsFirst;
+ ++DoThreadMigration;
+ break;
+
+ case 'Z':
+ ++DoReScheduleOnFetch;
+ break;
+
+ case 'z':
+ ++SimplifiedFetch;
+ break;
+
+ case 'N':
+ ++PreferSparksOfLocalNodes;
+ break;
+
+ case 'b':
+ RTSflags.ParFlags.granSimStats_Binary = rtsTrue;
+ break;
+
+ case 'P':
+ RTSflags.ParFlags.granSimStats = rtsTrue;
+ break;
+
+ case 's':
+ ++do_sp_profile;
+ break;
+
+ case '-':
+ switch(rts_argv[arg][3]) {
+
+ case 'C':
+ DoAlwaysCreateThreads=0;
+ DoThreadMigration=0;
+ break;
+
+ case 'G':
+ DoGUMMFetching=0;
+ break;
+
+ case 'M':
+ DoThreadMigration=0;
+ break;
+
+ case 'R':
+ DoFairSchedule=0;
+ break;
+
+ case 'T':
+ DoStealThreadsFirst=0;
+ DoThreadMigration=0;
+ break;
+
+ case 'Z':
+ DoReScheduleOnFetch=0;
+ break;
+
+ case 'N':
+ PreferSparksOfLocalNodes=0;
+ break;
+
+ case 'P':
+ RTSflags.ParFlags.granSimStats = rtsFalse;
+ no_gr_profile=1;
+ break;
+
+ case 's':
+ do_sp_profile=0;
+ break;
+
+ case 'b':
+ RTSflags.ParFlags.granSimStats_Binary = rtsFalse;
+ break;
+
+ default:
+ bad_option( rts_argv[arg] );
+ break;
+ }
+ break;
+
+# if defined(GRAN_CHECK) && defined(GRAN)
+ case 'D':
+ switch(rts_argv[arg][3]) {
+ case 'e': /* event trace */
+ fprintf(stderr,"Printing event trace.\n");
+ ++event_trace;
+ break;
+
+ case 'f':
+ fprintf(stderr,"Printing forwarding of FETCHNODES.\n");
+ debug |= 0x2; /* print fwd messages */
+ break;
+
+ case 'z':
+ fprintf(stderr,"Check for blocked on fetch.\n");
+ debug |= 0x4; /* debug non-reschedule-on-fetch */
+ break;
+
+ case 't':
+ fprintf(stderr,"Check for TSO asleep on fetch.\n");
+ debug |= 0x10; /* debug TSO asleep for fetch */
+ break;
+
+ case 'E':
+ fprintf(stderr,"Printing event statistics.\n");
+ debug |= 0x20; /* print event statistics */
+ break;
+
+ case 'F':
+ fprintf(stderr,"Prohibiting forward.\n");
+ NoForward = 1; /* prohibit forwarding */
+ break;
+
+ case 'm':
+ fprintf(stderr,"Printing fetch misses.\n");
+ PrintFetchMisses = 1; /* prohibit forwarding */
+ break;
+
+ case 'd':
+ fprintf(stderr,"Debug mode.\n");
+ debug |= 0x40;
+ break;
+
+ case 'D':
+ fprintf(stderr,"Severe debug mode.\n");
+ debug |= 0x80;
+ break;
+
+ case '\0':
+ debug = 1;
+ break;
+
+ default:
+ bad_option( rts_argv[arg] );
+ break;
+ }
+ break;
+# endif
+ default:
+ bad_option( rts_argv[arg] );
+ break;
+ }
+ }
+ do_gr_sim++;
+ RTSflags.ConcFlags.ctxtSwitchTime = 0;
+}
+#endif /* GRAN */
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Profiling RTS Arguments}
+%* *
+%************************************************************************
+
+\begin{code}
+I_ MaxResidency = 0; /* in words; for stats only */
+I_ ResidencySamples = 0; /* for stats only */
+
+void
+initSM(void)
+{
+ RTSflags.GcFlags.minAllocAreaSize
+ = (I_) (RTSflags.GcFlags.heapSize * RTSflags.GcFlags.pcFreeHeap / 100);
+ /*
+ This needs to be here, in case the user changed some of these
+ values with a "hook".
+ */
+}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Utility bits}
+%* *
+%************************************************************************
+
+\begin{code}
+static FILE * /* return NULL on error */
+open_stats_file (
+ I_ arg,
+ int argc, char *argv[],
+ int rts_argc, char *rts_argv[],
+ const char *FILENAME_FMT)
+{
+ FILE *f = NULL;
+
+ if (strequal(rts_argv[arg]+2, "stderr")) /* use real stderr */
+ f = stderr;
+ else if (rts_argv[arg][2] != '\0') /* stats file specified */
+ f = fopen(rts_argv[arg]+2,"w");
+ else {
+ char stats_filename[STATS_FILENAME_MAXLEN]; /* default <program>.<ext> */
+ sprintf(stats_filename, FILENAME_FMT, argv[0]);
+ f = fopen(stats_filename,"w");
+ }
+ if (f == NULL) {
+ fprintf(stderr, "Can't open stats file %s\n", rts_argv[arg]+2);
+ } else {
+ /* Write argv and rtsv into start of stats file */
+ I_ count;
+ for(count = 0; count < argc; count++)
+ fprintf(f, "%s ", argv[count]);
+ fprintf(f, "+RTS ");
+ for(count = 0; count < rts_argc; count++)
+ fprintf(f, "%s ", rts_argv[count]);
+ fprintf(f, "\n");
+ }
+
+ return(f);
+}
+
+static I_
+decode(const char *s)
+{
+ I_ c;
+ StgDouble m;
+
+ if (!*s)
+ return 0;
+
+ m = atof(s);
+ c = s[strlen(s)-1];
+
+ if (c == 'g' || c == 'G')
+ m *= 1000*1000*1000; /* UNchecked! */
+ else if (c == 'm' || c == 'M')
+ m *= 1000*1000; /* We do not use powers of 2 (1024) */
+ else if (c == 'k' || c == 'K') /* to avoid possible bad effects on */
+ m *= 1000; /* a direct-mapped cache. */
+ else if (c == 'w' || c == 'W')
+ m *= sizeof(W_);
+
+ return (I_)m;
+}
+
+static void
+bad_option(const char *s)
+{
+ fflush(stdout);
+ fprintf(stderr, "initSM: Bad RTS option: %s\n", s);
+ EXIT(EXIT_FAILURE);
+}
+\end{code}
# endif
void
-AwaitEvent(delta)
-I_ delta;
+AwaitEvent(I_ delta)
{
P_ tso, prev, next;
rtsBool ready;
fd_set rfd;
I_ us;
I_ min;
+ I_ maxfd=0;
struct timeval tv;
min = delta == 0 ? 0x7fffffff : 0;
/*
* Collect all of the fd's that we're interested in, and capture
* the minimum waiting time for the delayed threads.
+ *
+ * (I_)TSO_EVENT(tso) < 0 => thread waiting on fd (-(I_)TSO_EVENT(tso))
+ *
*/
FD_ZERO(&rfd);
for(tso = WaitingThreadsHd; tso != Nil_closure; tso = TSO_LINK(tso)) {
min = us;
} else {
/* Looking at a wait event */
+ maxfd = ((-us)> maxfd) ? (-us) : maxfd;
FD_SET((-us), &rfd);
}
}
tv.tv_sec = min / 1000000;
tv.tv_usec = min % 1000000;
- while (select(FD_SETSIZE, &rfd, NULL, NULL, &tv) < 0) {
+ while (select((maxfd==0 ? 0 : (maxfd+1)), &rfd, NULL, NULL, &tv) < 0) {
if (errno != EINTR) {
fflush(stdout);
fprintf(stderr, "AwaitEvent: select failed\n");
EXIT(EXIT_FAILURE);
}
}
-
+
if (delta == 0)
- delta = min;
+ delta=min;
prev = NULL;
for(tso = WaitingThreadsHd; tso != Nil_closure; tso = next) {
much pain.
\begin{code}
-
#include "platform.h"
#if defined(sunos4_TARGET_OS)
# define _OSF_SOURCE 1
#endif
-#if defined(linuxaout_TARGET_OS) || defined(linux_TARGET_OS)
- /* I have no idea why this works (WDP 95/03) */
-# define _BSD_SOURCE 1
+#if irix_TARGET_OS
+/* SIGVTALRM not avail w/ POSIX_SOURCE, but worse things happen without */
+/* SIGH: triple SIGH (WDP 95/07) */
+# define SIGVTALRM 28
#endif
#include "rtsdefs.h"
#if defined(HAVE_SIGNAL_H)
# include <signal.h>
#endif
-#if irix_TARGET_OS
-/* SIGVTALRM not avail w/ POSIX_SOURCE, but worse things happen without */
-/* SIGH: triple SIGH (WDP 95/07) */
-# define SIGVTALRM 28
-#endif
#if defined(HAVE_SIGINFO_H)
/* DEC OSF1 seems to need this explicitly. Maybe others do as well? */
fault.
\begin{code}
-
#if STACK_CHECK_BY_PAGE_FAULT
extern P_ stks_space; /* Where the stacks live, from SMstacks.lc */
-extern I_ SM_word_stk_size; /* How big they are (ditto) */
-
\end{code}
SunOS 4.x is too old to have @SA_SIGINFO@ as a flag to @sigaction@, so
Fun, eh?
\begin{code}
-
-# if defined(sunos4_TARGET_OS) || defined(linuxaout_TARGET_OS) || defined(linux_TARGET_OS)
+# if defined(sunos4_TARGET_OS)
static void
segv_handler(sig, code, scp, addr)
int sig;
- int code;
+ int code; /* NB: all except first argument are "implementation defined" */
struct sigcontext *scp;
caddr_t addr;
{
extern void StackOverflow(STG_NO_ARGS) STG_NORETURN;
if (addr >= (caddr_t) stks_space
- && addr < (caddr_t) (stks_space + SM_word_stk_size))
+ && addr < (caddr_t) (stks_space + RTSflags.GcFlags.stksSize))
StackOverflow();
fflush(stdout);
}
int
-install_segv_handler()
+install_segv_handler(void)
{
- return (int) signal(SIGSEGV, segv_handler) == -1;
+ return ((int) signal(SIGSEGV, segv_handler) == SIG_ERR);
+ /* I think the "== SIG_ERR" is saying "there was no
+ handler for SIGSEGV before this one". WDP 95/12
+ */
}
# else /* Not SunOS 4 */
# endif
static void
-segv_handler(sig, sip)
- int sig;
- siginfo_t *sip;
+segv_handler(int sig, siginfo_t *sip)
+ /* NB: the second "siginfo_t" argument is not really standard */
{
fflush(stdout);
if (sip == NULL) {
fprintf(stderr, "Segmentation fault caught, address unknown\n");
} else {
if (sip->si_addr >= (caddr_t) stks_space
- && sip->si_addr < (caddr_t) (stks_space + SM_word_stk_size))
+ && sip->si_addr < (caddr_t) (stks_space + RTSflags.GcFlags.stksSize))
StackOverflow();
fprintf(stderr, "Segmentation fault caught, address = %08lx\n", (W_) sip->si_addr);
}
int
-install_segv_handler()
+install_segv_handler(STG_NO_ARGS)
{
struct sigaction action;
action.sa_handler = segv_handler;
sigemptyset(&action.sa_mask);
action.sa_flags = SA_SIGINFO;
+
return sigaction(SIGSEGV, &action, NULL);
}
here.
\begin{code}
-#if (defined(USE_COST_CENTRES) || defined(CONCURRENT)) && !defined(GRAN)
-
-# if defined(USE_COST_CENTRES)
-extern I_ heap_profiling_req;
-# endif
+#if (defined(PROFILING) || defined(CONCURRENT)) && !defined(GRAN)
# ifdef CONCURRENT
-# if defined(USE_COST_CENTRES) || defined(GUM)
-I_ contextSwitchTicks;
-I_ profilerTicks;
-# endif
-
# ifdef PAR
extern P_ CurrentTSO;
# endif
-extern I_ contextSwitchTime;
static void
-vtalrm_handler(sig)
- int sig;
+vtalrm_handler(int sig)
{
/*
For the parallel world, currentTSO is set if there is any work
in case other PEs have sent us messages which must be processed.
*/
-# if defined(USE_COST_CENTRES) || defined(GUM)
+# if defined(PROFILING) || defined(PAR)
static I_ csTicks = 0, pTicks = 0;
if (time_profiling) {
- if (++pTicks % profilerTicks == 0) {
-# if ! defined(USE_COST_CENTRES)
+ if (++pTicks % RTSflags.CcFlags.profilerTicks == 0) {
+# if ! defined(PROFILING)
handle_tick_serial();
# else
- if (cc_profiling > 1 || heap_profiling_req != HEAP_NO_PROFILING)
+ if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE
+ || RTSflags.ProfFlags.doHeapProfile)
handle_tick_serial();
else
handle_tick_noserial();
# endif
}
- if (++csTicks % contextSwitchTicks != 0)
+ if (++csTicks % RTSflags.CcFlags.ctxtSwitchTicks != 0)
return;
}
# endif
if (WaitingThreadsHd != Nil_closure)
- AwaitEvent(contextSwitchTime);
+ AwaitEvent(RTSflags.ConcFlags.ctxtSwitchTime);
# ifdef PAR
if (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL] ||
PendingSparksTl[ADVISORY_POOL] == PendingSparksLim[ADVISORY_POOL]) {
PruneSparks();
- if (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL])
+ if (PendingSparksTl[REQUIRED_POOL] == PendingSparksLim[REQUIRED_POOL])
PendingSparksTl[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL] +
SparkLimit[REQUIRED_POOL] / 2;
- if (PendingSparksTl[ADVISORY_POOL] == PendingSparksLim[ADVISORY_POOL])
+ if (PendingSparksTl[ADVISORY_POOL] == PendingSparksLim[ADVISORY_POOL]) {
PendingSparksTl[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL] +
SparkLimit[ADVISORY_POOL] / 2;
+ sparksIgnored += SparkLimit[REQUIRED_POOL] / 2;
+ }
}
if (CurrentTSO != NULL ||
# endif
-# if defined(sunos4_TARGET_OS) || defined(linuxaout_TARGET_OS) || defined(linux_TARGET_OS)
+# if defined(sunos4_TARGET_OS)
int
-install_vtalrm_handler()
+install_vtalrm_handler(void)
{
void (*old)();
# ifdef CONCURRENT
old = signal(SIGVTALRM, vtalrm_handler);
# else
- if (cc_profiling > 1 || heap_profiling_req != HEAP_NO_PROFILING)
+ if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE
+ || RTSflags.ProfFlags.doHeapProfile)
old = signal(SIGVTALRM, handle_tick_serial);
else
old = signal(SIGVTALRM, handle_tick_noserial);
# endif
- return (int) old == -1;
+ return ((int) old == SIG_ERR);
}
static int vtalrm_mask;
# ifdef CONCURRENT
action.sa_handler = vtalrm_handler;
# else
- if (cc_profiling > 1 || heap_profiling_req != HEAP_NO_PROFILING)
+ if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE
+ || RTSflags.ProfFlags.doHeapProfile)
action.sa_handler = handle_tick_serial;
else
action.sa_handler = handle_tick_noserial;
(void) sigprocmask(SIG_UNBLOCK, &signals, NULL);
}
-# endif /* SunOS 4 */
+# endif /* ! SunOS 4 */
-#endif /* USE_COST_CENTRES || CONCURRENT (but not GRAN) */
+#endif /* PROFILING || CONCURRENT (but not GRAN) */
\end{code}
#ifdef PAR
void
-blockUserSignals()
+blockUserSignals(void)
{
return;
}
void
-unblockUserSignals()
+unblockUserSignals(void)
{
return;
}
static I_ nHandlers = 0; /* Size of handlers array */
static void
-more_handlers(sig)
- I_ sig;
+more_handlers(I_ sig)
{
I_ i;
if (handlers == NULL) {
fflush(stdout);
- fprintf(stderr, "VM exhausted\n");
+ fprintf(stderr, "VM exhausted (in more_handlers)\n");
EXIT(EXIT_FAILURE);
}
for(i = nHandlers; i <= sig; i++)
# ifdef _POSIX_SOURCE
static void
-generic_handler(sig)
+generic_handler(int sig)
{
sigset_t signals;
SAVE_Hp = SAVE_HpLim; /* Just to be safe */
- if (initStacks(&StorageMgrInfo) != 0) {
+ if (! initStacks(&StorageMgrInfo)) {
fflush(stdout);
fprintf(stderr, "initStacks failed!\n");
EXIT(EXIT_FAILURE);
static sigset_t savedSignals;
void
-initUserSignals()
+initUserSignals(void)
{
sigemptyset(&userSignals);
}
void
-blockUserSignals()
+blockUserSignals(void)
{
sigprocmask(SIG_SETMASK, &userSignals, &savedSignals);
}
void
-unblockUserSignals()
+unblockUserSignals(void)
{
sigprocmask(SIG_SETMASK, &savedSignals, NULL);
}
sigemptyset(&action.sa_mask);
action.sa_flags = sig == SIGCHLD && nocldstop ? SA_NOCLDSTOP : 0;
+
if (sigaction(sig, &action, NULL) || sigprocmask(SIG_UNBLOCK, &signals, NULL)) {
if (previous_spi)
freeStablePointer(handlers[sig]);
generic_handler(sig)
{
SAVE_Hp = SAVE_HpLim; /* Just to be safe */
- if (initStacks(&StorageMgrInfo) != 0) {
+ if (! initStacks(&StorageMgrInfo)) {
fflush(stdout);
fprintf(stderr, "initStacks failed!\n");
EXIT(EXIT_FAILURE);
static int savedSignals;
void
-initUserSignals()
+initUserSignals(void)
{
userSignals = 0;
}
void
-blockUserSignals()
+blockUserSignals(void)
{
savedSignals = sigsetmask(userSignals);
}
void
-unblockUserSignals()
+unblockUserSignals(void)
{
sigsetmask(savedSignals);
}
{
I_ previous_spi;
int mask;
- void (*handler)();
+ void (*handler)(int);
/* Block the signal until we figure out what to do */
/* Count on this to fail if the signal number is invalid */
return previous_spi;
}
-# endif /* POSIX */
+# endif /* !POSIX */
#endif /* PAR */
#include "rtsdefs.h"
-extern void PrintRednCountInfo(STG_NO_ARGS);
-extern I_ showRednCountStats;
+void PrintTickyInfo(STG_NO_ARGS);
#ifdef __DO_ARITY_CHKS__
I_ ExpectedArity;
fprintf(stderr, "Arity error: called with %ld args, should have been %ld\n",
ExpectedArity, n);
-#if defined(DO_REDN_COUNTING)
- if (showRednCountStats) {
- PrintRednCountInfo();
- }
+#if defined(TICKY_TICKY)
+ if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
#endif
EXIT(EXIT_FAILURE);
StackOverflow(STG_NO_ARGS)
{
fflush(stdout);
- StackOverflowHook(SM_word_stk_size * sizeof(W_)); /*msg*/
+ StackOverflowHook(RTSflags.GcFlags.stksSize * sizeof(W_)); /*msg*/
-#if defined(DO_REDN_COUNTING)
- if (showRednCountStats) {
- PrintRednCountInfo();
- }
+#if defined(TICKY_TICKY)
+ if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
#endif
EXIT(EXIT_FAILURE);
are turned into indirections to the common black hole (or blocking queue).
\begin{code}
-
-I_ squeeze_upd_frames = 1; /* now ON by default */
-
I_
SqueezeUpdateFrames(bottom, top, frame)
P_ bottom;
return 0;
if ((prev_frame = GRAB_SuB(frame)) <= bottom) {
-#if !defined(CONCURRENT) && defined(SM_DO_BH_UPDATE)
- if (!noBlackHoles)
+#if !defined(CONCURRENT)
+ if ( RTSflags.GcFlags.lazyBlackHoling )
UPD_BH(GRAB_UPDATEE(frame), BH_UPD_info);
#endif
return 0;
}
/*
- * Now, we're at the bottom. Frame points to the lowest update frame on the
- * stack, and its saved SuB actually points to the frame above. We have to walk
- * back up the stack, squeezing out empty update frames and turning the pointers
- * back around on the way back up.
+ * Now, we're at the bottom. Frame points to the lowest update
+ * frame on the stack, and its saved SuB actually points to the
+ * frame above. We have to walk back up the stack, squeezing out
+ * empty update frames and turning the pointers back around on the
+ * way back up.
*/
/*
- * The bottom-most frame has not been altered, and we never want to eliminate it
- * anyway. Just black hole the updatee and walk one step up
- * before starting to squeeze. When you get to the topmost frame,
- * remember that there are still some words above it that might
- * have to be moved.
+ * The bottom-most frame has not been altered, and we never want
+ * to eliminate it anyway. Just black hole the updatee and walk
+ * one step up before starting to squeeze. When you get to the
+ * topmost frame, remember that there are still some words above
+ * it that might have to be moved.
*/
-#if !defined(CONCURRENT) && defined(SM_DO_BH_UPDATE)
- if (!noBlackHoles)
+#if !defined(CONCURRENT)
+ if ( RTSflags.GcFlags.lazyBlackHoling )
UPD_BH(GRAB_UPDATEE(frame), BH_UPD_info);
#endif
prev_frame = frame;
frame = next_frame;
/*
- * Loop through all of the middle frames (everything except the very
- * bottom and the very top).
+ * Loop through all of the middle frames (everything except the
+ * very bottom and the very top).
*/
while ((next_frame = GRAB_SuB(frame)) != NULL) {
P_ sp;
/*
fprintf(stderr, "squeezing frame at %lx, ret %lx\n", frame,
GRAB_RET(frame));
- */
+ */
#ifdef CONCURRENT
/* Check for a blocking queue on the node that's going away */
}
#endif
- UPD_EXISTING(); /* ticky stuff (NB: nothing for spat-profiling) */
+ UPD_SQUEEZED(); /* ticky stuff (NB: nothing for spat-profiling) */
UPD_IND(updatee_bypass, updatee_keep);
sp = frame - BREL(1); /* Toss the current frame */
displacement += STD_UF_SIZE;
} else {
-#if !defined(CONCURRENT) && defined(SM_DO_BH_UPDATE)
- if (!noBlackHoles)
+#if !defined(CONCURRENT)
+ if ( RTSflags.GcFlags.lazyBlackHoling )
UPD_BH(GRAB_UPDATEE(frame), BH_UPD_info);
#endif
if (displacement > 0) {
P_ next_frame_bottom = next_frame + BREL(STD_UF_SIZE);
- /*
+ /*
fprintf(stderr, "sliding [%lx, %lx] by %d\n", sp, next_frame_bottom,
displacement);
*/
}
/*
- * Now handle the topmost frame. Patch SuB, black hole the updatee,
- * and slide down.
+ * Now handle the topmost frame. Patch SuB, black hole the
+ * updatee, and slide down.
*/
PUSH_SuB(frame, prev_frame);
-#if !defined(CONCURRENT) && defined(SM_DO_BH_UPDATE)
- if (!noBlackHoles)
+#if !defined(CONCURRENT)
+ if ( RTSflags.GcFlags.lazyBlackHoling )
UPD_BH(GRAB_UPDATEE(frame), BH_UPD_info);
#endif
}
return displacement;
}
-
\end{code}
%************************************************************************
SET_TASK_ACTIVITY(ST_OVERHEAD);
- /*
- * fprintf(stderr,"StackOverflow:liveness=%lx,a=%lx,b=%lx\n",
- * liveness,words_of_a,words_of_b);
- */
+ /*?/
+ fprintf(stderr,"StackOverflow:liveness=%lx,a=%lx,b=%lx\n",
+ liveness,words_of_a,words_of_b);
+ /?*/
old_stko = SAVE_StkO;
- /*
- * fprintf(stderr, "SpA %lx SuA %lx SpB %lx SuB %lx\n", STKO_SpA(old_stko),
- * STKO_SuA(old_stko), STKO_SpB(old_stko), STKO_SuB(old_stko));
- */
+ /*?/
+ fprintf(stderr, "stko: %lx SpA %lx SuA %lx SpB %lx SuB %lx\n",
+ old_stko, STKO_SpA(old_stko),
+ STKO_SuA(old_stko), STKO_SpB(old_stko), STKO_SuB(old_stko));
+ /?*/
+
+ if (RTSflags.GcFlags.squeezeUpdFrames) {
- if (squeeze_upd_frames) {
i = SqueezeUpdateFrames(STKO_BSTK_BOT(old_stko), STKO_SpB(old_stko),
- STKO_SuB(old_stko));
+ STKO_SuB(old_stko));
+
STKO_SuB(old_stko) += BREL(i);
STKO_SpB(old_stko) += BREL(i);
+
+ /*?/ fprintf(stderr, "Just squeezed; now: SpB %lx SuB %lx retval %d\n", STKO_SpB(old_stko), STKO_SuB(old_stko), i); /?*/
+
if ((P_) STKO_SpA(old_stko) - AREL(headroom) > STKO_SpB(old_stko)) {
- /*
- * fprintf(stderr, "SpA %lx SpB %lx headroom %d\n", STKO_SpA(old_stko),
- * STKO_SpB(old_stko), headroom);
- */
+ /*?/
+ fprintf(stderr, "Squeezed; now: SpA %lx SpB %lx headroom %d\n", STKO_SpA(old_stko),
+ STKO_SpB(old_stko), headroom);
+ /?*/
/* We saved enough space to continue on the old StkO */
return 0;
}
SAVE_Liveness = liveness;
+ ASSERT(sanityChk_StkO(old_stko));
+
/* Double the stack chunk size each time we grow the stack */
+ /*?/ fprintf(stderr, "Stko %lx: about to double stk-chk size from %d...\n", old_stko, STKO_CLOSURE_CTS_SIZE(old_stko)); /?*/
cts_size = STKO_CLOSURE_CTS_SIZE(old_stko) * 2;
if (SAVE_Hp + STKO_HS + cts_size > SAVE_HpLim) {
* Even in the uniprocessor world, we may have to reenter node in case
* node is a selector shorted out by GC.
*/
- assert(liveness & LIVENESS_R1);
+ ASSERT(liveness & LIVENESS_R1);
TSO_PC2(CurrentTSO) = EnterNodeCode;
really_reenter_node = 1;
}
+ /*?/ fprintf(stderr, "StkO %lx: stk-chk GC: size %d...\n", old_stko, STKO_HS + cts_size);/?*/
ReallyPerformThreadGC(STKO_HS + cts_size, rtsFalse);
+ /*
+ now, GC semantics promise to have left SAVE_Hp with
+ the requested space *behind* it; as we will bump
+ SAVE_Hp just below, we had better first put it back.
+ (PS: Finding this was a two-day bug-hunting trip...)
+ Will & Phil 95/10
+ */
+ SAVE_Hp -= STKO_HS + cts_size;
+
old_stko = SAVE_StkO;
}
ALLOC_STK(STKO_HS, cts_size, 0);
SAVE_Hp += STKO_HS + cts_size;
SET_STKO_HDR(new_stko, StkO_info, CCC);
+ /*?/ fprintf(stderr, "New StkO now %lx...\n", new_stko); /?*/
+
/* Initialize the StkO, as in NewThread */
STKO_SIZE(new_stko) = cts_size + STKO_VHS;
STKO_SpB(new_stko) = STKO_SuB(new_stko) = STKO_BSTK_BOT(new_stko) + BREL(1);
STKO_SpA(new_stko) = STKO_SuA(new_stko) = STKO_ASTK_BOT(new_stko) + AREL(1);
STKO_LINK(new_stko) = old_stko;
+ /*?/ fprintf(stderr, "New StkO SpA = %lx...\n", STKO_SpA(new_stko) ); /?*/
+
STKO_RETURN(new_stko) = SAVE_Ret;
#ifdef PAR
* When we fall off of the top stack segment, we will either be
* returning an algebraic data type, in which case R2 holds a
* valid info ptr, or we will be returning a primitive
- * (e.g. int#), in which case R2 is garbage. If we need to perform
+ * (e.g. Int#), in which case R2 is garbage. If we need to perform
* GC to pull in the lower stack segment (this should only happen
* because of task migration), then we need to know the register
* liveness for the algebraic returns. We get the liveness out of
STKO_SpA(old_stko) += AREL(words_of_a);
STKO_SpB(old_stko) += BREL(words_of_b);
-#ifdef DO_REDN_COUNTING
+#ifdef TICKY_TICKY
/* Record the stack depths in chunks below the new stack object */
STKO_ADEP(new_stko) = STKO_ADEP(old_stko) +
#endif
if (STKO_SpB(old_stko) < STKO_BSTK_BOT(old_stko)) {
-
/*
- * This _should_ only happen if PAP_entry fails a stack check and there is
- * no update frame on the current stack. We can deal with this by storing a
- * function's argument requirements in its info table, peering into the PAP
- * (it had better be in R1) for the function pointer and taking only the
- * necessary number of arguments, but this would be hard, so we haven't done
- * it.
+ * This _should_ only happen if PAP_entry fails a stack check
+ * and there is no update frame on the current stack. We can
+ * deal with this by storing a function's argument
+ * requirements in its info table, peering into the PAP (it
+ * had better be in R1) for the function pointer and taking
+ * only the necessary number of arguments, but this would be
+ * hard, so we haven't done it.
*/
fflush(stdout);
- fprintf(stderr, "StackOverflow too deep. Probably a PAP with no update frame.\n");
+ fprintf(stderr, "StackOverflow too deep (SpB=%lx, Bstk bot=%lx). Probably a PAP with no update frame.\n", STKO_SpB(old_stko), STKO_BSTK_BOT(old_stko));
abort(); /* an 'abort' may be overkill WDP 95/04 */
}
/* Move A stack words from old StkO to new StkO */
P_ frame = STKO_SuB(new_stko) - BREL(STD_UF_SIZE);
/*
- * fprintf(stderr, "Stolen update frame: (old %lx, new %lx) SuA %lx, SuB
- * %lx, return %lx\n", old_stko, new_stko, GRAB_SuA(frame), GRAB_SuB(frame),
- * GRAB_RET(frame));
+ fprintf(stderr, "Stolen update frame: (old %lx, new %lx) SuA %lx, SuB
+ %lx, return %lx\n", old_stko, new_stko, GRAB_SuA(frame), GRAB_SuB(frame),
+ GRAB_RET(frame));
*/
STKO_SuA(old_stko) = GRAB_SuA(frame);
STKO_SuB(new_stko) = frame;
}
+
+ ASSERT(sanityChk_StkO(new_stko));
+
SAVE_StkO = new_stko;
+
return really_reenter_node;
}
\end{code}
/* Ditto for the unused Stable Pointer info table. [ADR]
*/
-extern void raiseError PROTO((StgStablePtr));
-extern StgStablePtr errorHandler;
+void raiseError PROTO((StgStablePtr));
+extern StgStablePtr errorHandler; /* NB: prone to magic-value-ery (WDP 95/12) */
/* Unused Stable Pointer (ie unused slot in a stable pointer table) */
STATICFUN(UnusedSP_entry)
FE_
}
-STATIC_ITBL(UnusedSP_static_info,UnusedSP_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,IF_,CON_K,"UNUSED STABLE PTR","USP");
+STATIC_ITBL(UnusedSP_info,UnusedSP_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,IF_,CON_K,"UNUSED STABLE PTR","USP");
-SET_STATIC_HDR(UnusedSP_closure,UnusedSP_static_info,CC_SUBSUMED,,ED_RO_)
+SET_STATIC_HDR(UnusedSP_closure,UnusedSP_info,CC_SUBSUMED,,ED_RO_)
};
/* Entry point and Info table for Stable Pointer Table. */
+STATICFUN(EmptyStablePointerTable_entry)
+{
+ FB_
+ /* Don't wrap the calls; we're done with STG land */
+ fflush(stdout);
+ fprintf(stderr, "Entered *empty* stable pointer table---this shouldn't happen!\n");
+ abort();
+ FE_
+}
+
STATICFUN(StablePointerTable_entry)
{
FB_
FE_
}
-STATIC_ITBL(EmptyStablePointerTable_static_info,StablePointerTable_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,IF_,SPT_K,"SP_TABLE","SP_TABLE");
+STATIC_ITBL(EmptyStablePointerTable_info,EmptyStablePointerTable_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,IF_,SPT_K,"SP_TABLE","SP_TABLE");
/* ToDo: could put a useful tag in there!!! */
DYN_ITBL(StablePointerTable_info,StablePointerTable_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,IF_,SPT_K,"SP_TABLE","SP_TABLE");
overflow will trigger creation of a table of useful size.
*/
-SET_STATIC_HDR(EmptySPTable_closure,EmptyStablePointerTable_static_info,CC_SUBSUMED,,ED_RO_)
+SET_STATIC_HDR(EmptySPTable_closure,EmptyStablePointerTable_info,CC_SUBSUMED,,ED_RO_)
, (W_) DYN_VHS + 0 + 1 + 0 /* size = DYN_VHS + n + 1 + n with n = 0 */
, (W_) 0 /* number of ptrs */
, (W_) 0 /* top of stack */
up to date, and is used to load the STG registers.
*/
-#if defined (DO_SPAT_PROFILING)
- SET_ACTIVITY(ACT_REDN); /* init: do this first, so we count the restore insns */
-#endif
-
RestoreAllStgRegs(); /* inline! */
/* ------- STG registers are now valid! -------------------------*/
default:
/* Don't wrap the calls; we're done with STG land */
fflush(stdout);
- fprintf(stderr,"ErrorIO: %x unknown\n", TSO_TYPE(CurrentTSO));
+ fprintf(stderr,"ErrorIO: %lx unknown\n", TSO_TYPE(CurrentTSO));
EXIT(EXIT_FAILURE);
}
STKO_LINK(StkOReg) = Nil_closure;
STKO_RETURN(StkOReg) = NULL;
-#ifdef DO_REDN_COUNTING
+#ifdef TICKY_TICKY
STKO_ADEP(StkOReg) = STKO_BDEP(StkOReg) = 0;
#endif
SaveAllStgRegs(); /* inline! */
- if ( initStacks( &StorageMgrInfo ) != 0) {
+ if (! initStacks( &StorageMgrInfo )) {
/* Don't wrap the calls; we're done with STG land */
fflush(stdout);
fprintf(stderr, "initStacks failed!\n");
}
/* info table */
-STATIC_ITBL(STK_STUB_static_info,STK_STUB_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,EF_,INTERNAL_KIND,"STK_STUB","STK_STUB");
+STATIC_ITBL(STK_STUB_info,STK_STUB_entry,UpdErr,0,INFO_OTHER_TAG,0,0,const,EF_,INTERNAL_KIND,"STK_STUB","STK_STUB");
/* closure */
-SET_STATIC_HDR(STK_STUB_closure,STK_STUB_static_info,CC_SUBSUMED,,EXTDATA_RO)
+SET_STATIC_HDR(STK_STUB_closure,STK_STUB_info,CC_SUBSUMED,,EXTDATA_RO)
, (W_)0, (W_)0
};
\end{code}
ToDo: Explicit cost centres in prelude for Input and Output costs.
\begin{code}
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
STGFUN(startCcRegisteringWorld)
{
QP_Event1("GR", CurrentTSO);
}
#ifdef PAR
- if(do_gr_profile) {
+ if(RTSflags.ParFlags.granSimStats) {
/* Note that CURRENT_TIME may perform an unsafe call */
TIME now = CURRENT_TIME;
TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
QP_Event1("GR", CurrentTSO);
}
- if(do_gr_profile) {
+ if(RTSflags.ParFlags.granSimStats) {
/* Note that CURRENT_TIME may perform an unsafe call */
TIME now = CURRENT_TIME;
TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
%* *
%************************************************************************
-The normal way of entering a thread is through resumeThread, which
-short-circuits and indirections to the TSO and StkO, sets up STG registers,
-and jumps to the saved PC.
+The normal way of entering a thread is through \tr{resumeThread},
+which short-circuits any indirections to the TSO and StkO, sets up STG
+registers, and jumps to the saved PC.
\begin{code}
-
STGFUN(resumeThread)
{
FB_
- while((P_) INFO_PTR(CurrentTSO) == Ind_info) {
+ while(IS_INDIRECTION(INFO_PTR(CurrentTSO))) {
CurrentTSO = (P_) IND_CLOSURE_PTR(CurrentTSO);
}
#ifdef PAR
- if (do_gr_profile) {
+ if (RTSflags.ParFlags.granSimStats) {
TSO_QUEUE(CurrentTSO) = Q_RUNNING;
/* Note that CURRENT_TIME may perform an unsafe call */
TSO_BLOCKEDAT(CurrentTSO) = CURRENT_TIME;
CurrentRegTable = TSO_INTERNAL_PTR(CurrentTSO);
- while((P_) INFO_PTR(SAVE_StkO) == Ind_info) {
+ while(IS_INDIRECTION(INFO_PTR(SAVE_StkO))) {
SAVE_StkO = (P_) IND_CLOSURE_PTR(SAVE_StkO);
}
RestoreAllStgRegs();
SET_TASK_ACTIVITY(ST_REDUCING);
- SET_ACTIVITY(ACT_REDN); /* back to normal reduction */
RESTORE_CCC(TSO_CCC(CurrentTSO));
JMP_(TSO_PC1(CurrentTSO));
FE_
}
-
\end{code}
Since we normally context switch during a heap check, it is possible
stashed away the heap requirements in @TSO_ARG1@ so that we can decide
whether or not to perform a garbage collection before resuming the
thread. The actual thread resumption address (either @EnterNodeCode@
-or elsewhere) is stashed in TSO_PC2.
+or elsewhere) is stashed in @TSO_PC2@.
\begin{code}
-
STGFUN(CheckHeapCode)
{
FB_
ALLOC_HEAP(TSO_ARG1(CurrentTSO)); /* ticky profiling */
- SET_ACTIVITY(ACT_HEAP_CHK); /* SPAT counting */
if ((Hp += TSO_ARG1(CurrentTSO)) > HpLim) {
ReallyPerformThreadGC(TSO_ARG1(CurrentTSO), rtsFalse);
JMP_(resumeThread);
}
SET_TASK_ACTIVITY(ST_REDUCING);
- SET_ACTIVITY(ACT_REDN); /* back to normal reduction */
RESUME_(TSO_PC2(CurrentTSO));
FE_
}
-
\end{code}
Often, a thread starts (or rather, resumes) by entering the closure
want this to happen upon resumption of the thread.
\begin{code}
-
STGFUN(EnterNodeCode)
{
FB_
JMP_(ENTRY_CODE(InfoPtr));
FE_
}
-
\end{code}
-Then, there are the occasions when we just want to pick up where we left off.
-We use RESUME_ here instead of JMP_, because when we return to a call site,
-the alpha is going to try to load %gp from %ra rather than %pv, and JMP_ only
-sets %pv. Resuming to the start of a function is currently okay, but an
-extremely bad practice. As we add support for more architectures, we can expect
-the difference between RESUME_ and JMP_ to become more acute.
+Then, there are the occasions when we just want to pick up where we
+left off. We use \tr{RESUME_} here instead of \tr{JMP_}, because when
+we return to a call site, the Alpha is going to try to load \tr{%gp}
+from \tr{%ra} rather than \tr{%pv}, and \tr{JMP_} only sets \tr{%pv}.
+Resuming to the start of a function is currently okay, but an
+extremely bad practice. As we add support for more architectures, we
+can expect the difference between \tr{RESUME_} and \tr{JMP_} to become
+more acute.
\begin{code}
-
STGFUN(Continue)
{
FB_
SET_TASK_ACTIVITY(ST_REDUCING);
- SET_ACTIVITY(ACT_REDN); /* back to normal reduction */
RESUME_(TSO_PC2(CurrentTSO));
FE_
}
-
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-
-extern P_ AvailableStack;
-
#ifndef PAR
-
\end{code}
On a uniprocessor, stack underflow causes us no great headaches. The
FB_
temp = STKO_LINK(StkOReg);
+
+ /* fprintf(stderr,"Stk Underflow from: %lx to: %lx size abandoned: %d\n",StkOReg,temp,STKO_CLOSURE_CTS_SIZE(StkOReg)); */
+
+ /* change the guy we are abandoning into something
+ that will not be "interesting" on the mutables
+ list. (As long as it is there, it will be
+ scavenged in GC, and we cannot guarantee that
+ it is still a "sane" StkO object). (And, besides,
+ why continue to keep it [and all it pts to] alive?)
+ Will & Phil 95/10
+ */
+ FREEZE_MUT_HDR(StkOReg, ImMutArrayOfPtrs_info);
+ MUTUPLE_CLOSURE_SIZE(StkOReg) = MUTUPLE_VHS;
+
StkOReg = temp;
/* ToDo: Fetch the remote stack object here! */
RestoreStackStgRegs();
+++ /dev/null
-\begin{code}
-
-#include "rtsdefs.h"
-
-#if defined(DO_RUNTIME_TRACE_UPDATES)
-
-/********** Debugging Tracing of Updates ***********/
-
-/* These will only be called if StgUpdate.h macro calls
- compiled with -DDO_RUNTIME_TRACE_UPDATES
- */
-
-extern I_ traceUpdates; /* a Bool, essentially */
-
-void
-TRACE_UPDATE_Ind(updclosure,heapptr)
-P_ updclosure,heapptr;
-{
-#if defined(GCap)
- if (traceUpdates) {
- fprintf(stderr,"Upd Ind %s Gen: 0x%lx -> 0x%lx\n",
- (updclosure) <= StorageMgrInfo.OldLim ? "Old" : "New",
- (W_) updclosure, (W_) heapptr);
- }
-#else
- if (traceUpdates) {
- fprintf(stderr,"Upd Ind: 0x%lx -> 0x%lx\n",
- (W_) updclosure, (W_) heapptr);
- }
-#endif
-}
-
-void
-TRACE_UPDATE_Inplace_NoPtrs(updclosure)
-P_ updclosure;
-{
-#if defined(GCap)
- if (traceUpdates) {
- fprintf(stderr,"Upd Inplace %s Gen: 0x%lx\n",
- (updclosure) <= StorageMgrInfo.OldLim ? "Old" : "New",
- (W_) updclosure);
- }
-#else
- if (traceUpdates) {
- fprintf(stderr,"Upd Inplace: 0x%lx\n", (W_) updclosure);
- }
-#endif
-}
-
-void
-TRACE_UPDATE_Inplace_Ptrs(updclosure, hp)
-P_ updclosure;
-P_ hp;
-{
-#if defined(GCap)
- if (traceUpdates) {
- if ((updclosure) <= StorageMgrInfo.OldLim) {
- fprintf(stderr,"Upd Redirect Old Gen (Ptrs): 0x%lx -> 0x%lx\n",
- (W_) updclosure,
- (W_) (hp + 1));
- } else {
- fprintf(stderr,"Upd Inplace New Gen (Ptrs): 0x%lx\n", (W_) updclosure);
- }
- }
-#else
- if (traceUpdates) {
- fprintf(stderr,"Update Inplace: 0x%lx\n", (W_) updclosure);
- }
-#endif
-}
-
-#endif /* DO_RUNTIME_TRACE_UPDATES */
-
-\end{code}
EXTDATA(Nil_closure);
-#if defined(DO_REDN_COUNTING)
-extern void PrintRednCountInfo(STG_NO_ARGS);
-extern I_ showRednCountStats;
+#if defined(TICKY_TICKY)
+void PrintTickyInfo(STG_NO_ARGS);
#endif
\end{code}
{
FB_
ENT_IND(Node); /* Ticky-ticky profiling info */
- SET_ACTIVITY(ACT_INDIRECT); /* SPAT profiling */
Node = (P_) IND_CLOSURE_PTR((P_) Node);
ENT_VIA_NODE();
}
IND_ITBL(Ind_info,Ind_entry,const,EF_);
-
\end{code}
We also need a special @CAF@ indirection info table which is used to
{
FB_
ENT_IND(Node);
- SET_ACTIVITY(ACT_INDIRECT); /* SPAT profiling */
Node = (P_) IND_CLOSURE_PTR((P_) Node);
ENT_VIA_NODE();
EXTFUN(StackUnderflowEnterNode);
EXTDATA_RO(BQ_info);
#else
-extern StgStablePtr errorHandler;
-extern void raiseError PROTO((StgStablePtr));
+void raiseError PROTO((StgStablePtr));
+extern StgStablePtr errorHandler; /* NB: prone to magic-value-ery (WDP 95/12) */
#endif
STGFUN(BH_UPD_entry)
(void) STGCALL1(int,(void *, FILE *),fflush,stdout);
(void) STGCALL2(int,(),fprintf,stderr,"Entered a `black hole': the program has a cyclic data dependency.\n");
-# if defined(USE_COST_CENTRES)
+# if defined(PROFILING)
{
CostCentre cc = (CostCentre) CC_HDR(Node);
(void) STGCALL5(int,(),fprintf,stderr,"Cost Centre: %s Module: %s Group %s\n",cc->label, cc->module, cc->group);
}
# endif
-# if defined(DO_REDN_COUNTING)
- if (showRednCountStats) {
- (void) STGCALL0(void,(),PrintRednCountInfo);
+# if defined(TICKY_TICKY)
+ if (RTSflags.TickyFlags.showTickyStats) {
+ (void) STGCALL0(void,(),PrintTickyInfo);
}
# endif
}
# ifdef PAR
- if(do_gr_profile) {
+ if(RTSflags.ParFlags.granSimStats) {
TIME now = CURRENT_TIME;
TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
TSO_BLOCKCOUNT(CurrentTSO)++;
# endif
FE_
+
#endif /* threads */
}
(void) STGCALL2(int,(),fprintf,stderr,"either the compiler made a mistake on single-entryness,\n");
(void) STGCALL2(int,(),fprintf,stderr,"or the program has a cyclic data dependency.\n");
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
{
CostCentre cc = (CostCentre) CC_HDR(Node);
(void) STGCALL5(int,(),fprintf,stderr, "Cost Centre: %s Module: %s Group %s\n",cc->label, cc->module, cc->group);
}
#endif
-# if defined(DO_REDN_COUNTING)
- if (showRednCountStats) {
- (void) STGCALL0(void,(),PrintRednCountInfo);
+# if defined(TICKY_TICKY)
+ if (RTSflags.TickyFlags.showTickyStats) {
+ (void) STGCALL0(void,(),PrintTickyInfo);
}
# endif
%* *
%************************************************************************
-Here is the standard update code for objects that are returned in the heap
-(or those which are initially returned in registers, but have already been
-allocated in the heap earlier in the update chain.) In either case, Node
-points to the heap object. The update code grabs the address of the updatee
-out of the partial update frame (the return address has already been popped),
-makes the updatee an indirection to Node, and returns according to the convention
-for the constructor.
+Here is the standard update code for objects that are returned in the
+heap (or those which are initially returned in registers, but have
+already been allocated in the heap earlier in the update chain). In
+either case, @Node@ points to the heap object. The update code grabs
+the address of the updatee out of the partial update frame (the return
+address has already been popped), makes the updatee an indirection to
+@Node@, and returns according to the convention for the constructor.
\begin{code}
-#define IND_UPD_TEMPLATE(label, retvector) \
- STGFUN(label) \
- { \
- FB_ \
- UPD_EXISTING(); /* Ticky-ticky profiling info */ \
- /* Update thing off stk with an indirection to Node */ \
- UPD_IND(GRAB_UPDATEE(SpB), Node); \
- /* Pop the standard update frame */ \
- POP_STD_UPD_FRAME() \
- \
- JMP_(retvector); \
- FE_ \
+#define IND_UPD_TEMPLATE(label, retvector) \
+ STGFUN(label) \
+ { \
+ FB_ \
+ UPD_EXISTING(); /* Ticky-ticky profiling info */ \
+ /* Update thing off stk with an indirection to Node */ \
+ UPD_IND(GRAB_UPDATEE(SpB), Node); \
+ /* Pop the standard update frame */ \
+ POP_STD_UPD_FRAME() \
+ \
+ JMP_(retvector); \
+ FE_ \
}
IND_UPD_TEMPLATE(IndUpdRetDir, DIRECT(((P_)RetReg)))
IND_UPD_TEMPLATE(IndUpdRetV5, ((P_)RetReg)[RVREL(5)])
IND_UPD_TEMPLATE(IndUpdRetV6, ((P_)RetReg)[RVREL(6)])
IND_UPD_TEMPLATE(IndUpdRetV7, ((P_)RetReg)[RVREL(7)])
-
\end{code}
%************************************************************************
occupied by it as it would not reside in the heap during normal
execution.
+In ticky-land: If we are trying to collect update-entry counts
+(controlled by an RTS flag), then we must use permanent indirections
+(the shorting-out of regular indirections loses the counts).
+
\begin{code}
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING) || defined(TICKY_TICKY)
STGFUN(Perm_Ind_entry)
{
/* Don't add INDs to granularity cost */
- ENT_IND(Node); /* Ticky-ticky profiling info */
+ /* Dont: ENT_IND(Node); for ticky-ticky; this ind is here only to help ticky */
/* Enter PAP cost centre -- lexical scoping only */
ENTER_CC_PAP_CL(Node);
Node = (P_) IND_CLOSURE_PTR((P_) Node);
- ENT_VIA_NODE(); /* Ticky-ticky profiling info */
+
+ /* Dont: ENT_VIA_NODE(); for ticky-ticky; as above */
InfoPtr=(D_)(INFO_PTR(Node));
+
# if defined(GRAN)
GRAN_EXEC(1,1,2,0,0);
# endif
PERM_IND_ITBL(Perm_Ind_info,Perm_Ind_entry,const,EF_);
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING or TICKY */
\end{code}
%************************************************************************
\end{itemize}
\begin{code}
-
STGFUN(UpdatePAP)
{
/*
#define NPtrWords (R3.i)
#define NArgWords (R4.i)
#define PapSize (R5.i)
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
# define CC_pap ((CostCentre)(R7.p))
#endif
++nPAPs;
#endif
- SET_ACTIVITY(ACT_UPDATE_PAP); /* SPAT profiling */
-
NPtrWords = AREL(SuA - SpA);
NNonPtrWords = BREL(SuB - SpB);
NArgWords = NPtrWords + NNonPtrWords + 1; /* +1 for Node */
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
/* set "CC_pap" to go in the updatee (see Sansom thesis, p 183) */
CC_pap /*really cc_enter*/ = (CostCentre) CC_HDR(Node);
/* Allocate PapClosure -- Only Node (R1) is live */
HEAP_CHK(LIVENESS_R1, PapSize, 0);
- SET_ACTIVITY(ACT_UPDATE_PAP); /* back to it (for SPAT profiling) */
-
PapClosure = Hp + 1 - PapSize; /* The new PapClosure */
SET_DYN_HDR(PapClosure, PAP_info, CC_pap, NArgWords + DYN_VHS, NPtrWords + 1);
p = Hp;
for (i = NNonPtrWords - 1; i >= 0; i--) *p-- = (W_) SpB[BREL(i)];
- for (i = NPtrWords - 1; i >= 0; i--) *p-- = (W_) SpA[AREL(i)];
+ for (i = NPtrWords - 1; i >= 0; i--) *p-- = (W_) SpA[AREL(i)];
*p = (W_) Node;
}
/*
- * Finished constructing PAP closure; now update the updatee.
- * But wait! What if there is no updatee? Then we fall off the stack.
+ * Finished constructing PAP closure; now update the updatee. But
+ * wait! What if there is no updatee? Then we fall off the
+ * stack.
*/
#ifdef CONCURRENT
UPD_IND(Updatee, PapClosure); /* Indirect Updatee to PapClosure */
if (NArgWords != 1) {
- UPD_PAP_IN_NEW();
+ UPD_PAP_IN_NEW(NArgWords);
} else {
UPD_PAP_IN_PLACE();
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
/*
* Lexical scoping requires a *permanent* indirection, and we
* also have to set the cost centre for the indirection.
INFO_PTR(Updatee) = (W_) Perm_Ind_info;
SET_CC_HDR(Updatee, CC_pap);
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING */
}
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
/*
* Restore the Cost Centre too (if required); again see Sansom thesis p 183.
* Take the CC out of the update frame if a CAF/DICT.
CCC = (IS_CAF_OR_DICT_CC(CC_pap)) ? GRAB_COST_CENTRE(SuB) : CC_pap;
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING */
/* Restore SuA, SuB, RetReg */
RetReg = GRAB_RET(SuB);
#undef NPtrWords
#undef NArgWords
#undef PapSize
-#ifdef USE_COST_CENTRES
+#ifdef PROFILING
# undef CC_pap
#endif
}
/* Use STG registers for these locals which must survive the STK_CHK */
#define NPtrWords (R2.i)
#define NNonPtrWords (R3.i)
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
# define CC_pap ((CostCentre)(R7.p))
#endif
- /* These locals don't have to survive a HEAP_CHK */
+ /* These locals don't have to survive the STK_CHK */
P_ Updatee;
P_ p;
I_ i;
FB_
- SET_ACTIVITY(ACT_UPDATE_PAP); /* SPAT profiling */
-
while (AREL(SuA - SpA) == 0 && BREL(SuB - SpB) == 0) {
#ifdef CONCURRENT
if (SuB < STKO_BSTK_BOT(StkOReg)) {
Updatee = GRAB_UPDATEE(SuB);
UPD_IND(Updatee, Node);
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
/*
- * Restore the Cost Centre too (if required); again see Sansom thesis p 183.
- * Take the CC out of the update frame if a CAF/DICT.
- */
+ * Restore the Cost Centre too (if required); again see Sansom
+ * thesis p 183. Take the CC out of the update frame if a
+ * CAF/DICT.
+ */
CC_pap = (CostCentre) CC_HDR(Node);
CCC = (IS_CAF_OR_DICT_CC(CC_pap)) ? GRAB_COST_CENTRE(SuB) : CC_pap;
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING */
RetReg = GRAB_RET(SuB);
SuA = GRAB_SuA(SuB);
#undef NPtrWords
#undef NNonPtrWords
-#ifdef USE_COST_CENTRES
+#ifdef PROFILING
# undef CC_pap
#endif
}
@AvailableStack@ is used to determine whether an existing stack can be
reused without new allocation, so reducing garbage collection, and
stack setup time. At present, it is only used for the first stack
-chunk of a thread, the one that's got @StkOChunkSize@ words.
+chunk of a thread, the one that's got
+@RTSflags.ConcFlags.stkChunkSize@ words.
\begin{code}
P_ AvailableStack = Nil_closure;
/* mattson thinks this is obsolete */
# if 0 && defined(GRAN)
-extern FILE *main_statsfile; /* Might be of general interest HWL */
typedef unsigned long TIME;
typedef unsigned char PROC;
BQ_lens = 0;
# endif
-I_ do_gr_binary = 0;
-I_ do_gr_profile = 0; /* Full .gr profile or only END events? */
I_ no_gr_profile = 0; /* Don't create any .gr file at all? */
I_ do_sp_profile = 0;
I_ do_gr_migration = 0;
if(EventHd == NULL)
{
fprintf(stderr,"No next event\n");
- exit(EXIT_FAILURE); /* ToDo: abort()? EXIT??? */
+ exit(EXIT_FAILURE); /* ToDo: abort()? EXIT? */
}
if(entry != NULL)
P_ tso, node;
sparkq spark;
{
- extern P_ xmalloc();
- eventq newentry = (eventq) xmalloc(sizeof(struct event));
+ eventq newentry = (eventq) stgMallocBytes(sizeof(struct event), "newevent");
EVENT_PROC(newentry) = proc;
EVENT_CREATOR(newentry) = creator;
static jmp_buf scheduler_loop;
-I_ MaxThreads = DEFAULT_MAX_THREADS;
I_ required_thread_count = 0;
I_ advisory_thread_count = 0;
I_ context_switch = 0;
-I_ contextSwitchTime = CS_MIN_MILLISECS; /* In milliseconds */
-
#if !defined(GRAN)
I_ threadId = 0;
+I_ sparksIgnored =0;
-I_ MaxLocalSparks = DEFAULT_MAX_LOCAL_SPARKS;
I_ SparkLimit[SPARK_POOLS];
-extern I_ doSanityChks;
-extern void checkAStack(STG_NO_ARGS);
-
rtsBool
-initThreadPools(size)
-I_ size;
+initThreadPools(STG_NO_ARGS)
{
+ I_ size = RTSflags.ConcFlags.maxLocalSparks;
+
SparkLimit[ADVISORY_POOL] = SparkLimit[REQUIRED_POOL] = size;
+
if ((PendingSparksBase[ADVISORY_POOL] = (PP_) malloc(size * sizeof(P_))) == NULL)
return rtsFalse;
+
if ((PendingSparksBase[REQUIRED_POOL] = (PP_) malloc(size * sizeof(P_))) == NULL)
return rtsFalse;
+
PendingSparksLim[ADVISORY_POOL] = PendingSparksBase[ADVISORY_POOL] + size;
PendingSparksLim[REQUIRED_POOL] = PendingSparksBase[REQUIRED_POOL] + size;
return rtsTrue;
ScheduleThreads(topClosure)
P_ topClosure;
{
+#ifdef GRAN
I_ i;
+#endif
P_ tso;
-#if defined(USE_COST_CENTRES) || defined(GUM)
- if (time_profiling || contextSwitchTime > 0) {
- if (initialize_virtual_timer(tick_millisecs)) {
+#if defined(PROFILING) || defined(PAR)
+ if (time_profiling || RTSflags.ConcFlags.ctxtSwitchTime > 0) {
+ if (initialize_virtual_timer(RTSflags.CcFlags.msecsPerTick)) {
#else
- if (contextSwitchTime > 0) {
- if (initialize_virtual_timer(contextSwitchTime)) {
+ if (RTSflags.ConcFlags.ctxtSwitchTime > 0) {
+ if (initialize_virtual_timer(RTSflags.ConcFlags.ctxtSwitchTime)) {
#endif
fflush(stdout);
fprintf(stderr, "Can't initialize virtual timer.\n");
init_qp_profiling();
/*
- * We perform GC so that a signal handler can install a new TopClosure and start
- * a new main thread.
+ * We perform GC so that a signal handler can install a new
+ * TopClosure and start a new main thread.
*/
#ifdef PAR
if (IAmMainThread) {
#endif
#ifdef PAR
- if (do_gr_profile) {
+ if (RTSflags.ParFlags.granSimStats) {
DumpGranEvent(GR_START, tso);
sameThread = rtsTrue;
}
fprintf(stderr, "No runnable threads!\n");
EXIT(EXIT_FAILURE);
}
- AwaitEvent(0);
+ AwaitEvent(RTSflags.ConcFlags.ctxtSwitchTime);
}
#else
if (RunnableThreadsHd == Nil_closure) {
- if (advisory_thread_count < MaxThreads &&
+ if (advisory_thread_count < RTSflags.ConcFlags.maxThreads &&
(PendingSparksHd[REQUIRED_POOL] < PendingSparksTl[REQUIRED_POOL] ||
PendingSparksHd[ADVISORY_POOL] < PendingSparksTl[ADVISORY_POOL])) {
/*
- * If we're here (no runnable threads) and we have pending sparks,
- * we must have a space problem. Get enough space to turn one of
- * those pending sparks into a thread...ReallyPerformGC doesn't
- * return until the space is available, so it may force global GC.
- * ToDo: Is this unnecessary here? Duplicated in ReSchedule()? --JSM
+ * If we're here (no runnable threads) and we have pending
+ * sparks, we must have a space problem. Get enough space
+ * to turn one of those pending sparks into a
+ * thread... ReallyPerformGC doesn't return until the
+ * space is available, so it may force global GC. ToDo:
+ * Is this unnecessary here? Duplicated in ReSchedule()?
+ * --JSM
*/
ReallyPerformThreadGC(THREAD_SPACE_REQUIRED, rtsTrue);
SAVE_Hp -= THREAD_SPACE_REQUIRED;
} else {
/*
- * We really have absolutely no work. Send out a fish (there may be
- * some out there already), and wait for something to arrive. We
- * clearly can't run any threads until a SCHEDULE or RESUME arrives,
- * and so that's what we're hoping to see. (Of course, we still have
- * to respond to other types of messages.)
+ * We really have absolutely no work. Send out a fish
+ * (there may be some out there already), and wait for
+ * something to arrive. We clearly can't run any threads
+ * until a SCHEDULE or RESUME arrives, and so that's what
+ * we're hoping to see. (Of course, we still have to
+ * respond to other types of messages.)
*/
if (!fishing)
sendFish(choosePE(), mytid, NEW_FISH_AGE, NEW_FISH_HISTORY,
NEW_FISH_HUNGER);
+
processMessages();
}
ReSchedule(0);
}
#ifdef PAR
- if (do_gr_profile && !sameThread)
+ if (RTSflags.ParFlags.granSimStats && !sameThread)
DumpGranEvent(GR_SCHEDULE, RunnableThreadsHd);
#endif
#endif
/* If we're not running a timer, just leave the flag on */
- if (contextSwitchTime > 0)
+ if (RTSflags.ConcFlags.ctxtSwitchTime > 0)
context_switch = 0;
#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
}
#endif
-# if defined(__STG_TAILJUMPS__)
miniInterpret((StgFunPtr)resumeThread);
-# else
- if (doSanityChks)
- miniInterpret_debug((StgFunPtr)resumeThread, checkAStack);
- else
- miniInterpret((StgFunPtr)resumeThread);
-# endif /* __STG_TAILJUMPS__ */
}
\end{code}
/* This code does round-Robin, if preferred. */
if(DoFairSchedule && TSO_LINK(CurrentTSO) != Nil_closure)
{
- if(do_gr_profile)
+ if(RTSflags.ParFlags.granSimStats)
DumpGranEvent(GR_DESCHEDULE,ThreadQueueHd);
ThreadQueueHd = TSO_LINK(CurrentTSO);
TSO_LINK(ThreadQueueTl) = CurrentTSO;
ThreadQueueTl = CurrentTSO;
TSO_LINK(CurrentTSO) = Nil_closure;
- if (do_gr_profile)
+ if (RTSflags.ParFlags.granSimStats)
DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
CurrentTime[CurrentProc] += gran_threadcontextswitchtime;
}
}
#endif
- if(do_gr_profile)
+ if(RTSflags.ParFlags.granSimStats)
DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
CurrentTSO = ThreadQueueHd;
++TSO_FETCHCOUNT(EVENT_TSO(event));
TSO_FETCHTIME(EVENT_TSO(event)) += gran_fetchtime;
- if (do_gr_profile)
+ if (RTSflags.ParFlags.granSimStats)
DumpGranEventAndNode(GR_REPLY,EVENT_TSO(event),
EVENT_NODE(event),EVENT_CREATOR(event));
CONTINUETHREAD,Nil_closure,Nil_closure,NULL);
TSO_BLOCKTIME(EVENT_TSO(event)) += CurrentTime[CurrentProc] -
TSO_BLOCKEDAT(EVENT_TSO(event));
- if(do_gr_profile)
+ if(RTSflags.ParFlags.granSimStats)
DumpGranEvent(GR_RESUME,EVENT_TSO(event));
continue;
} else {
if(do_sp_profile)
DumpSparkGranEvent(SP_PRUNED,spark);
- assert(spark != NULL);
+ ASSERT(spark != NULL);
SparkQueueHd = SPARK_NEXT(spark);
if(SparkQueueHd == NULL)
newevent(CurrentProc,CurrentProc,CurrentTime[CurrentProc],
STARTTHREAD,tso,Nil_closure,NULL);
- assert(spark != NULL);
+ ASSERT(spark != NULL);
SparkQueueHd = SPARK_NEXT(spark);
if(SparkQueueHd == NULL)
#ifdef PAR
/*
* In the parallel world, we do unfair scheduling for the moment.
- * Ultimately, this should all be merged with the more sophicticated
- * GrAnSim scheduling options. (Of course, some provision should be
- * made for *required* threads to make sure that they don't starve,
- * but for now we assume that no one is running concurrent Haskell on
- * a multi-processor platform.)
+ * Ultimately, this should all be merged with the more
+ * sophisticated GrAnSim scheduling options. (Of course, some
+ * provision should be made for *required* threads to make sure
+ * that they don't starve, but for now we assume that no one is
+ * running concurrent Haskell on a multi-processor platform.)
*/
sameThread = again;
if (RunnableThreadsHd == Nil_closure) {
RunnableThreadsHd = tso;
#ifdef PAR
- if (do_gr_profile) {
+ if (RTSflags.ParFlags.granSimStats) {
DumpGranEvent(GR_START, tso);
sameThread = rtsTrue;
}
} else {
TSO_LINK(RunnableThreadsTl) = tso;
#ifdef PAR
- if (do_gr_profile)
+ if (RTSflags.ParFlags.granSimStats)
DumpGranEvent(GR_STARTQ, tso);
#endif
}
(RunnableThreadsHd != Nil_closure ||
(required_thread_count == 0 && IAmMainThread)) ||
#endif
- advisory_thread_count == MaxThreads ||
+ advisory_thread_count == RTSflags.ConcFlags.maxThreads ||
(tso = NewThread(spark, T_ADVISORY)) == NULL)
break;
advisory_thread_count++;
if (RunnableThreadsHd == Nil_closure) {
RunnableThreadsHd = tso;
#ifdef PAR
- if (do_gr_profile) {
+ if (RTSflags.ParFlags.granSimStats) {
DumpGranEvent(GR_START, tso);
sameThread = rtsTrue;
}
} else {
TSO_LINK(RunnableThreadsTl) = tso;
#ifdef PAR
- if (do_gr_profile)
+ if (RTSflags.ParFlags.granSimStats)
DumpGranEvent(GR_STARTQ, tso);
#endif
}
CurrentTSO = ThreadQueueHd = ThreadQueueTl = EVENT_TSO(event);
newevent(CurrentProc,CurrentProc,CurrentTime[CurrentProc]+gran_threadqueuetime,
CONTINUETHREAD,Nil_closure,Nil_closure,NULL);
- if(do_gr_profile)
+ if(RTSflags.ParFlags.granSimStats)
DumpGranEvent(event_type,EVENT_TSO(event));
}
else
if(DoThreadMigration)
++SurplusThreads;
- if(do_gr_profile)
+ if(RTSflags.ParFlags.granSimStats)
DumpGranEvent(event_type+1,EVENT_TSO(event));
}
MAKE_BUSY(proc);
--SurplusThreads;
- if(do_gr_profile)
+ if(RTSflags.ParFlags.granSimStats)
DumpRawGranEvent(p,GR_STEALING,TSO_ID(thread));
CurrentTime[p] += 5l * gran_mtidytime;
#if defined(GRAN)
-/* Slow but relatively reliable method uses xmalloc */
+/* Slow but relatively reliable method uses stgMallocBytes */
/* Eventually change that to heap allocated sparks. */
sparkq
P_ node;
I_ name, local;
{
- extern P_ xmalloc();
- sparkq newspark = (sparkq) xmalloc(sizeof(struct spark));
+ sparkq newspark = (sparkq) stgMallocBytes(sizeof(struct spark), "NewSpark");
+
SPARK_PREV(newspark) = SPARK_NEXT(newspark) = NULL;
SPARK_NODE(newspark) = node;
SPARK_NAME(newspark) = name;
#endif
-I_ StkOChunkSize = DEFAULT_STKO_CHUNK_SIZE;
-
/* Create a new TSO, with the specified closure to enter and thread type */
P_
}
TSO_LINK(tso) = Nil_closure;
+#ifdef PAR
TSO_CCC(tso) = (CostCentre)STATIC_CC_REF(CC_MAIN);
+#endif
TSO_NAME(tso) = (P_) INFO_PTR(topClosure); /* A string would be nicer -- JSM */
TSO_ID(tso) = threadId++;
TSO_TYPE(tso) = type;
TSO_ARG1(tso) = TSO_EVENT(tso) = 0;
TSO_SWITCH(tso) = NULL;
-#ifdef DO_REDN_COUNTING
+#ifdef TICKY_TICKY
TSO_AHWM(tso) = 0;
TSO_BHWM(tso) = 0;
#endif
SET_PROCS(stko,ThisPE);
#endif
AvailableStack = STKO_LINK(AvailableStack);
- } else if (SAVE_Hp + STKO_HS + StkOChunkSize > SAVE_HpLim) {
+ } else if (SAVE_Hp + STKO_HS + RTSflags.ConcFlags.stkChunkSize > SAVE_HpLim) {
return(NULL);
} else {
- ALLOC_STK(STKO_HS,StkOChunkSize,0);
+ ALLOC_STK(STKO_HS,RTSflags.ConcFlags.stkChunkSize,0);
stko = SAVE_Hp + 1;
- SAVE_Hp += STKO_HS + StkOChunkSize;
+ SAVE_Hp += STKO_HS + RTSflags.ConcFlags.stkChunkSize;
SET_STKO_HDR(stko, StkO_info, CCC);
}
- STKO_SIZE(stko) = StkOChunkSize + STKO_VHS;
+ STKO_SIZE(stko) = RTSflags.ConcFlags.stkChunkSize + STKO_VHS;
STKO_SpB(stko) = STKO_SuB(stko) = STKO_BSTK_BOT(stko) + BREL(1);
STKO_SpA(stko) = STKO_SuA(stko) = STKO_ASTK_BOT(stko) + AREL(1);
STKO_LINK(stko) = Nil_closure;
}
# endif
-#ifdef DO_REDN_COUNTING
+#ifdef TICKY_TICKY
STKO_ADEP(stko) = STKO_BDEP(stko) = 0;
#endif
SAVE_Ret = (StgRetAddr) UNVEC(stopThreadDirectReturn,vtbl_stopStgWorld);
SAVE_StkO = stko;
+ ASSERT(sanityChk_StkO(stko));
+
if (DO_QP_PROF) {
QP_Event1(do_qp_prof > 1 ? "*A" : "*G", tso);
}
#ifdef PAR
TIME now = CURRENT_TIME;
#endif
-#ifdef DO_REDN_COUNTING
- extern FILE *tickyfile;
-
- if (tickyfile != NULL) {
- fprintf(tickyfile, "Thread %d (%lx)\n\tA stack max. depth: %ld words\n",
- TSO_ID(CurrentTSO), TSO_NAME(CurrentTSO), TSO_AHWM(CurrentTSO));
- fprintf(tickyfile, "\tB stack max. depth: %ld words\n",
- TSO_BHWM(CurrentTSO));
+#ifdef TICKY_TICKY
+ if (RTSflags.TickyFlags.showTickyStats) {
+ fprintf(RTSflags.TickyFlags.tickyFile,
+ "Thread %d (%lx)\n\tA stack max. depth: %ld words\n",
+ TSO_ID(CurrentTSO), TSO_NAME(CurrentTSO), TSO_AHWM(CurrentTSO));
+ fprintf(RTSflags.TickyFlags.tickyFile,
+ "\tB stack max. depth: %ld words\n",
+ TSO_BHWM(CurrentTSO));
}
#endif
}
#if defined(GRAN)
- assert(CurrentTSO == ThreadQueueHd);
+ ASSERT(CurrentTSO == ThreadQueueHd);
ThreadQueueHd = TSO_LINK(CurrentTSO);
if(ThreadQueueHd == Nil_closure)
/* make the job of bookkeeping the running, runnable, */
/* blocked threads easier for scripts like gr2ps -- HWL */
- if (do_gr_profile && !is_first)
+ if (RTSflags.ParFlags.granSimStats && !is_first)
DumpRawGranEvent(i,GR_SCHEDULE,
TSO_ID(RunnableThreadsHd[i]));
if (!no_gr_profile)
/* Note ThreadQueueHd is Nil when the main thread terminates */
if(ThreadQueueHd != Nil_closure)
{
- if (do_gr_profile && !no_gr_profile)
+ if (RTSflags.ParFlags.granSimStats && !no_gr_profile)
DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
CurrentTime[CurrentProc] += gran_threadscheduletime;
}
- else if (do_gr_binary && TSO_TYPE(CurrentTSO)==T_MAIN &&
+ else if (RTSflags.ParFlags.granSimStats_Binary && TSO_TYPE(CurrentTSO)==T_MAIN &&
!no_gr_profile)
grterminate(CurrentTime[CurrentProc]);
}
#endif /* GRAN */
#ifdef PAR
- if (do_gr_profile) {
+ if (RTSflags.ParFlags.granSimStats) {
TSO_EXECTIME(CurrentTSO) += now - TSO_BLOCKEDAT(CurrentTSO);
DumpGranInfo(thisPE, CurrentTSO, TSO_TYPE(CurrentTSO) != T_ADVISORY);
}
case T_MAIN:
required_thread_count--;
#ifdef PAR
- if (do_gr_binary)
+ if (RTSflags.ParFlags.granSimStats_Binary)
grterminate(now);
#endif
QP_Event2(do_qp_prof > 1 ? "RA" : "RG", bqe, CurrentTSO);
}
# ifdef PAR
- if (do_gr_profile) {
+ if (RTSflags.ParFlags.granSimStats) {
DumpGranEvent(GR_RESUMEQ, bqe);
switch (TSO_QUEUE(bqe)) {
case Q_BLOCKED:
while(tso != Nil_closure) {
W_ proc;
- assert(TSO_INTERNAL_PTR(tso)->rR[0].p == node);
+ ASSERT(TSO_INTERNAL_PTR(tso)->rR[0].p == node);
# if defined(COUNT)
++BQ_lens;
TSO_LINK(ThreadQueueTl) = tso;
while(TSO_LINK(tso) != Nil_closure) {
- assert(TSO_INTERNAL_PTR(tso)->rR[0].p == node);
+ ASSERT(TSO_INTERNAL_PTR(tso)->rR[0].p == node);
if (DO_QP_PROF) {
QP_Event2(do_qp_prof > 1 ? "RA" : "RG", tso, CurrentTSO);
}
tso = TSO_LINK(tso);
}
- assert(TSO_INTERNAL_PTR(tso)->rR[0].p == node);
+ ASSERT(TSO_INTERNAL_PTR(tso)->rR[0].p == node);
if (DO_QP_PROF) {
QP_Event2(do_qp_prof > 1 ? "RA" : "RG", tso, CurrentTSO);
}
QP_Event1("GR", CurrentTSO);
}
#ifdef PAR
- if (do_gr_profile) {
+ if (RTSflags.ParFlags.granSimStats) {
/* Note that CURRENT_TIME may perform an unsafe call */
TSO_EXECTIME(CurrentTSO) += CURRENT_TIME - TSO_BLOCKEDAT(CurrentTSO);
}
P_ node;
PROC from, to;
{
- assert(to==CurrentProc);
+ ASSERT(to==CurrentProc);
+
if (!IS_LOCAL_TO(PROCS(node),from) &&
!IS_LOCAL_TO(PROCS(node),to) )
return 1;
{ /* start tso */
newevent(p,CurrentProc,
CurrentTime[CurrentProc] /* +gran_latency */,
- FETCHREPLY,tso,node,NULL); /* node needed ?? */
+ FETCHREPLY,tso,node,NULL); /* node needed ? */
CurrentTime[CurrentProc] += gran_mtidytime;
}
else if (IS_LOCAL_TO(PROCS(node),CurrentProc) ) /* Is node still here? */
newevent(p,CurrentProc,
CurrentTime[CurrentProc]+gran_latency,
- FETCHREPLY,tso,node,NULL); /* node needed ?? */
+ FETCHREPLY,tso,node,NULL); /* node needed ? */
CurrentTime[CurrentProc] += gran_mtidytime;
}
if (NoForward) {
newevent(p,p_new,
max(CurrentTime[p_new],CurrentTime[CurrentProc])+gran_latency,
- FETCHREPLY,tso,node,NULL); /* node needed ?? */
+ FETCHREPLY,tso,node,NULL); /* node needed ? */
CurrentTime[CurrentProc] += gran_mtidytime;
return;
}
if(do_gr_sim)
{
- char *extension = do_gr_binary? "gb": "gr";
+ char *extension = RTSflags.ParFlags.granSimStats_Binary? "gb": "gr";
sprintf(gr_filename, GR_FILENAME_FMT, prog_argv[0],extension);
if ((gr_file = fopen(gr_filename,"w")) == NULL )
fputs("\n\n++++++++++++++++++++\n\n",gr_file);
}
- if(do_gr_binary)
+ if(RTSflags.ParFlags.granSimStats_Binary)
grputw(sizeof(TIME));
Idlers = max_proc;
fputc(' ', qp_file);
fputs(prog_argv[i], qp_file);
}
- fprintf(qp_file, " +RTS -C%d -t%d\n", contextSwitchTime, MaxThreads);
+ fprintf(qp_file, " +RTS -C%d -t%d\n"
+ , RTSflags.ConcFlags.ctxtSwitchTime
+ , RTSflags.ConcFlags.maxThreads);
+
fputs(time_str(), qp_file);
fputc('\n', qp_file);
}
if(ThreadQueueHd==Nil_closure) {
MAKE_IDLE(CurrentProc);
ThreadQueueTl = Nil_closure;
- } else if (do_gr_profile) {
+ } else if (RTSflags.ParFlags.granSimStats) {
CurrentTime[CurrentProc] += gran_threadcontextswitchtime;
DumpGranEvent(GR_SCHEDULE,ThreadQueueHd);
}
-- assumes head of queue == CurrentTSO */
if(!DoFairSchedule)
{
- if(do_gr_profile)
+ if(RTSflags.ParFlags.granSimStats)
DumpGranEventAndNode(GR_FETCH,CurrentTSO,node,p);
ActivateNextThread();
else /* !DoReScheduleOnFetch */
{
/* Note: CurrentProc is still busy as it's blocked on fetch */
- if(do_gr_profile)
+ if(RTSflags.ParFlags.granSimStats)
DumpGranEventAndNode(GR_FETCH,CurrentTSO,node,p);
#if defined(GRAN_CHECK) && defined(GRAN) /* Just for testing */
void
GranSimBlock()
{
- if(do_gr_profile)
+ if(RTSflags.ParFlags.granSimStats)
DumpGranEvent(GR_BLOCK,CurrentTSO);
++TSO_BLOCKCOUNT(CurrentTSO);
{
#if defined(GRAN_CHECK) && defined(GRAN)
if ( debug & 0x40 )
- fprintf(main_statsfile,"Saving Spark Root %d(proc: %d; pool: %d) -- 0x%lx\n",
+ fprintf(RTSflags.GcFlags.statsFile,"Saving Spark Root %d(proc: %d; pool: %d) -- 0x%lx\n",
num_ptr_roots,proc,i,SPARK_NODE(spark));
#endif
StorageMgrInfo.roots[num_ptr_roots++] = SPARK_NODE(spark);
}
} /* forall spark ... */
if (prunedSparks>0) {
- fprintf(main_statsfile,"Pruning and disposing %lu excess sparks (> %lu) on proc %d for GC purposes\n",
+ fprintf(RTSflags.GcFlags.statsFile,"Pruning and disposing %lu excess sparks (> %lu) on proc %d for GC purposes\n",
prunedSparks,MAX_SPARKS,proc);
if (disposeQ == PendingSparksHd[proc][i])
PendingSparksHd[proc][i] = NULL;
SPARK_NODE(spark) = StorageMgrInfo.roots[--num_ptr_roots];
#if defined(GRAN_CHECK) && defined(GRAN)
if ( debug & 0x40 )
- fprintf(main_statsfile,"Restoring Spark Root %d -- new: 0x%lx \n",
+ fprintf(RTSflags.GcFlags.statsFile,"Restoring Spark Root %d -- new: 0x%lx \n",
num_ptr_roots,SPARK_NODE(spark));
#endif
}
else
#if defined(GRAN_CHECK) && defined(GRAN)
if ( debug & 0x40 )
- fprintf(main_statsfile,"Error in RestoreSpkRoots (%d; @ spark 0x%x): More than MAX_SPARKS (%d) sparks\n",
+ fprintf(RTSflags.GcFlags.statsFile,"Error in RestoreSpkRoots (%d; @ spark 0x%x): More than MAX_SPARKS (%d) sparks\n",
num_ptr_roots,SPARK_NODE(spark),MAX_SPARKS);
#endif
if(name > GR_EVENT_MAX)
name = GR_EVENT_MAX;
- if(do_gr_binary)
+ if(RTSflags.ParFlags.granSimStats_Binary)
{
grputw(name);
grputw(pe);
if(name > GR_EVENT_MAX)
name = GR_EVENT_MAX;
- if(do_gr_binary)
+ if(RTSflags.ParFlags.granSimStats_Binary)
{
grputw(name);
grputw(pe);
P_ tso;
I_ mandatory_thread;
{
- if(do_gr_binary)
+ if(RTSflags.ParFlags.granSimStats_Binary)
{
grputw(GR_END);
grputw(pe);
fprintf(stderr," [GA: 0x%lx]",GA(node));
#endif
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
fprintf(stderr," [CC: 0x%lx]",CC_HDR(node));
#endif
fprintf(stderr,"Enter Flush Entry: 0x%lx;\tExit Flush Entry: 0x%lx\n",INFO_FLUSHENT(info_ptr),INFO_FLUSH(info_ptr));
#endif
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
fprintf(stderr,"Cost Centre (???): 0x%lx\n",INFO_CAT(info_ptr));
#endif
fputc(' ', qp_file);
fputs(prog_argv[i], qp_file);
}
- fprintf(qp_file, "+RTS -C%ld -t%ld\n", contextSwitchTime, MaxThreads);
+ fprintf(qp_file, "+RTS -C%ld -t%ld\n"
+ , RTSflags.ConcFlags.ctxtSwitchTime
+ , RTSflags.ConcFlags.maxThreads);
+
fputs(time_str(), qp_file);
fputc('\n', qp_file);
}
W_ IdleProcs = ~0l, Idlers = 32;
void
-GranSimAllocate(n,node,liveness)
-I_ n;
-P_ node;
-W_ liveness;
+GranSimAllocate(I_ n, P_ node, W_ liveness)
{ }
void
-GranSimUnallocate(n,node,liveness)
-W_ n;
-P_ node;
-W_ liveness;
+GranSimUnallocate(W_ n, P_ node, W_ liveness)
{ }
-
void
-GranSimExec(ariths,branches,loads,stores,floats)
-W_ ariths,branches,loads,stores,floats;
+GranSimExec(W_ ariths, W_ branches, W_ loads, W_ stores, W_ floats)
{ }
-I_
-GranSimFetch(node /* , liveness_mask */ )
-P_ node;
+int
+GranSimFetch(P_ node /* , liveness_mask */ )
/* I_ liveness_mask; */
-{ }
+{ return(9999999); }
void
-GranSimSpark(local,node)
-W_ local;
-P_ node;
+GranSimSpark(W_ local, P_ node)
{ }
#if 0
#endif
void
-GranSimBlock()
+GranSimBlock(STG_NO_ARGS)
{ }
#endif
--- /dev/null
+%
+% (c) The GRASP Project, Glasgow University, 1992-1993
+%
+%************************************************************************
+%* *
+\section[Ticky.lc]{Stuff for ``ticky-ticky'' profiling}
+%* *
+%************************************************************************
+
+Goes with \tr{imports/Ticky.lh}; more documentation there.
+
+%************************************************************************
+%* *
+\subsection[Ticky-counters]{Declare all the counters}
+%* *
+%************************************************************************
+
+\begin{code}
+#define NULL_REG_MAP /* Not threaded */
+
+#include "../storage/SMinternal.h" /* Bad boy, Will (ToDo) */
+
+#if defined(TICKY_TICKY)
+
+I_ ALLOC_HEAP_ctr = 0;
+I_ ALLOC_HEAP_tot = 0;
+
+PP_ max_SpA; /* set in re_enterable_part_of_main */
+P_ max_SpB;
+
+/* not used at all
+I_ A_STK_REUSE_ctr = 0;
+I_ B_STK_REUSE_ctr = 0;
+*/
+I_ A_STK_STUB_ctr = 0;
+
+I_ ALLOC_FUN_ctr = 0;
+I_ ALLOC_FUN_adm = 0;
+I_ ALLOC_FUN_gds = 0;
+I_ ALLOC_FUN_slp = 0;
+I_ ALLOC_FUN_hst[5] = {0,0,0,0,0};
+I_ ALLOC_THK_ctr = 0;
+I_ ALLOC_THK_adm = 0;
+I_ ALLOC_THK_gds = 0;
+I_ ALLOC_THK_slp = 0;
+I_ ALLOC_THK_hst[5] = {0,0,0,0,0};
+I_ ALLOC_CON_ctr = 0;
+I_ ALLOC_CON_adm = 0;
+I_ ALLOC_CON_gds = 0;
+I_ ALLOC_CON_slp = 0;
+I_ ALLOC_CON_hst[5] = {0,0,0,0,0};
+I_ ALLOC_TUP_ctr = 0;
+I_ ALLOC_TUP_adm = 0;
+I_ ALLOC_TUP_gds = 0;
+I_ ALLOC_TUP_slp = 0;
+I_ ALLOC_TUP_hst[5] = {0,0,0,0,0};
+I_ ALLOC_BH_ctr = 0;
+I_ ALLOC_BH_adm = 0;
+I_ ALLOC_BH_gds = 0;
+I_ ALLOC_BH_slp = 0;
+I_ ALLOC_BH_hst[5] = {0,0,0,0,0};
+I_ ALLOC_PRIM_ctr = 0;
+I_ ALLOC_PRIM_adm = 0;
+I_ ALLOC_PRIM_gds = 0;
+I_ ALLOC_PRIM_slp = 0;
+I_ ALLOC_PRIM_hst[5] = {0,0,0,0,0};
+I_ ALLOC_UPD_PAP_ctr = 0;
+I_ ALLOC_UPD_PAP_adm = 0;
+I_ ALLOC_UPD_PAP_gds = 0;
+I_ ALLOC_UPD_PAP_slp = 0;
+I_ ALLOC_UPD_PAP_hst[5] = {0,0,0,0,0};
+
+#ifdef CONCURRENT
+I_ ALLOC_STK_ctr = 0;
+I_ ALLOC_STK_adm = 0;
+I_ ALLOC_STK_gds = 0;
+I_ ALLOC_STK_slp = 0;
+I_ ALLOC_STK_hst[5] = {0,0,0,0,0};
+I_ ALLOC_TSO_ctr = 0;
+I_ ALLOC_TSO_adm = 0;
+I_ ALLOC_TSO_gds = 0;
+I_ ALLOC_TSO_slp = 0;
+I_ ALLOC_TSO_hst[5] = {0,0,0,0,0};
+
+# ifdef PAR
+I_ ALLOC_FMBQ_ctr = 0;
+I_ ALLOC_FMBQ_adm = 0;
+I_ ALLOC_FMBQ_gds = 0;
+I_ ALLOC_FMBQ_slp = 0;
+I_ ALLOC_FMBQ_hst[5] = {0,0,0,0,0};
+I_ ALLOC_FME_ctr = 0;
+I_ ALLOC_FME_adm = 0;
+I_ ALLOC_FME_gds = 0;
+I_ ALLOC_FME_slp = 0;
+I_ ALLOC_FME_hst[5] = {0,0,0,0,0};
+I_ ALLOC_BF_ctr = 0;
+I_ ALLOC_BF_adm = 0;
+I_ ALLOC_BF_gds = 0;
+I_ ALLOC_BF_slp = 0;
+I_ ALLOC_BF_hst[5] = {0,0,0,0,0};
+# endif
+#endif
+
+I_ ENT_VIA_NODE_ctr = 0;
+I_ ENT_CON_ctr = 0;
+I_ ENT_FUN_STD_ctr = 0;
+I_ ENT_FUN_DIRECT_ctr = 0;
+I_ ENT_IND_ctr = 0;
+I_ ENT_PAP_ctr = 0;
+I_ ENT_THK_ctr = 0;
+
+I_ RET_NEW_IN_HEAP_ctr = 0;
+I_ RET_NEW_IN_REGS_ctr = 0;
+I_ RET_OLD_IN_HEAP_ctr = 0;
+I_ RET_OLD_IN_REGS_ctr = 0;
+I_ RET_SEMI_BY_DEFAULT_ctr = 0;
+I_ RET_SEMI_IN_HEAP_ctr = 0;
+I_ RET_SEMI_IN_REGS_ctr = 0;
+I_ RET_SEMI_FAILED_IND_ctr = 0;
+I_ RET_SEMI_FAILED_UNEVAL_ctr = 0;
+I_ VEC_RETURN_ctr = 0;
+
+I_ RET_NEW_IN_HEAP_hst[9] = {0,0,0,0,0,0,0,0,0};
+I_ RET_NEW_IN_REGS_hst[9] = {0,0,0,0,0,0,0,0,0};
+I_ RET_OLD_IN_HEAP_hst[9] = {0,0,0,0,0,0,0,0,0};
+I_ RET_OLD_IN_REGS_hst[9] = {0,0,0,0,0,0,0,0,0};
+/* no such thing: I_ RET_SEMI_BY_DEFAULT_hst[9] = {0,0,0,0,0,0,0,0,0}; */
+I_ RET_SEMI_IN_HEAP_hst[9] = {0,0,0,0,0,0,0,0,0};
+I_ RET_SEMI_IN_REGS_hst[9] = {0,0,0,0,0,0,0,0,0};
+I_ RET_VEC_RETURN_hst[9] = {0,0,0,0,0,0,0,0,0};
+
+I_ RET_SEMI_loads_avoided = 0;
+
+I_ ReturnInRegsNodeValid = 0; /* i.e., False */
+
+I_ UPDF_OMITTED_ctr = 0;
+I_ UPDF_STD_PUSHED_ctr = 0;
+I_ UPDF_CON_PUSHED_ctr = 0;
+I_ UPDF_HOLE_PUSHED_ctr = 0;
+
+I_ UPDF_RCC_PUSHED_ctr = 0;
+I_ UPDF_RCC_OMITTED_ctr = 0;
+
+I_ UPD_EXISTING_ctr = 0;
+I_ UPD_SQUEEZED_ctr = 0;
+I_ UPD_CON_W_NODE_ctr = 0;
+I_ UPD_CON_IN_PLACE_ctr = 0;
+I_ UPD_CON_IN_NEW_ctr = 0;
+I_ UPD_PAP_IN_PLACE_ctr = 0;
+I_ UPD_PAP_IN_NEW_ctr = 0;
+
+I_ UPD_CON_IN_PLACE_hst[9] = {0,0,0,0,0,0,0,0,0};
+I_ UPD_CON_IN_NEW_hst[9] = {0,0,0,0,0,0,0,0,0};
+I_ UPD_PAP_IN_NEW_hst[9] = {0,0,0,0,0,0,0,0,0};
+
+I_ UPD_ENTERED_hst[9] = {0,0,0,0,0,0,0,0,0};
+
+I_ UPD_NEW_IND_ctr = 0;
+I_ UPD_NEW_IN_PLACE_PTRS_ctr = 0;
+I_ UPD_NEW_IN_PLACE_NOPTRS_ctr = 0;
+I_ UPD_OLD_IND_ctr = 0;
+I_ UPD_OLD_IN_PLACE_PTRS_ctr = 0;
+I_ UPD_OLD_IN_PLACE_NOPTRS_ctr = 0;
+
+I_ UPD_IN_PLACE_COPY_ctr = 0;
+
+I_ GC_SEL_ABANDONED_ctr = 0;
+I_ GC_SEL_MINOR_ctr = 0;
+I_ GC_SEL_MAJOR_ctr = 0;
+
+I_ GC_SHORT_IND_ctr = 0;
+I_ GC_SHORT_CAF_ctr = 0;
+I_ GC_COMMON_CHARLIKE_ctr = 0;
+I_ GC_COMMON_INTLIKE_ctr = 0;
+I_ GC_COMMON_INTLIKE_FAIL_ctr = 0;
+I_ GC_COMMON_CONST_ctr = 0;
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Ticky-print]{Print out all the counters}
+%* *
+%************************************************************************
+
+\begin{code}
+static void printRegisteredCounterInfo (FILE *); /* fwd decl */
+
+#define INTAVG(a,b) ((b == 0) ? 0.0 : ((StgDouble) (a) / (StgDouble) (b)))
+#define PC(a) (100.0 * a)
+
+#define AVG(thing) \
+ StgDouble CAT2(avg,thing) = INTAVG(CAT2(tot,thing),CAT2(ctr,thing))
+
+void
+PrintTickyInfo()
+{
+ I_ i;
+ I_ tot_allocs = /* total number of things allocated */
+ ALLOC_FUN_ctr + ALLOC_THK_ctr + ALLOC_CON_ctr + ALLOC_TUP_ctr +
+#ifdef CONCURRENT
+ ALLOC_STK_ctr + ALLOC_TSO_ctr +
+# ifdef PAR
+ ALLOC_FMBQ_ctr + ALLOC_FME_ctr + ALLOC_BF_ctr +
+# endif
+#endif
+ ALLOC_BH_ctr + ALLOC_UPD_PAP_ctr + ALLOC_PRIM_ctr;
+ I_ tot_adm_wds = /* total number of admin words allocated */
+ ALLOC_FUN_adm + ALLOC_THK_adm + ALLOC_CON_adm + ALLOC_TUP_adm +
+#ifdef CONCURRENT
+ ALLOC_STK_adm + ALLOC_TSO_adm +
+# ifdef PAR
+ ALLOC_FMBQ_adm + ALLOC_FME_adm + ALLOC_BF_adm +
+# endif
+#endif
+ ALLOC_BH_adm + ALLOC_UPD_PAP_adm + ALLOC_PRIM_adm;
+ I_ tot_gds_wds = /* total number of words of ``good stuff'' allocated */
+ ALLOC_FUN_gds + ALLOC_THK_gds + ALLOC_CON_gds + ALLOC_TUP_gds +
+#ifdef CONCURRENT
+ ALLOC_STK_gds + ALLOC_TSO_gds +
+# ifdef PAR
+ ALLOC_FMBQ_gds + ALLOC_FME_gds + ALLOC_BF_gds +
+# endif
+#endif
+ ALLOC_BH_gds + ALLOC_UPD_PAP_gds + ALLOC_PRIM_gds;
+ I_ tot_slp_wds = /* total number of ``slop'' words allocated */
+ ALLOC_FUN_slp + ALLOC_THK_slp + ALLOC_CON_slp + ALLOC_TUP_slp +
+#ifdef CONCURRENT
+ ALLOC_STK_slp + ALLOC_TSO_slp +
+# ifdef PAR
+ ALLOC_FMBQ_slp + ALLOC_FME_slp + ALLOC_BF_slp +
+# endif
+#endif
+ ALLOC_BH_slp + ALLOC_UPD_PAP_slp + ALLOC_PRIM_slp;
+ I_ tot_wds = /* total words */
+ tot_adm_wds + tot_gds_wds + tot_slp_wds;
+
+ I_ tot_enters =
+ ENT_CON_ctr + ENT_FUN_DIRECT_ctr +
+ ENT_IND_ctr + ENT_PAP_ctr + ENT_THK_ctr;
+ I_ jump_direct_enters =
+ tot_enters - ENT_VIA_NODE_ctr;
+ I_ bypass_enters =
+ ENT_FUN_DIRECT_ctr -
+ (ENT_FUN_STD_ctr - UPD_PAP_IN_PLACE_ctr - UPD_PAP_IN_NEW_ctr);
+
+ I_ tot_returns_in_regs =
+ RET_NEW_IN_REGS_ctr + RET_OLD_IN_REGS_ctr + RET_SEMI_IN_REGS_ctr;
+ I_ tot_returns_in_heap =
+ RET_NEW_IN_HEAP_ctr + RET_OLD_IN_HEAP_ctr + RET_SEMI_IN_HEAP_ctr + RET_SEMI_BY_DEFAULT_ctr/*???*/;
+ I_ tot_returns_of_new =
+ RET_NEW_IN_REGS_ctr + RET_NEW_IN_HEAP_ctr;
+ I_ tot_returns_of_old = /* NB: NOT USED ???! 94/05 WDP */
+ RET_OLD_IN_REGS_ctr + RET_OLD_IN_HEAP_ctr +
+ RET_SEMI_BY_DEFAULT_ctr + RET_SEMI_IN_HEAP_ctr + RET_SEMI_IN_REGS_ctr /*???*/;
+
+ I_ tot_returns =
+ tot_returns_in_regs + tot_returns_in_heap;
+
+ I_ tot_upd_frames =
+ UPDF_STD_PUSHED_ctr + UPDF_CON_PUSHED_ctr; /*DBH*/
+
+ I_ con_updates =
+ UPD_CON_W_NODE_ctr + UPD_CON_IN_PLACE_ctr + UPD_CON_IN_NEW_ctr;
+ I_ pap_updates =
+ UPD_PAP_IN_PLACE_ctr + UPD_PAP_IN_NEW_ctr;
+ I_ tot_updates =
+ UPD_EXISTING_ctr + UPD_SQUEEZED_ctr + con_updates + pap_updates;
+ I_ tot_in_place_updates =
+ UPD_CON_IN_PLACE_ctr + UPD_PAP_IN_PLACE_ctr;
+
+ I_ tot_new_updates =
+ UPD_NEW_IN_PLACE_NOPTRS_ctr + UPD_NEW_IN_PLACE_PTRS_ctr + UPD_NEW_IND_ctr;
+ I_ tot_old_updates =
+ UPD_OLD_IN_PLACE_NOPTRS_ctr + UPD_OLD_IN_PLACE_PTRS_ctr + UPD_OLD_IND_ctr;
+ I_ tot_gengc_updates =
+ tot_new_updates + tot_old_updates;
+
+ FILE *tf = RTSflags.TickyFlags.tickyFile;
+
+ fprintf(tf,"\n\nALLOCATIONS: %ld (%ld words total: %ld admin, %ld goods, %ld slop)\n",
+ tot_allocs, tot_wds, tot_adm_wds, tot_gds_wds, tot_slp_wds);
+ fprintf(tf,"\t\t\t\ttotal words:\t 2 3 4 5 6+\n");
+
+#define ALLOC_HISTO_MAGIC(categ) \
+ (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[0], CAT3(ALLOC_,categ,_ctr)))), \
+ (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[1], CAT3(ALLOC_,categ,_ctr)))), \
+ (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[2], CAT3(ALLOC_,categ,_ctr)))), \
+ (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[3], CAT3(ALLOC_,categ,_ctr)))), \
+ (PC(INTAVG(CAT3(ALLOC_,categ,_hst)[4], CAT3(ALLOC_,categ,_ctr))))
+
+ fprintf(tf,"%7ld (%5.1f%%) function values",
+ ALLOC_FUN_ctr,
+ PC(INTAVG(ALLOC_FUN_ctr, tot_allocs)));
+ if (ALLOC_FUN_ctr != 0)
+ fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(FUN));
+
+ fprintf(tf,"\n%7ld (%5.1f%%) thunks",
+ ALLOC_THK_ctr,
+ PC(INTAVG(ALLOC_THK_ctr, tot_allocs)));
+ if (ALLOC_THK_ctr != 0)
+ fprintf(tf,"\t\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(THK));
+
+ fprintf(tf,"\n%7ld (%5.1f%%) data values",
+ ALLOC_CON_ctr,
+ PC(INTAVG(ALLOC_CON_ctr, tot_allocs)));
+ if (ALLOC_CON_ctr != 0)
+ fprintf(tf,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(CON));
+
+ fprintf(tf,"\n%7ld (%5.1f%%) big tuples",
+ ALLOC_TUP_ctr,
+ PC(INTAVG(ALLOC_TUP_ctr, tot_allocs)));
+ if (ALLOC_TUP_ctr != 0)
+ fprintf(tf,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(TUP));
+
+ fprintf(tf,"\n%7ld (%5.1f%%) black holes",
+ ALLOC_BH_ctr,
+ PC(INTAVG(ALLOC_BH_ctr, tot_allocs)));
+ if (ALLOC_BH_ctr != 0)
+ fprintf(tf,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(BH));
+
+ fprintf(tf,"\n%7ld (%5.1f%%) prim things",
+ ALLOC_PRIM_ctr,
+ PC(INTAVG(ALLOC_PRIM_ctr, tot_allocs)));
+ if (ALLOC_PRIM_ctr != 0)
+ fprintf(tf,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(PRIM));
+
+ fprintf(tf,"\n%7ld (%5.1f%%) partial applications",
+ ALLOC_UPD_PAP_ctr,
+ PC(INTAVG(ALLOC_UPD_PAP_ctr, tot_allocs)));
+ if (ALLOC_UPD_PAP_ctr != 0)
+ fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(UPD_PAP));
+
+#ifdef CONCURRENT
+ fprintf(tf,"\n%7ld (%5.1f%%) stack objects",
+ ALLOC_STK_ctr,
+ PC(INTAVG(ALLOC_STK_ctr, tot_allocs)));
+ if (ALLOC_STK_ctr != 0)
+ fprintf(tf,"\t\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(STK));
+ fprintf(tf,"\n%7ld (%5.1f%%) thread state objects",
+ ALLOC_TSO_ctr,
+ PC(INTAVG(ALLOC_TSO_ctr, tot_allocs)));
+ if (ALLOC_TSO_ctr != 0)
+ fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(TSO));
+# ifdef PAR
+ fprintf(tf,"\n%7ld (%5.1f%%) thread state objects",
+ ALLOC_FMBQ_ctr,
+ PC(INTAVG(ALLOC_FMBQ_ctr, tot_allocs)));
+ if (ALLOC_FMBQ_ctr != 0)
+ fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(FMBQ));
+ fprintf(tf,"\n%7ld (%5.1f%%) thread state objects",
+ ALLOC_FME_ctr,
+ PC(INTAVG(ALLOC_FME_ctr, tot_allocs)));
+ if (ALLOC_FME_ctr != 0)
+ fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(FME));
+ fprintf(tf,"\n%7ld (%5.1f%%) thread state objects",
+ ALLOC_BF_ctr,
+ PC(INTAVG(ALLOC_BF_ctr, tot_allocs)));
+ if (ALLOC_BF_ctr != 0)
+ fprintf(tf,"\t\t%5.1f %5.1f %5.1f %5.1f %5.1f", ALLOC_HISTO_MAGIC(BF));
+# endif
+#endif
+ fprintf(tf,"\n");
+
+ fprintf(tf,"\nTotal storage-manager allocations: %ld (%ld words)\n\t[%ld words lost to speculative heap-checks]\n", ALLOC_HEAP_ctr, ALLOC_HEAP_tot, ALLOC_HEAP_tot - tot_wds);
+
+ fprintf(tf,"\nSTACK USAGE:\n"); /* NB: some bits are direction sensitive */
+ fprintf(tf,"\tA stack slots stubbed: %ld\n", A_STK_STUB_ctr);
+/* not used at all
+ fprintf(tf,"\tA stack slots re-used: %ld\n", A_STK_REUSE_ctr);
+ fprintf(tf,"\tB stack slots re-used: %ld\n", B_STK_REUSE_ctr);
+*/
+#ifndef CONCURRENT
+ fprintf(tf,"\tA stack max. depth: %ld words\n",
+ (I_) (stackInfo.botA - max_SpA));
+ fprintf(tf,"\tB stack max. depth: %ld words\n",
+ (I_) (max_SpB - stackInfo.botB)); /* And cheating, too (ToDo) */
+#endif
+
+ fprintf(tf,"\nENTERS: %ld of which %ld (%.1f%%) direct to the entry code\n\t\t [the rest indirected via Node's info ptr]\n",
+ tot_enters,
+ jump_direct_enters,
+ PC(INTAVG(jump_direct_enters,tot_enters)));
+ fprintf(tf,"%7ld (%5.1f%%) thunks\n",
+ ENT_THK_ctr,
+ PC(INTAVG(ENT_THK_ctr,tot_enters)));
+ fprintf(tf,"%7ld (%5.1f%%) data values\n",
+ ENT_CON_ctr,
+ PC(INTAVG(ENT_CON_ctr,tot_enters)));
+ fprintf(tf,"%7ld (%5.1f%%) function values\n\t\t [of which %ld (%.1f%%) bypassed arg-satisfaction chk]\n",
+ ENT_FUN_DIRECT_ctr,
+ PC(INTAVG(ENT_FUN_DIRECT_ctr,tot_enters)),
+ bypass_enters,
+ PC(INTAVG(bypass_enters,ENT_FUN_DIRECT_ctr)));
+ fprintf(tf,"%7ld (%5.1f%%) partial applications\n",
+ ENT_PAP_ctr,
+ PC(INTAVG(ENT_PAP_ctr,tot_enters)));
+ fprintf(tf,"%7ld (%5.1f%%) indirections\n",
+ ENT_IND_ctr,
+ PC(INTAVG(ENT_IND_ctr,tot_enters)));
+
+ fprintf(tf,"\nRETURNS: %ld\n", tot_returns);
+ fprintf(tf,"%7ld (%5.1f%%) in registers [the rest in the heap]\n",
+ tot_returns_in_regs,
+ PC(INTAVG(tot_returns_in_regs,tot_returns)));
+ fprintf(tf,"%7ld (%5.1f%%) from entering a new constructor\n\t\t [the rest from entering an existing constructor]\n",
+ tot_returns_of_new,
+ PC(INTAVG(tot_returns_of_new,tot_returns)));
+ fprintf(tf,"%7ld (%5.1f%%) vectored [the rest unvectored]\n",
+ VEC_RETURN_ctr,
+ PC(INTAVG(VEC_RETURN_ctr,tot_returns)));
+
+/*
+ fprintf(tf, "RET_xxx: %7ld: ", RET_xxx_ctr);
+ for (i = 0; i < 9; i++) { fprintf(tf, "%5.1f%%",
+ PC(INTAVG(RET_xxx_hst[i],RET_xxx_ctr))); }
+ fprintf(tf, "\n");
+*/
+ fprintf(tf, "\nRET_OLD_IN_REGS: %7ld: ", RET_OLD_IN_REGS_ctr);
+ for (i = 0; i < 9; i++) { fprintf(tf, "%5.1f%%",
+ PC(INTAVG(RET_OLD_IN_REGS_hst[i],RET_OLD_IN_REGS_ctr))); }
+ fprintf(tf, "\n");
+ fprintf(tf, "RET_NEW_IN_REGS: %7ld: ", RET_NEW_IN_REGS_ctr);
+ for (i = 0; i < 9; i++) { fprintf(tf, "%5.1f%%",
+ PC(INTAVG(RET_NEW_IN_REGS_hst[i],RET_NEW_IN_REGS_ctr))); }
+ fprintf(tf, "\n");
+ fprintf(tf, "RET_OLD_IN_HEAP: %7ld: ", RET_OLD_IN_HEAP_ctr);
+ for (i = 0; i < 9; i++) { fprintf(tf, "%5.1f%%",
+ PC(INTAVG(RET_OLD_IN_HEAP_hst[i],RET_OLD_IN_HEAP_ctr))); }
+ fprintf(tf, "\n");
+ fprintf(tf, "RET_NEW_IN_HEAP: %7ld: ", RET_NEW_IN_HEAP_ctr);
+ for (i = 0; i < 9; i++) { fprintf(tf, "%5.1f%%",
+ PC(INTAVG(RET_NEW_IN_HEAP_hst[i],RET_NEW_IN_HEAP_ctr))); }
+ fprintf(tf, "\n");
+ fprintf(tf, "\nRET_VEC_RETURN : %7ld: ", VEC_RETURN_ctr);
+ for (i = 0; i < 9; i++) { fprintf(tf, "%5.1f%%",
+ PC(INTAVG(RET_VEC_RETURN_hst[i],VEC_RETURN_ctr))); }
+ fprintf(tf, "\n");
+
+ fprintf(tf,"\nUPDATE FRAMES: %ld (%ld omitted from thunks)\n",
+ tot_upd_frames,
+ UPDF_OMITTED_ctr);
+ fprintf(tf,"%7ld (%5.1f%%) standard frames\n",
+ UPDF_STD_PUSHED_ctr,
+ PC(INTAVG(UPDF_STD_PUSHED_ctr,tot_upd_frames)));
+ fprintf(tf,"%7ld (%5.1f%%) constructor frames\n",
+ UPDF_CON_PUSHED_ctr,
+ PC(INTAVG(UPDF_CON_PUSHED_ctr,tot_upd_frames)));
+ fprintf(tf,"\t\t [of which %ld (%.1f%%) were for black-holes]\n",
+ UPDF_HOLE_PUSHED_ctr,
+ PC(INTAVG(UPDF_HOLE_PUSHED_ctr,UPDF_CON_PUSHED_ctr))); /*DBH*/
+
+ if (UPDF_RCC_PUSHED_ctr != 0)
+ fprintf(tf,"%7ld restore cost centre frames (%ld omitted)\n",
+ UPDF_RCC_PUSHED_ctr,
+ UPDF_RCC_OMITTED_ctr);
+
+ fprintf(tf,"\nUPDATES: %ld\n", tot_updates);
+ fprintf(tf,"%7ld (%5.1f%%) data values\n\t\t [%ld in place, %ld allocated new space, %ld with Node]\n",
+ con_updates,
+ PC(INTAVG(con_updates,tot_updates)),
+ UPD_CON_IN_PLACE_ctr, UPD_CON_IN_NEW_ctr, UPD_CON_W_NODE_ctr);
+ fprintf(tf,"%7ld (%5.1f%%) partial applications\n\t\t [%ld in place, %ld allocated new space]\n",
+ pap_updates,
+ PC(INTAVG(pap_updates,tot_updates)),
+ UPD_PAP_IN_PLACE_ctr, UPD_PAP_IN_NEW_ctr);
+ fprintf(tf,"%7ld (%5.1f%%) updates to existing heap objects (%ld by squeezing)\n",
+ UPD_EXISTING_ctr + UPD_SQUEEZED_ctr,
+ PC(INTAVG(UPD_EXISTING_ctr + UPD_SQUEEZED_ctr, tot_updates)),
+ UPD_SQUEEZED_ctr);
+ fprintf(tf,"%7ld (%5.1f%%) in-place updates copied\n",
+ UPD_IN_PLACE_COPY_ctr,
+ PC(INTAVG(UPD_IN_PLACE_COPY_ctr,tot_in_place_updates)));
+#if 0
+ if (UPD_ENTERED_ctr != 0) {
+ fprintf(tf,"%7ld (%5.1f%%) subsequently entered\n",
+ UPD_ENTERED_ctr,
+ PC(INTAVG(UPD_ENTERED_ctr,tot_updates)));
+ fprintf(tf,"%7ld (%5.1f%%) subsequently entered more than once\n",
+ UPD_ENTERED_AGAIN_ctr,
+ PC(INTAVG(UPD_ENTERED_AGAIN_ctr,tot_updates)));
+ }
+#endif
+/*
+ fprintf(tf, "UPD_xxx: %7ld: ", UPD_xxx_ctr);
+ for (i = 0; i < 9; i++) { fprintf(tf, "%7ld", UPD_xxx_hst[i]); }
+ fprintf(tf, "\n");
+*/
+ fprintf(tf, "UPD_CON_IN_PLACE: %7ld: ", UPD_CON_IN_PLACE_ctr);
+ for (i = 0; i < 9; i++) { fprintf(tf, "%7ld", UPD_CON_IN_PLACE_hst[i]); }
+ fprintf(tf, "\n");
+ fprintf(tf, "UPD_CON_IN_NEW: %7ld: ", UPD_CON_IN_NEW_ctr);
+ for (i = 0; i < 9; i++) { fprintf(tf, "%7ld", UPD_CON_IN_NEW_hst[i]); }
+ fprintf(tf, "\n");
+ fprintf(tf, "UPD_PAP_IN_NEW: %7ld: ", UPD_PAP_IN_NEW_ctr);
+ for (i = 0; i < 9; i++) { fprintf(tf, "%7ld", UPD_PAP_IN_NEW_hst[i]); }
+ fprintf(tf, "\n");
+
+ if (tot_gengc_updates != 0) {
+ fprintf(tf,"\nNEW GEN UPDATES: %ld (%5.1f%%)\n",
+ tot_new_updates,
+ PC(INTAVG(tot_new_updates,tot_gengc_updates)));
+ fprintf(tf,"%7ld (%5.1f%%) indirections\n",
+ UPD_NEW_IND_ctr,
+ PC(INTAVG(UPD_NEW_IND_ctr,tot_gengc_updates)));
+ fprintf(tf,"%7ld (%5.1f%%) inplace with ptrs\n",
+ UPD_NEW_IN_PLACE_PTRS_ctr,
+ PC(INTAVG(UPD_NEW_IN_PLACE_PTRS_ctr,tot_gengc_updates)));
+ fprintf(tf,"%7ld (%5.1f%%) inplace without ptrs\n",
+ UPD_NEW_IN_PLACE_NOPTRS_ctr,
+ PC(INTAVG(UPD_NEW_IN_PLACE_NOPTRS_ctr,tot_gengc_updates)));
+ fprintf(tf,"\nOLD GEN UPDATES: %ld (%5.1f%%)\n",
+ tot_old_updates,
+ PC(INTAVG(tot_old_updates,tot_gengc_updates)));
+ fprintf(tf,"%7ld (%5.1f%%) indirections\n",
+ UPD_OLD_IND_ctr,
+ PC(INTAVG(UPD_OLD_IND_ctr,tot_gengc_updates)));
+ fprintf(tf,"%7ld (%5.1f%%) inplace with ptrs\n",
+ UPD_OLD_IN_PLACE_PTRS_ctr,
+ PC(INTAVG(UPD_OLD_IN_PLACE_PTRS_ctr,tot_gengc_updates)));
+ fprintf(tf,"%7ld (%5.1f%%) inplace without ptrs\n",
+ UPD_OLD_IN_PLACE_NOPTRS_ctr,
+ PC(INTAVG(UPD_OLD_IN_PLACE_NOPTRS_ctr,tot_gengc_updates)));
+ }
+
+ printRegisteredCounterInfo(tf);
+
+ fprintf(tf,"\n**************************************************\n");
+
+ /* here, we print out all the raw numbers; these are really
+ more useful when we want to snag them for subsequent
+ rdb-etc processing. WDP 95/11
+ */
+
+#define PR_CTR(ctr) \
+ do { fprintf(tf,"%7ld " #ctr "\n", ctr); } while(0)
+#define PR_HST(hst,i) \
+ do { fprintf(tf,"%7ld " #hst "_" #i "\n", hst[i]); } while(0)
+
+ PR_CTR(ALLOC_HEAP_ctr);
+ PR_CTR(ALLOC_HEAP_tot);
+
+#ifndef CONCURRENT
+ fprintf(tf,"%7ld HWM_SpA\n", (I_) (stackInfo.botA - max_SpA));
+ fprintf(tf,"%7ld HWM_SpB\n", (I_) (max_SpB - stackInfo.botB));
+#endif
+
+ PR_CTR(A_STK_STUB_ctr);
+
+ PR_CTR(ALLOC_FUN_ctr);
+ PR_CTR(ALLOC_FUN_adm);
+ PR_CTR(ALLOC_FUN_gds);
+ PR_CTR(ALLOC_FUN_slp);
+ PR_HST(ALLOC_FUN_hst,0);
+ PR_HST(ALLOC_FUN_hst,1);
+ PR_HST(ALLOC_FUN_hst,2);
+ PR_HST(ALLOC_FUN_hst,3);
+ PR_HST(ALLOC_FUN_hst,4);
+ PR_CTR(ALLOC_THK_ctr);
+ PR_CTR(ALLOC_THK_adm);
+ PR_CTR(ALLOC_THK_gds);
+ PR_CTR(ALLOC_THK_slp);
+ PR_HST(ALLOC_THK_hst,0);
+ PR_HST(ALLOC_THK_hst,1);
+ PR_HST(ALLOC_THK_hst,2);
+ PR_HST(ALLOC_THK_hst,3);
+ PR_HST(ALLOC_THK_hst,4);
+ PR_CTR(ALLOC_CON_ctr);
+ PR_CTR(ALLOC_CON_adm);
+ PR_CTR(ALLOC_CON_gds);
+ PR_CTR(ALLOC_CON_slp);
+ PR_HST(ALLOC_CON_hst,0);
+ PR_HST(ALLOC_CON_hst,1);
+ PR_HST(ALLOC_CON_hst,2);
+ PR_HST(ALLOC_CON_hst,3);
+ PR_HST(ALLOC_CON_hst,4);
+ PR_CTR(ALLOC_TUP_ctr);
+ PR_CTR(ALLOC_TUP_adm);
+ PR_CTR(ALLOC_TUP_gds);
+ PR_CTR(ALLOC_TUP_slp);
+ PR_HST(ALLOC_TUP_hst,0);
+ PR_HST(ALLOC_TUP_hst,1);
+ PR_HST(ALLOC_TUP_hst,2);
+ PR_HST(ALLOC_TUP_hst,3);
+ PR_HST(ALLOC_TUP_hst,4);
+ PR_CTR(ALLOC_BH_ctr);
+ PR_CTR(ALLOC_BH_adm);
+ PR_CTR(ALLOC_BH_gds);
+ PR_CTR(ALLOC_BH_slp);
+ PR_HST(ALLOC_BH_hst,0);
+ PR_HST(ALLOC_BH_hst,1);
+ PR_HST(ALLOC_BH_hst,2);
+ PR_HST(ALLOC_BH_hst,3);
+ PR_HST(ALLOC_BH_hst,4);
+ PR_CTR(ALLOC_PRIM_ctr);
+ PR_CTR(ALLOC_PRIM_adm);
+ PR_CTR(ALLOC_PRIM_gds);
+ PR_CTR(ALLOC_PRIM_slp);
+ PR_HST(ALLOC_PRIM_hst,0);
+ PR_HST(ALLOC_PRIM_hst,1);
+ PR_HST(ALLOC_PRIM_hst,2);
+ PR_HST(ALLOC_PRIM_hst,3);
+ PR_HST(ALLOC_PRIM_hst,4);
+ PR_CTR(ALLOC_UPD_PAP_ctr);
+ PR_CTR(ALLOC_UPD_PAP_adm);
+ PR_CTR(ALLOC_UPD_PAP_gds);
+ PR_CTR(ALLOC_UPD_PAP_slp);
+ PR_HST(ALLOC_UPD_PAP_hst,0);
+ PR_HST(ALLOC_UPD_PAP_hst,1);
+ PR_HST(ALLOC_UPD_PAP_hst,2);
+ PR_HST(ALLOC_UPD_PAP_hst,3);
+ PR_HST(ALLOC_UPD_PAP_hst,4);
+
+#ifdef CONCURRENT
+ PR_CTR(ALLOC_STK_ctr);
+ PR_CTR(ALLOC_STK_adm);
+ PR_CTR(ALLOC_STK_gds);
+ PR_CTR(ALLOC_STK_slp);
+ PR_HST(ALLOC_STK_hst,0);
+ PR_HST(ALLOC_STK_hst,1);
+ PR_HST(ALLOC_STK_hst,2);
+ PR_HST(ALLOC_STK_hst,3);
+ PR_HST(ALLOC_STK_hst,4);
+ PR_CTR(ALLOC_TSO_ctr);
+ PR_CTR(ALLOC_TSO_adm);
+ PR_CTR(ALLOC_TSO_gds);
+ PR_CTR(ALLOC_TSO_slp);
+ PR_HST(ALLOC_TSO_hst,0);
+ PR_HST(ALLOC_TSO_hst,1);
+ PR_HST(ALLOC_TSO_hst,2);
+ PR_HST(ALLOC_TSO_hst,3);
+ PR_HST(ALLOC_TSO_hst,4);
+
+# ifdef PAR
+ PR_CTR(ALLOC_FMBQ_ctr);
+ PR_CTR(ALLOC_FMBQ_adm);
+ PR_CTR(ALLOC_FMBQ_gds);
+ PR_CTR(ALLOC_FMBQ_slp);
+ PR_HST(ALLOC_FMBQ_hst,0);
+ PR_HST(ALLOC_FMBQ_hst,1);
+ PR_HST(ALLOC_FMBQ_hst,2);
+ PR_HST(ALLOC_FMBQ_hst,3);
+ PR_HST(ALLOC_FMBQ_hst,4);
+ PR_CTR(ALLOC_FME_ctr);
+ PR_CTR(ALLOC_FME_adm);
+ PR_CTR(ALLOC_FME_gds);
+ PR_CTR(ALLOC_FME_slp);
+ PR_HST(ALLOC_FME_hst,0);
+ PR_HST(ALLOC_FME_hst,1);
+ PR_HST(ALLOC_FME_hst,2);
+ PR_HST(ALLOC_FME_hst,3);
+ PR_HST(ALLOC_FME_hst,4);
+ PR_CTR(ALLOC_BF_ctr);
+ PR_CTR(ALLOC_BF_adm);
+ PR_CTR(ALLOC_BF_gds);
+ PR_CTR(ALLOC_BF_slp);
+ PR_HST(ALLOC_BF_hst,0);
+ PR_HST(ALLOC_BF_hst,1);
+ PR_HST(ALLOC_BF_hst,2);
+ PR_HST(ALLOC_BF_hst,3);
+ PR_HST(ALLOC_BF_hst,4);
+# endif
+#endif
+
+ PR_CTR(ENT_VIA_NODE_ctr);
+ PR_CTR(ENT_CON_ctr);
+ PR_CTR(ENT_FUN_STD_ctr);
+ PR_CTR(ENT_FUN_DIRECT_ctr);
+ PR_CTR(ENT_IND_ctr);
+ PR_CTR(ENT_PAP_ctr);
+ PR_CTR(ENT_THK_ctr);
+
+ PR_CTR(RET_NEW_IN_HEAP_ctr);
+ PR_CTR(RET_NEW_IN_REGS_ctr);
+ PR_CTR(RET_OLD_IN_HEAP_ctr);
+ PR_CTR(RET_OLD_IN_REGS_ctr);
+ PR_CTR(RET_SEMI_BY_DEFAULT_ctr);
+ PR_CTR(RET_SEMI_IN_HEAP_ctr);
+ PR_CTR(RET_SEMI_IN_REGS_ctr);
+ PR_CTR(RET_SEMI_FAILED_IND_ctr);
+ PR_CTR(RET_SEMI_FAILED_UNEVAL_ctr);
+ PR_CTR(VEC_RETURN_ctr);
+
+ PR_HST(RET_NEW_IN_HEAP_hst,0);
+ PR_HST(RET_NEW_IN_HEAP_hst,1);
+ PR_HST(RET_NEW_IN_HEAP_hst,2);
+ PR_HST(RET_NEW_IN_HEAP_hst,3);
+ PR_HST(RET_NEW_IN_HEAP_hst,4);
+ PR_HST(RET_NEW_IN_HEAP_hst,5);
+ PR_HST(RET_NEW_IN_HEAP_hst,6);
+ PR_HST(RET_NEW_IN_HEAP_hst,7);
+ PR_HST(RET_NEW_IN_HEAP_hst,8);
+ PR_HST(RET_NEW_IN_REGS_hst,0);
+ PR_HST(RET_NEW_IN_REGS_hst,1);
+ PR_HST(RET_NEW_IN_REGS_hst,2);
+ PR_HST(RET_NEW_IN_REGS_hst,3);
+ PR_HST(RET_NEW_IN_REGS_hst,4);
+ PR_HST(RET_NEW_IN_REGS_hst,5);
+ PR_HST(RET_NEW_IN_REGS_hst,6);
+ PR_HST(RET_NEW_IN_REGS_hst,7);
+ PR_HST(RET_NEW_IN_REGS_hst,8);
+ PR_HST(RET_OLD_IN_HEAP_hst,0);
+ PR_HST(RET_OLD_IN_HEAP_hst,1);
+ PR_HST(RET_OLD_IN_HEAP_hst,2);
+ PR_HST(RET_OLD_IN_HEAP_hst,3);
+ PR_HST(RET_OLD_IN_HEAP_hst,4);
+ PR_HST(RET_OLD_IN_HEAP_hst,5);
+ PR_HST(RET_OLD_IN_HEAP_hst,6);
+ PR_HST(RET_OLD_IN_HEAP_hst,7);
+ PR_HST(RET_OLD_IN_HEAP_hst,8);
+ PR_HST(RET_OLD_IN_REGS_hst,0);
+ PR_HST(RET_OLD_IN_REGS_hst,1);
+ PR_HST(RET_OLD_IN_REGS_hst,2);
+ PR_HST(RET_OLD_IN_REGS_hst,3);
+ PR_HST(RET_OLD_IN_REGS_hst,4);
+ PR_HST(RET_OLD_IN_REGS_hst,5);
+ PR_HST(RET_OLD_IN_REGS_hst,6);
+ PR_HST(RET_OLD_IN_REGS_hst,7);
+ PR_HST(RET_OLD_IN_REGS_hst,8);
+ PR_HST(RET_SEMI_IN_HEAP_hst,0);
+ PR_HST(RET_SEMI_IN_HEAP_hst,1);
+ PR_HST(RET_SEMI_IN_HEAP_hst,2);
+ PR_HST(RET_SEMI_IN_HEAP_hst,3);
+ PR_HST(RET_SEMI_IN_HEAP_hst,4);
+ PR_HST(RET_SEMI_IN_HEAP_hst,5);
+ PR_HST(RET_SEMI_IN_HEAP_hst,6);
+ PR_HST(RET_SEMI_IN_HEAP_hst,7);
+ PR_HST(RET_SEMI_IN_HEAP_hst,8);
+ PR_HST(RET_SEMI_IN_REGS_hst,0);
+ PR_HST(RET_SEMI_IN_REGS_hst,1);
+ PR_HST(RET_SEMI_IN_REGS_hst,2);
+ PR_HST(RET_SEMI_IN_REGS_hst,3);
+ PR_HST(RET_SEMI_IN_REGS_hst,4);
+ PR_HST(RET_SEMI_IN_REGS_hst,5);
+ PR_HST(RET_SEMI_IN_REGS_hst,6);
+ PR_HST(RET_SEMI_IN_REGS_hst,7);
+ PR_HST(RET_SEMI_IN_REGS_hst,8);
+ PR_HST(RET_VEC_RETURN_hst,0);
+ PR_HST(RET_VEC_RETURN_hst,1);
+ PR_HST(RET_VEC_RETURN_hst,2);
+ PR_HST(RET_VEC_RETURN_hst,3);
+ PR_HST(RET_VEC_RETURN_hst,4);
+ PR_HST(RET_VEC_RETURN_hst,5);
+ PR_HST(RET_VEC_RETURN_hst,6);
+ PR_HST(RET_VEC_RETURN_hst,7);
+ PR_HST(RET_VEC_RETURN_hst,8);
+
+ PR_CTR(RET_SEMI_loads_avoided);
+
+ PR_CTR(UPDF_OMITTED_ctr);
+ PR_CTR(UPDF_STD_PUSHED_ctr);
+ PR_CTR(UPDF_CON_PUSHED_ctr);
+ PR_CTR(UPDF_HOLE_PUSHED_ctr);
+
+ PR_CTR(UPDF_RCC_PUSHED_ctr);
+ PR_CTR(UPDF_RCC_OMITTED_ctr);
+
+ PR_CTR(UPD_EXISTING_ctr);
+ PR_CTR(UPD_SQUEEZED_ctr);
+ PR_CTR(UPD_CON_W_NODE_ctr);
+ PR_CTR(UPD_CON_IN_PLACE_ctr);
+ PR_CTR(UPD_CON_IN_NEW_ctr);
+ PR_CTR(UPD_PAP_IN_PLACE_ctr);
+ PR_CTR(UPD_PAP_IN_NEW_ctr);
+
+ PR_HST(UPD_CON_IN_PLACE_hst,0);
+ PR_HST(UPD_CON_IN_PLACE_hst,1);
+ PR_HST(UPD_CON_IN_PLACE_hst,2);
+ PR_HST(UPD_CON_IN_PLACE_hst,3);
+ PR_HST(UPD_CON_IN_PLACE_hst,4);
+ PR_HST(UPD_CON_IN_PLACE_hst,5);
+ PR_HST(UPD_CON_IN_PLACE_hst,6);
+ PR_HST(UPD_CON_IN_PLACE_hst,7);
+ PR_HST(UPD_CON_IN_PLACE_hst,8);
+ PR_HST(UPD_CON_IN_NEW_hst,0);
+ PR_HST(UPD_CON_IN_NEW_hst,1);
+ PR_HST(UPD_CON_IN_NEW_hst,2);
+ PR_HST(UPD_CON_IN_NEW_hst,3);
+ PR_HST(UPD_CON_IN_NEW_hst,4);
+ PR_HST(UPD_CON_IN_NEW_hst,5);
+ PR_HST(UPD_CON_IN_NEW_hst,6);
+ PR_HST(UPD_CON_IN_NEW_hst,7);
+ PR_HST(UPD_CON_IN_NEW_hst,8);
+ PR_HST(UPD_PAP_IN_NEW_hst,0);
+ PR_HST(UPD_PAP_IN_NEW_hst,1);
+ PR_HST(UPD_PAP_IN_NEW_hst,2);
+ PR_HST(UPD_PAP_IN_NEW_hst,3);
+ PR_HST(UPD_PAP_IN_NEW_hst,4);
+ PR_HST(UPD_PAP_IN_NEW_hst,5);
+ PR_HST(UPD_PAP_IN_NEW_hst,6);
+ PR_HST(UPD_PAP_IN_NEW_hst,7);
+ PR_HST(UPD_PAP_IN_NEW_hst,8);
+
+ PR_HST(UPD_ENTERED_hst,0);
+ PR_HST(UPD_ENTERED_hst,1);
+ PR_HST(UPD_ENTERED_hst,2);
+ PR_HST(UPD_ENTERED_hst,3);
+ PR_HST(UPD_ENTERED_hst,4);
+ PR_HST(UPD_ENTERED_hst,5);
+ PR_HST(UPD_ENTERED_hst,6);
+ PR_HST(UPD_ENTERED_hst,7);
+ PR_HST(UPD_ENTERED_hst,8);
+
+ PR_CTR(UPD_NEW_IND_ctr);
+ PR_CTR(UPD_NEW_IN_PLACE_PTRS_ctr);
+ PR_CTR(UPD_NEW_IN_PLACE_NOPTRS_ctr);
+ PR_CTR(UPD_OLD_IND_ctr);
+ PR_CTR(UPD_OLD_IN_PLACE_PTRS_ctr);
+ PR_CTR(UPD_OLD_IN_PLACE_NOPTRS_ctr);
+
+ PR_CTR(UPD_IN_PLACE_COPY_ctr);
+
+ PR_CTR(GC_SEL_ABANDONED_ctr);
+ PR_CTR(GC_SEL_MINOR_ctr);
+ PR_CTR(GC_SEL_MAJOR_ctr);
+ PR_CTR(GC_SHORT_IND_ctr);
+ PR_CTR(GC_SHORT_CAF_ctr);
+ PR_CTR(GC_COMMON_CHARLIKE_ctr);
+ PR_CTR(GC_COMMON_INTLIKE_ctr);
+ PR_CTR(GC_COMMON_INTLIKE_FAIL_ctr);
+ PR_CTR(GC_COMMON_CONST_ctr);
+}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[Ticky-ent-counters]{Handle named entry counters}
+%* *
+%************************************************************************
+
+Data structure used in ``registering'' one of these counters.
+\begin{code}
+struct ent_counter *ListOfEntryCtrs = NULL; /* root of list of them */
+\end{code}
+
+To print out all the registered-counter info:
+\begin{code}
+static void
+printRegisteredCounterInfo (FILE *tf)
+{
+ struct ent_counter *p;
+
+ if ( ListOfEntryCtrs != NULL ) {
+ fprintf(tf,"\n**************************************************\n");
+ }
+
+ for (p = ListOfEntryCtrs; p != NULL; p = p->link) {
+ /* common stuff first; then the wrapper info if avail */
+ fprintf(tf, "%-40s%u\t%u\t%u\t%-16s%ld",
+ p->f_str,
+ p->arity,
+ p->Astk_args,
+ p->Bstk_args,
+ p->f_arg_kinds,
+ p->ctr);
+
+ if ( p->wrap_str == NULL ) {
+ fprintf(tf, "\n");
+
+ } else {
+ fprintf(tf, "\t%s\t%s\n",
+ p->wrap_str,
+ p->wrap_arg_kinds);
+ }
+ }
+}
+\end{code}
+
+That's all, folks.
+\begin{code}
+#endif /* TICKY_TICKY */
+\end{code}
%****************************************************************/
\begin{code}
-#if defined(USE_COST_CENTRES) || defined(GUM) || defined(CONCURRENT)
+#if defined(PROFILING) || defined(PAR) || defined(CONCURRENT)
#define NON_POSIX_SOURCE /* time things on Solaris -- sigh */
#endif
# if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
# include <memory.h>
# endif /* not STDC_HEADERS and HAVE_MEMORY_H */
-# define index strchr
-# define rindex strrchr
-# define bcopy(s, d, n) memcpy ((d), (s), (n))
-# define bcmp(s1, s2, n) memcmp ((s1), (s2), (n))
-# define bzero(s, n) memset ((s), 0, (n))
+
#else /* not STDC_HEADERS and not HAVE_STRING_H */
# include <strings.h>
/* memory.h and strings.h conflict on some systems. */
#endif /* not STDC_HEADERS and not HAVE_STRING_H */
-#if defined(USE_COST_CENTRES) || defined(GUM)
+#if defined(PROFILING) || defined(PAR)
/* need some "time" things */
/* ToDo: This is a mess! Improve ? */
# ifdef HAVE_SYS_TIME_H
# include <sys/time.h>
# endif
-#endif /* USE_COST_CENTRES || GUM */
+#endif /* PROFILING || PAR */
#ifndef PAR
STGRegisterTable MainRegTable;
#endif
/* fwd decls */
-void setupRtsFlags PROTO((int *argc, char *argv[], I_ *rtsc, char *rtsv[]));
void shutdownHaskell(STG_NO_ARGS);
EXTFUN(startStgWorld);
-extern void PrintRednCountInfo(STG_NO_ARGS);
+extern void PrintTickyInfo(STG_NO_ARGS);
extern void checkAStack(STG_NO_ARGS);
/* a real nasty Global Variable */
/* structure to carry around info about the storage manager */
smInfo StorageMgrInfo;
-FILE *main_statsfile = NULL;
-#if defined(DO_REDN_COUNTING)
-FILE *tickyfile = NULL;
-#endif
-#if defined(SM_DO_BH_UPDATE)
-I_ noBlackHoles = 0;
-#endif
-I_ doSanityChks = 0;
-I_ showRednCountStats = 0;
-I_ traceUpdates = 0;
-extern I_ squeeze_upd_frames;
-
#ifdef PAR
-extern I_ OkToGC, buckets, average_stats();
-extern rtsBool TraceSparks, OutputDisabled, DelaySparks,
- DeferGlobalUpdates, ParallelStats;
+extern I_ OkToGC, buckets;
+extern rtsBool TraceSparks, DelaySparks,
+ DeferGlobalUpdates;
extern void RunParallelSystem PROTO((P_));
extern void initParallelSystem(STG_NO_ARGS);
extern void *stgReallocForGMP PROTO ((void *, size_t, size_t));
extern void stgDeallocForGMP PROTO ((void *, size_t));
-#if defined (DO_SPAT_PROFILING) && sparc_TARGET_ARCH
- /* NOTE: I, WDP, do not use this in my SPAT profiling */
-W_ KHHP, KHHPLIM, KHSPA, KHSPB;
-#endif
-
/* NeXTs can't just reach out and touch "end", to use in
distinguishing things in static vs dynamic (malloc'd) memory.
*/
void *get_end_result;
#endif
-I_ prog_argc;
+int prog_argc; /* an "int" so as to match normal "argc" */
char **prog_argv;
-I_ rts_argc;
+int rts_argc; /* ditto */
char *rts_argv[MAX_RTS_ARGS];
#ifndef PAR
unsigned nPEs = 0, nIMUs = 0;
#endif
-#if defined(GUM)
+#if defined(PAR)
int nPEs = 0;
#endif
int /* return type of "main" is defined by the C standard */
-main(argc, argv)
- int argc;
- char *argv[];
+main(int argc, char *argv[])
{
\end{code}
collecting timing statistics.
\begin{code}
-
start_time();
-
\end{code}
The parallel system needs to be initialised and synchronised before
\begin{code}
#ifdef PAR
/*
- * Grab the number of PEs out of the argument vector, and eliminate it
- * from further argument processing
+ * Grab the number of PEs out of the argument vector, and
+ * eliminate it from further argument processing.
*/
nPEs = atoi(argv[1]);
argv[1] = argv[0];
argv++;
argc--;
-/* fprintf(stderr, "I'm alive, nPEs = %d \n", nPEs); */
SynchroniseSystem();
#endif
-#if defined(USE_COST_CENTRES) || defined(GUM)
+#if defined(PROFILING) || defined(PAR)
/* setup string indicating time of run -- only used for profiling */
(void) time_str();
#endif
#endif
/*
- divide the command-line args between pgm and RTS;
- figure out what statsfile to use (if any);
- [if so, write the whole cmd-line into it]
+ divide the command-line args between pgm and RTS; figure out
+ what statsfile to use (if any); [if so, write the whole
+ cmd-line into it]
This is unlikely to work well in parallel! KH.
*/
+ initRtsFlagsDefaults();
+ defaultsHook(); /* the one supplied does nothing;
+ the user may have supplied a more interesting one.
+ */
+
setupRtsFlags(&argc, argv, &rts_argc, rts_argv);
prog_argc = argc;
prog_argv = argv;
initParallelSystem();
#endif /* PAR */
-#if defined(LIFE_PROFILE)
- if (life_profile_init(rts_argv, prog_argv) != 0) {
- fflush(stdout);
- fprintf(stderr, "life_profile_init failed!\n");
- EXIT(EXIT_FAILURE);
- }
-#endif
-
-#if defined(USE_COST_CENTRES) || defined(GUM)
+#if defined(PROFILING) || defined(PAR)
if (init_cc_profiling(rts_argc, rts_argv, prog_argv) != 0) {
fflush(stdout);
fprintf(stderr, "init_cc_profiling failed!\n");
#endif
#ifdef PAR
- if (do_gr_profile)
+ if (RTSflags.ParFlags.granSimStats)
init_gr_profiling(rts_argc, rts_argv, prog_argc, prog_argv);
#endif
- /*
- initialize the storage manager
- */
- if ( initSM(rts_argc, rts_argv, main_statsfile) != 0) {
- fflush(stdout);
- fprintf(stderr, "initSM failed!\n");
- EXIT(EXIT_FAILURE);
- }
+ /* initialize the storage manager */
+ initSM();
#ifndef PAR
- if ( initStacks( &StorageMgrInfo ) != 0) {
+ if (! initStacks( &StorageMgrInfo )) {
fflush(stdout);
fprintf(stderr, "initStacks failed!\n");
EXIT(EXIT_FAILURE);
}
#endif
- if ( initHeap( &StorageMgrInfo ) != 0) {
+ if (! initHeap( &StorageMgrInfo )) {
fflush(stdout);
- fprintf(stderr, "initHeap failed!\n"); EXIT(EXIT_FAILURE);
+ fprintf(stderr, "initHeap failed!\n");
+ EXIT(EXIT_FAILURE);
}
#if defined(CONCURRENT) && !defined(GRAN)
- if (!initThreadPools(MaxLocalSparks)) {
+ if (!initThreadPools()) {
fflush(stdout);
fprintf(stderr, "initThreadPools failed!\n");
EXIT(EXIT_FAILURE);
}
#endif
-#if defined(USE_COST_CENTRES) || defined(GUM)
+#if defined(PROFILING) || defined(PAR)
/* call cost centre registering routine (after heap allocated) */
cc_register();
#endif
-/* Information needed by runtime trace analysers -- don't even ask what it does! */
- /* NOTE: I, WDP, do not use this in my SPAT profiling */
-#if defined (DO_SPAT_PROFILING) && sparc_TARGET_ARCH
- KHHPLIM = (W_) StorageMgrInfo.hplim;
- KHHP = (W_) StorageMgrInfo.hp;
- KHSPA = (W_) SAVE_SpA,
- KHSPB = (W_) SAVE_SpB;
-
-/* fprintf(stderr,"Hp = %lx, HpLim = %lx, SpA = %lx, SpB = %lx\n",KHHP,KHHPLIM,KHSPA,KHSPB); */
-
-/* NOT ME:
- __asm__("sethi %%hi(_KHHP),%%o0\n\tld [%%o0+%%lo(_KHHP)],%%g0" : : : "%%o0");
- __asm__("sethi %%hi(_KHHPLIM),%%o0\n\tld [%%o0+%%lo(_KHHPLIM)],%%g0" : : : "%%o0");
- __asm__("sethi %%hi(_KHSPA),%%o0\n\tld [%%o0+%%lo(_KHSPA)],%%g0" : : : "%%o0");
- __asm__("sethi %%hi(_KHSPB),%%o0\n\tld [%%o0+%%lo(_KHSPB)],%%g0" : : : "%%o0");
-*/
-#endif
-
-#if defined(DO_REDN_COUNTING)
+#if defined(TICKY_TICKY)
max_SpA = MAIN_SpA; /* initial high-water marks */
max_SpB = MAIN_SpB;
#endif
/* Record initialization times */
end_init();
-#if defined(USE_COST_CENTRES) || defined(CONCURRENT)
+#if defined(PROFILING) || defined(CONCURRENT)
/*
* Both the context-switcher and the cost-center profiler use
* a virtual timer.
fprintf(stderr, "Can't install VTALRM handler.\n");
EXIT(EXIT_FAILURE);
}
-#if (defined(CONCURRENT) && defined(USE_COST_CENTRES)) || defined(GUM)
- if (time_profiling) {
- if (contextSwitchTime % (1000/TICK_FREQUENCY) == 0)
- tick_millisecs = TICK_MILLISECS;
+#if (defined(CONCURRENT) && defined(PROFILING)) || defined(PAR)
+ if (! time_profiling)
+ RTSflags.CcFlags.msecsPerTick = RTSflags.ConcFlags.ctxtSwitchTime;
+ else {
+ if (RTSflags.ConcFlags.ctxtSwitchTime % (1000/TICK_FREQUENCY) == 0)
+ RTSflags.CcFlags.msecsPerTick = TICK_MILLISECS;
else
- tick_millisecs = CS_MIN_MILLISECS;
+ RTSflags.CcFlags.msecsPerTick = CS_MIN_MILLISECS;
- contextSwitchTicks = contextSwitchTime / tick_millisecs;
- profilerTicks = TICK_MILLISECS / tick_millisecs;
- } else
- tick_millisecs = contextSwitchTime;
+ RTSflags.CcFlags.ctxtSwitchTicks = RTSflags.ConcFlags.ctxtSwitchTime / RTSflags.CcFlags.msecsPerTick;
+ RTSflags.CcFlags.profilerTicks = TICK_MILLISECS / RTSflags.CcFlags.msecsPerTick;
+ }
#endif
#ifndef CONCURRENT
START_TIME_PROFILER;
#endif
-#endif /* USE_COST_CENTRES || CONCURRENT */
+#endif /* PROFILING || CONCURRENT */
#ifndef PAR
setjmp(restart_main);
#else /* not threaded (sequential) */
-# if defined(__STG_TAILJUMPS__)
miniInterpret((StgFunPtr)startStgWorld);
-# else
- if (doSanityChks)
- miniInterpret_debug((StgFunPtr)startStgWorld, checkAStack);
- else
- miniInterpret((StgFunPtr)startStgWorld);
-# endif /* not tail-jumping */
+
#endif /* !CONCURRENT */
shutdownHaskell();
{
STOP_TIME_PROFILER;
- if (exitSM(&StorageMgrInfo) != 0) {
+ if (! exitSM(&StorageMgrInfo)) {
fflush(stdout);
fprintf(stderr, "exitSM failed!\n");
EXIT(EXIT_FAILURE);
}
-#if defined(LIFE_PROFILE)
- {
- extern P_ hp_start; /* from the SM -- Hack! */
- life_profile_finish(StorageMgrInfo.hp - hp_start, prog_argv);
- }
-#endif
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
heap_profile_finish();
#endif
-#if defined(USE_COST_CENTRES) || defined(GUM)
+#if defined(PROFILING) || defined(PAR)
report_cc_profiling(1 /* final */ );
#endif
-#if defined(DO_REDN_COUNTING)
- if (showRednCountStats) {
- PrintRednCountInfo();
- }
+#if defined(TICKY_TICKY)
+ if (RTSflags.TickyFlags.showTickyStats) PrintTickyInfo();
#endif
#if defined(GRAN_CHECK) && defined(GRAN)
}
\end{code}
-%/****************************************************************
-%* *
-%* Getting default settings for RTS parameters *
-%* *
-%* +RTS indicates following arguments destined for RTS *
-%* -RTS indicates following arguments destined for program *
-%* *
-%****************************************************************/
-\begin{code}
-
-char *flagtext[] = {
-"",
-"Usage: <prog> <args> [+RTS <rtsopts> | -RTS <args>] ... --RTS <args>",
-"",
-" +RTS Indicates run time system options follow",
-" -RTS Indicates program arguments follow",
-" --RTS Indicates that ALL subsequent arguments will be given to the",
-" program (including any of these RTS flags)",
-"",
-"The following run time system options are available:",
-"",
-" -? -f Prints this message and exits; the program is not executed",
-"",
-" -K<size> Sets the stack size (default 64k) Egs: -K32k -K512k",
-" -H<size> Sets the heap size (default 4M) -H512k -H16M",
-" -s<file> Summary GC statistics (default file: <program>.stat)",
-" -S<file> Detailed GC statistics (with -Sstderr going to stderr)",
-"",
-#if defined(GCap)
-" -M<n>% Sets minimum size of alloc area as % of heap (default 3%)",
-" -A<size> Fixes size of alloc area, overriding any minimum (-A gives 64k)",
-" -G<size> Fixes size of major generation (default is dynamic threshold)",
-" -F2s Forces program compiled for Appel gc to use 2s collection",
-#else
-# if defined(GCgn)
-" -A<size> Specifies size of alloc area (default 64k)",
-" -G<size> Fixes size of major generation (default is available heap)",
-" -F2s Forces program compiled for Gen gc to use 2s collection",
-# else
-" -M<n>% Minimum % of heap which must be available (default 3%)",
-" -A<size> Fixes size of heap area allocated between GCs (-A gives 64k)",
-# endif
-#endif
-#if defined(FORCE_GC)
-" -j<size> Forces major GC at every <size> bytes allocated",
-#endif /* FORCE_GC */
-#if defined(GCdu)
-" -u<percent> Fixes residency threshold at which mode switches (range 0.0..0.95)",
-#endif
-"",
-#if defined(SM_DO_BH_UPDATE)
-" -N No black-holing (for use when a signal handler is present)",
-#endif
-" -Z Don't squeeze out update frames on stack overflow",
-" -B Sound the bell at the start of each (major) garbage collection",
-#if defined(USE_COST_CENTRES) || defined(GUM)
-"",
-" -p<sort> Produce cost centre time profile (output file <program>.prof)",
-" sort: T = time (default), A = alloc, C = cost centre label",
-" -P<sort> Produce serial time profile (output file <program>.time)",
-" and a -p profile with detailed caf/enter/tick/alloc info",
-#if defined(USE_COST_CENTRES)
-"",
-" -h<break-down> Heap residency profile (output file <program>.hp)",
-" break-down: C = cost centre (default), M = module, G = group",
-" D = closure description, Y = type description",
-" T<ints>,<start> = time closure created",
-" ints: no. of interval bands plotted (default 18)",
-" start: seconds after which intervals start (default 0.0)",
-" A subset of closures may be selected by the attached cost centre using:",
-" -c{mod:lab,mod:lab...}, specific module:label cost centre(s)",
-" -m{mod,mod...} all cost centres from the specified modules(s)",
-" -g{grp,grp...} all cost centres from the specified group(s)",
-" Selections can also be made by description, type, kind and age:",
-" -d{des,des...} closures with specified closure descriptions",
-" -y{typ,typ...} closures with specified type descriptions",
-" -k{knd,knd...} closures of the specified kinds",
-" -a<age> closures which survived <age> complete intervals",
-" The selection logic used is summarised as follows:",
-" ([-c] or [-m] or [-g]) and ([-d] or [-y] or [-k]) and [-a]",
-" where an option is true if not specified",
-#endif
-"",
-" -z<tbl><size> set hash table <size> for <tbl> (C, M, G, D or Y)",
-"",
-" -i<secs> Number of seconds in a profiling interval (default 1.0):",
-" heap profile (-h) and/or serial time profile (-P) frequency",
-#endif /* USE_COST_CENTRES */
-#if defined(LIFE_PROFILE)
-"",
-" -l<res> Produce liftime and update profile (output file <program>.life)",
-" res: the age resolution in bytes allocated (default 10,000)",
-#endif /* LIFE_PROFILE */
-"",
-#if defined(DO_REDN_COUNTING)
-" -r<file> Produce reduction profiling statistics (with -rstderr for stderr)",
-"",
-#endif
-" -I Use debugging miniInterpret with stack and heap sanity-checking.",
-" -T<level> Trace garbage collection execution (debugging)",
-#ifdef CONCURRENT
-"",
-# ifdef PAR
-" -N<n> Use <n> PVMish processors in parallel (default: 2)",
-/* NB: the -N<n> is implemented by the driver!! */
-# endif
-" -C<secs> Context-switch interval in seconds",
-" (0 or no argument means switch as often as possible)",
-" the default is .01 sec; resolution is .01 sec",
-" -e<size> Size of spark pools (default 100)",
-# ifdef PAR
-" -q Enable activity profile (output files in ~/<program>*.gr)",
-" -qb Enable binary activity profile (output file /tmp/<program>.gb)",
-#else
-" -q[v] Enable quasi-parallel profile (output file <program>.qp)",
-# endif
-" -t<num> Set maximum number of advisory threads per PE (default 32)",
-" -o<num> Set stack chunk size (default 1024)",
-# ifdef PAR
-" -d Turn on PVM-ish debugging",
-" -O Disable output for performance measurement",
-# endif /* PAR */
-#endif /* CONCURRENT */
-"",
-"Other RTS options may be available for programs compiled a different way.",
-"The GHC User's Guide has full details.",
-"",
-0
-};
-
-#define RTS 1
-#define PGM 0
-
-#ifndef atof
-extern double atof();
-/* no proto because some machines use const and some do not */
-#endif
-
-void
-setupRtsFlags(argc, argv, rts_argc, rts_argv)
-int *argc;
-I_ *rts_argc;
-char *argv[], *rts_argv[];
-{
- I_ error = 0;
- I_ mode;
- I_ arg, total_arg;
- char *last_slash;
-
- /* Remove directory from argv[0] -- default files in current directory */
-
- if ((last_slash = (char *) rindex(argv[0], '/')) != NULL)
- strcpy(argv[0], last_slash+1);
-
- /* Split arguments (argv) into PGM (argv) and RTS (rts_argv) parts */
- /* argv[0] must be PGM argument -- leave in argv */
-
- total_arg = *argc;
- arg = 1;
-
- *argc = 1;
- *rts_argc = 0;
-
- for (mode = PGM; arg < total_arg && strcmp("--RTS", argv[arg]) != 0; arg++) {
- if (strcmp("+RTS", argv[arg]) == 0) {
- mode = RTS;
- }
- else if (strcmp("-RTS", argv[arg]) == 0) {
- mode = PGM;
- }
- else if (mode == RTS && *rts_argc < MAX_RTS_ARGS-1) {
- rts_argv[(*rts_argc)++] = argv[arg];
- }
- else if (mode == PGM) {
- argv[(*argc)++] = argv[arg];
- }
- else {
- fflush(stdout);
- fprintf(stderr, "setupRtsFlags: Too many RTS arguments (max %d)\n",
- MAX_RTS_ARGS-1);
- EXIT(EXIT_FAILURE);
- }
- }
- if (arg < total_arg) {
- /* arg must be --RTS; process remaining program arguments */
- while (++arg < total_arg) {
- argv[(*argc)++] = argv[arg];
- }
- }
- argv[*argc] = (char *) 0;
- rts_argv[*rts_argc] = (char *) 0;
-
- /* Process RTS (rts_argv) part: mainly to determine statsfile */
-
- for (arg = 0; arg < *rts_argc; arg++) {
- if (rts_argv[arg][0] == '-') {
- switch(rts_argv[arg][1]) {
- case '?':
- case 'f':
- error = 1;
- break;
-
- case 'Z': /* Don't squeeze out update frames */
- squeeze_upd_frames = 0;
- break;
-
-#if defined(SM_DO_BH_UPDATE)
- case 'N':
- noBlackHoles++;
- break;
-#endif
-
- case 'I':
- doSanityChks++;
-#if defined(__STG_TAILJUMPS__)
- /* Blech -- too many errors if run in parallel -- KH */
- fprintf(stderr, "setupRtsFlags: Using Tail Jumps: Sanity checks not possible: %s\n", rts_argv[arg]);
- error = 1;
-#endif
- break;
-
- case 'U':
- traceUpdates++;
-#if ! defined(DO_RUNTIME_TRACE_UPDATES)
- fprintf(stderr, "setupRtsFlags: Update Tracing not compiled in: %s\n", rts_argv[arg]);
- error = 1;
-#endif
- break;
-
- case 'r': /* Basic profiling stats */
- showRednCountStats++;
-#if ! defined(DO_REDN_COUNTING)
- fprintf(stderr, "setupRtsFlags: Reduction counting not compiled in: %s\n", rts_argv[arg]);
- error = 1;
-
-#else /* ticky-ticky! */
- if (strcmp(rts_argv[arg]+2, "stderr") == 0) /* use real stderr */
- tickyfile = stderr;
- else if (rts_argv[arg][2] != '\0') /* ticky file specified */
- tickyfile = fopen(rts_argv[arg]+2,"w");
- else {
- char stats_filename[STATS_FILENAME_MAXLEN]; /* default <program>.ticky */
- sprintf(stats_filename, TICKY_FILENAME_FMT, argv[0]);
- tickyfile = fopen(stats_filename,"w");
- }
- if (tickyfile == NULL) {
- fprintf(stderr, "Can't open tickyfile %s\n",
- rts_argv[arg]+2);
- error = 1;
- } else {
- /* Write argv and rtsv into start of ticky file */
- I_ count;
- for(count = 0; count < *argc; count++)
- fprintf(tickyfile, "%s ", argv[count]);
- fprintf(tickyfile, "+RTS ");
- for(count = 0; count < *rts_argc; count++)
- fprintf(tickyfile, "%s ", rts_argv[count]);
- fprintf(tickyfile, "\n");
- }
-#endif /* ticky-ticky! */
- break;
-
- case 's': /* Also used by GC -- open file here */
- case 'S':
-#ifdef PAR
- /* Opening all those files would almost certainly fail... */
- ParallelStats = rtsTrue;
- main_statsfile = stderr; /* temporary; ToDo: rm */
-#else
- if (strcmp(rts_argv[arg]+2, "stderr") == 0) /* use real stderr */
- main_statsfile = stderr;
- else if (rts_argv[arg][2] != '\0') /* stats file specified */
- main_statsfile = fopen(rts_argv[arg]+2,"w");
- else {
- char stats_filename[STATS_FILENAME_MAXLEN]; /* default <program>.stat */
- sprintf(stats_filename, STAT_FILENAME_FMT, argv[0]);
- main_statsfile = fopen(stats_filename,"w");
- }
- if (main_statsfile == NULL) {
- fprintf(stderr, "Can't open statsfile %s\n", rts_argv[arg]+2);
- error = 1;
- } else {
- /* Write argv and rtsv into start of stats file */
- I_ count;
- for(count = 0; count < *argc; count++)
- fprintf(main_statsfile, "%s ", argv[count]);
- fprintf(main_statsfile, "+RTS ");
- for(count = 0; count < *rts_argc; count++)
- fprintf(main_statsfile, "%s ", rts_argv[count]);
- fprintf(main_statsfile, "\n");
- }
-#endif
- break;
-
- case 'P': /* detailed cost centre profiling (time/alloc) */
- case 'p': /* cost centre profiling (time/alloc) */
- case 'i': /* serial profiling -- initial timer interval */
-#if ! (defined(USE_COST_CENTRES) || defined(GUM))
- fprintf(stderr, "setupRtsFlags: Not built for cost centre profiling: %s\n", rts_argv[arg]);
- error = 1;
-#endif /* ! (USE_COST_CENTRES || GUM) */
- break;
- case 'h': /* serial heap profile */
- case 'z': /* size of index tables */
- case 'c': /* cost centre label select */
- case 'm': /* cost centre module select */
- case 'g': /* cost centre group select */
- case 'd': /* closure descr select */
- case 'y': /* closure type select */
- case 'k': /* closure kind select */
- case 'a': /* closure age select */
-#if ! defined(USE_COST_CENTRES)
- fprintf(stderr, "setupRtsFlags: Not built for cost centre profiling: %s\n", rts_argv[arg]);
- error = 1;
-#endif /* ! USE_COST_CENTRES */
- break;
-
- case 'j': /* force GC option */
-#if defined(FORCE_GC)
- force_GC++;
- if (rts_argv[arg][2]) {
- GCInterval = decode(rts_argv[arg]+2) / sizeof(W_);
- }
-#else /* ! FORCE_GC */
- fprintf(stderr, "setupRtsFlags: Not built for forcing GC: %s\n", rts_argv[arg]);
- error = 1;
-#endif /* ! FORCE_GC */
- break;
-
- case 'l': /* life profile option */
-#if defined(LIFE_PROFILE)
- do_life_prof++;
- if (rts_argv[arg][2]) {
- LifeInterval = decode(rts_argv[arg]+2) / sizeof(W_);
- }
-#else /* ! LIFE_PROFILE */
- fprintf(stderr, "setupRtsFlags: Not built for lifetime profiling: %s\n", rts_argv[arg]);
- error = 1;
-#endif /* ! LIFE_PROFILE */
- break;
-
- /* Flags for the threaded RTS */
-
-#ifdef CONCURRENT
- case 'C': /* context switch interval */
- if (rts_argv[arg][2] != '\0') {
- /* Convert to milliseconds */
- contextSwitchTime = (I_) ((atof(rts_argv[arg]+2) * 1000));
- contextSwitchTime = (contextSwitchTime / CS_MIN_MILLISECS)
- * CS_MIN_MILLISECS;
- if (contextSwitchTime < CS_MIN_MILLISECS)
- contextSwitchTime = CS_MIN_MILLISECS;
- } else
- contextSwitchTime = 0;
- break;
-#if !defined(GRAN)
- case 'e':
- if (rts_argv[arg][2] != '\0') {
- MaxLocalSparks = strtol(rts_argv[arg]+2, (char **) NULL, 10);
- if (MaxLocalSparks <= 0) {
- fprintf(stderr, "setupRtsFlags: bad value for -e\n");
- error = 1;
- }
- } else
- MaxLocalSparks = DEFAULT_MAX_LOCAL_SPARKS;
- break;
-#endif
-#ifdef PAR
- case 'q': /* activity profile option */
- if (rts_argv[arg][2] == 'b')
- do_gr_binary++;
- else
- do_gr_profile++;
- break;
-#else
- case 'q': /* quasi-parallel profile option */
- if (rts_argv[arg][2] == 'v')
- do_qp_prof = 2;
- else
- do_qp_prof++;
- break;
-#endif
- case 't':
- if (rts_argv[arg][2] != '\0') {
- MaxThreads = strtol(rts_argv[arg]+2, (char **) NULL, 10);
- } else {
- fprintf(stderr, "setupRtsFlags: missing size for -t\n");
- error = 1;
- }
- break;
-
- case 'o':
- if (rts_argv[arg][2] != '\0') {
- StkOChunkSize = decode(rts_argv[arg]+2);
- if (StkOChunkSize < MIN_STKO_CHUNK_SIZE)
- StkOChunkSize = MIN_STKO_CHUNK_SIZE;
- } else {
- fprintf(stderr, "setupRtsFlags: missing size for -o\n");
- error = 1;
- }
- break;
-
-# ifdef PAR
- case 'O':
- OutputDisabled = rtsTrue;
- break;
-
-# else /* PAR */
-
-# if !defined(GRAN)
- case 'b': /* will fall through to disaster */
-# else
- case 'b':
- if (rts_argv[arg][2] != '\0') {
-
- /* Should we emulate hbcpp */
- if(strcmp((rts_argv[arg]+2),"roken")==0) {
- ++DoAlwaysCreateThreads;
- strcpy(rts_argv[arg]+2,"oring");
- }
-
- /* or a ridiculously idealised simulator */
- if(strcmp((rts_argv[arg]+2),"oring")==0) {
- gran_latency = gran_fetchtime = gran_additional_latency =
- gran_gunblocktime = gran_lunblocktime
- = gran_threadcreatetime = gran_threadqueuetime
- = gran_threadscheduletime = gran_threaddescheduletime
- = gran_threadcontextswitchtime
- = 0;
-
- gran_mpacktime = gran_munpacktime = 0;
-
- gran_arith_cost = gran_float_cost = gran_load_cost
- = gran_store_cost = gran_branch_cost = 0;
-
- gran_heapalloc_cost = 1;
-
- /* ++DoFairSchedule; */
- ++DoStealThreadsFirst;
- ++DoThreadMigration;
- ++do_gr_profile;
- }
-
- /* or a ridiculously idealised simulator */
- if(strcmp((rts_argv[arg]+2),"onzo")==0) {
- gran_latency = gran_fetchtime = gran_additional_latency =
- gran_gunblocktime = gran_lunblocktime
- = gran_threadcreatetime = gran_threadqueuetime
- = gran_threadscheduletime = gran_threaddescheduletime
- = gran_threadcontextswitchtime
- = 0;
-
- gran_mpacktime = gran_munpacktime = 0;
-
- /* Keep default values for these
- gran_arith_cost = gran_float_cost = gran_load_cost
- = gran_store_cost = gran_branch_cost = 0;
- */
-
- gran_heapalloc_cost = 1;
-
- /* ++DoFairSchedule; */ /* -b-R */
- /* ++DoStealThreadsFirst; */ /* -b-T */
- ++DoReScheduleOnFetch; /* -bZ */
- ++DoThreadMigration; /* -bM */
- ++do_gr_profile; /* -bP */
-# if defined(GRAN_CHECK) && defined(GRAN)
- debug = 0x20; /* print event statistics */
-# endif
- }
-
- /* Communication and task creation cost parameters */
- else switch(rts_argv[arg][2]) {
- case 'l':
- if (rts_argv[arg][3] != '\0')
- {
- gran_gunblocktime = gran_latency = decode(rts_argv[arg]+3);
- gran_fetchtime = 2* gran_latency;
- }
- else
- gran_latency = LATENCY;
- break;
-
- case 'a':
- if (rts_argv[arg][3] != '\0')
- gran_additional_latency = decode(rts_argv[arg]+3);
- else
- gran_additional_latency = ADDITIONAL_LATENCY;
- break;
-
- case 'm':
- if (rts_argv[arg][3] != '\0')
- gran_mpacktime = decode(rts_argv[arg]+3);
- else
- gran_mpacktime = MSGPACKTIME;
- break;
-
- case 'x':
- if (rts_argv[arg][3] != '\0')
- gran_mtidytime = decode(rts_argv[arg]+3);
- else
- gran_mtidytime = 0;
- break;
-
- case 'r':
- if (rts_argv[arg][3] != '\0')
- gran_munpacktime = decode(rts_argv[arg]+3);
- else
- gran_munpacktime = MSGUNPACKTIME;
- break;
-
- case 'f':
- if (rts_argv[arg][3] != '\0')
- gran_fetchtime = decode(rts_argv[arg]+3);
- else
- gran_fetchtime = FETCHTIME;
- break;
-
- case 'n':
- if (rts_argv[arg][3] != '\0')
- gran_gunblocktime = decode(rts_argv[arg]+3);
- else
- gran_gunblocktime = GLOBALUNBLOCKTIME;
- break;
-
- case 'u':
- if (rts_argv[arg][3] != '\0')
- gran_lunblocktime = decode(rts_argv[arg]+3);
- else
- gran_lunblocktime = LOCALUNBLOCKTIME;
- break;
-
- /* Thread-related metrics */
- case 't':
- if (rts_argv[arg][3] != '\0')
- gran_threadcreatetime = decode(rts_argv[arg]+3);
- else
- gran_threadcreatetime = THREADCREATETIME;
- break;
-
- case 'q':
- if (rts_argv[arg][3] != '\0')
- gran_threadqueuetime = decode(rts_argv[arg]+3);
- else
- gran_threadqueuetime = THREADQUEUETIME;
- break;
-
- case 'c':
- if (rts_argv[arg][3] != '\0')
- gran_threadscheduletime = decode(rts_argv[arg]+3);
- else
- gran_threadscheduletime = THREADSCHEDULETIME;
-
- gran_threadcontextswitchtime = gran_threadscheduletime
- + gran_threaddescheduletime;
- break;
-
- case 'd':
- if (rts_argv[arg][3] != '\0')
- gran_threaddescheduletime = decode(rts_argv[arg]+3);
- else
- gran_threaddescheduletime = THREADDESCHEDULETIME;
-
- gran_threadcontextswitchtime = gran_threadscheduletime
- + gran_threaddescheduletime;
- break;
-
- /* Instruction Cost Metrics */
- case 'A':
- if (rts_argv[arg][3] != '\0')
- gran_arith_cost = decode(rts_argv[arg]+3);
- else
- gran_arith_cost = ARITH_COST;
- break;
-
- case 'F':
- if (rts_argv[arg][3] != '\0')
- gran_float_cost = decode(rts_argv[arg]+3);
- else
- gran_float_cost = FLOAT_COST;
- break;
-
- case 'B':
- if (rts_argv[arg][3] != '\0')
- gran_branch_cost = decode(rts_argv[arg]+3);
- else
- gran_branch_cost = BRANCH_COST;
- break;
-
- case 'L':
- if (rts_argv[arg][3] != '\0')
- gran_load_cost = decode(rts_argv[arg]+3);
- else
- gran_load_cost = LOAD_COST;
- break;
-
- case 'S':
- if (rts_argv[arg][3] != '\0')
- gran_store_cost = decode(rts_argv[arg]+3);
- else
- gran_store_cost = STORE_COST;
- break;
-
- case 'H':
- if (rts_argv[arg][3] != '\0')
- gran_heapalloc_cost = decode(rts_argv[arg]+3);
- else
- gran_heapalloc_cost = 0;
- break;
-
- case 'y':
- if (rts_argv[arg][3] != '\0')
- FetchStrategy = decode(rts_argv[arg]+3);
- else
- FetchStrategy = 4; /* default: fetch everything */
- break;
-
- /* General Parameters */
- case 'p':
- if (rts_argv[arg][3] != '\0')
- {
- max_proc = decode(rts_argv[arg]+3);
- if(max_proc > MAX_PROC || max_proc < 1)
- {
- fprintf(stderr,"setupRtsFlags: no more than %u processors allowed\n", MAX_PROC);
- error = 1;
- }
- }
- else
- max_proc = MAX_PROC;
- break;
-
- case 'C':
- ++DoAlwaysCreateThreads;
- ++DoThreadMigration;
- break;
-
- case 'G':
- ++DoGUMMFetching;
- break;
-
- case 'M':
- ++DoThreadMigration;
- break;
-
- case 'R':
- ++DoFairSchedule;
- break;
-
- case 'T':
- ++DoStealThreadsFirst;
- ++DoThreadMigration;
- break;
-
- case 'Z':
- ++DoReScheduleOnFetch;
- break;
-
- case 'z':
- ++SimplifiedFetch;
- break;
-
- case 'N':
- ++PreferSparksOfLocalNodes;
- break;
-
- case 'b':
- ++do_gr_binary;
- break;
-
- case 'P':
- ++do_gr_profile;
- break;
-
- case 's':
- ++do_sp_profile;
- break;
-
- case '-':
- switch(rts_argv[arg][3]) {
-
- case 'C':
- DoAlwaysCreateThreads=0;
- DoThreadMigration=0;
- break;
-
- case 'G':
- DoGUMMFetching=0;
- break;
-
- case 'M':
- DoThreadMigration=0;
- break;
-
- case 'R':
- DoFairSchedule=0;
- break;
-
- case 'T':
- DoStealThreadsFirst=0;
- DoThreadMigration=0;
- break;
-
- case 'Z':
- DoReScheduleOnFetch=0;
- break;
-
- case 'N':
- PreferSparksOfLocalNodes=0;
- break;
-
- case 'P':
- do_gr_profile=0;
- no_gr_profile=1;
- break;
-
- case 's':
- do_sp_profile=0;
- break;
-
- case 'b':
- do_gr_binary=0;
- break;
-
- default:
- badoption( rts_argv[arg] );
- break;
- }
- break;
-
-# if defined(GRAN_CHECK) && defined(GRAN)
- case 'D':
- switch(rts_argv[arg][3]) {
- case 'e': /* event trace */
- fprintf(stderr,"Printing event trace.\n");
- ++event_trace;
- break;
-
- case 'f':
- fprintf(stderr,"Printing forwarding of FETCHNODES.\n");
- debug |= 0x2; /* print fwd messages */
- break;
-
- case 'z':
- fprintf(stderr,"Check for blocked on fetch.\n");
- debug |= 0x4; /* debug non-reschedule-on-fetch */
- break;
-
- case 't':
- fprintf(stderr,"Check for TSO asleep on fetch.\n");
- debug |= 0x10; /* debug TSO asleep for fetch */
- break;
-
- case 'E':
- fprintf(stderr,"Printing event statistics.\n");
- debug |= 0x20; /* print event statistics */
- break;
-
- case 'F':
- fprintf(stderr,"Prohibiting forward.\n");
- NoForward = 1; /* prohibit forwarding */
- break;
-
- case 'm':
- fprintf(stderr,"Printing fetch misses.\n");
- PrintFetchMisses = 1; /* prohibit forwarding */
- break;
-
- case 'd':
- fprintf(stderr,"Debug mode.\n");
- debug |= 0x40;
- break;
-
- case 'D':
- fprintf(stderr,"Severe debug mode.\n");
- debug |= 0x80;
- break;
-
- case '\0':
- debug = 1;
- break;
-
- default:
- badoption( rts_argv[arg] );
- break;
- }
- break;
-# endif
- default:
- badoption( rts_argv[arg] );
- break;
- }
- }
- do_gr_sim++;
- contextSwitchTime = 0;
- break;
-# endif
- case 'J':
- case 'Q':
- case 'D':
- case 'R':
- case 'L':
- case 'O':
- fprintf(stderr, "setupRtsFlags: Not built for parallel execution: %s\n", rts_argv[arg]);
- error = 1;
-# endif /* PAR */
-#else /* CONCURRENT */
- case 't':
- fprintf(stderr, "setupRtsFlags: Not built for threaded execution: %s\n", rts_argv[arg]);
- error = 1;
-
-#endif /* CONCURRENT */
- case 'H': /* SM options -- ignore */
- case 'A':
- case 'G':
- case 'F':
- case 'K':
- case 'M':
- case 'B':
- case 'T':
-#ifdef GCdu
- case 'u': /* set dual mode threshold */
-#endif
- break;
-
- default: /* Unknown option ! */
- fprintf(stderr, "setupRtsFlags: Unknown RTS option: %s\n", rts_argv[arg]);
- error = 1;
- break;
- }
- }
- else {
- fflush(stdout);
- fprintf(stderr, "setupRtsFlags: Unexpected RTS argument: %s\n",
- rts_argv[arg]);
- error = 1;
- }
- }
- if (error == 1) {
- char **p;
- fflush(stdout);
- for (p = flagtext; *p; p++)
- fprintf(stderr, "%s\n", *p);
- EXIT(EXIT_FAILURE);
- }
-}
-\end{code}
-
Sets up and returns a string indicating the date/time of the run.
Successive calls simply return the same string again. Initially
called by @main.lc@ to initialise the string at the start of the run.
Only used for profiling.
\begin{code}
-#if defined(USE_COST_CENTRES) || defined(CONCURRENT)
+#if defined(PROFILING) || defined(CONCURRENT)
# include <time.h>
char *
ToDo: Will this work under threads?
\begin{code}
-StgStablePtr errorHandler = -1;
+StgStablePtr errorHandler = -1; /* NB: prone to magic-value-ery (WDP 95/12) */
-StgInt getErrorHandler()
+StgInt
+getErrorHandler(STG_NO_ARGS)
{
return (StgInt) errorHandler;
}
#ifndef PAR
-void raiseError( handler )
-StgStablePtr handler;
+void
+raiseError( handler )
+ StgStablePtr handler;
{
- if (handler == -1) {
+ if (handler == -1) { /* beautiful magic value... (WDP 95/12) */
shutdownHaskell();
+ EXIT(EXIT_FAILURE);
} else {
TopClosure = deRefStablePointer( handler );
longjmp(restart_main,1);
\begin{code}
StgInt
catchError( newErrorHandler )
-StgStablePtr newErrorHandler;
+ StgStablePtr newErrorHandler;
{
StgStablePtr oldErrorHandler = errorHandler;
errorHandler = newErrorHandler;
#define BYTES2X(ctype,htype) \
I_ \
-CAT3(bytes2,ctype,__)(in, out) \
- P_ in; \
- htype *out; \
+CAT3(bytes2,ctype,__)(P_ in, htype *out) \
{ \
union { \
ctype i; \
static STG_INLINE
void
-assign_flt(p_dest, src)
- W_ p_dest[];
- StgFloat src;
+assign_flt(W_ p_dest[], StgFloat src)
{
float_thing y;
y.f = src;
static STG_INLINE
void
-assign_dbl(p_dest, src)
- W_ p_dest[];
- StgDouble src;
+assign_dbl(W_ p_dest[], StgDouble src)
{
double_thing y;
y.d = src;
#define BYTES2FX(ctype,htype,assign_fx) \
I_ \
-CAT3(bytes2,ctype,__)(in, out) \
- P_ in; \
- htype *out; \
+CAT3(bytes2,ctype,__)(P_ in, htype *out) \
{ \
union { \
ctype i; \
STG_INLINE
void
-#ifdef __STDC__
ASSIGN_DBL(W_ p_dest[], StgDouble src)
-#else
-ASSIGN_DBL(p_dest, src)
- W_ p_dest[]; StgDouble src;
-#endif
{
double_thing y;
y.d = src;
STG_INLINE
StgDouble
-#ifdef __STDC__
PK_DBL(W_ p_src[])
-#else
-PK_DBL(p_src)
- W_ p_src[];
-#endif
{
double_thing y;
y.du.dhi = p_src[0];
STG_INLINE
void
-#ifdef __STDC__
ASSIGN_FLT(W_ p_dest[], StgFloat src)
-#else
-ASSIGN_FLT(p_dest, src)
- W_ p_dest[]; StgFloat src;
-#endif
{
float_thing y;
y.f = src;
STG_INLINE
StgFloat
-#ifdef __STDC__
PK_FLT(W_ p_src[])
-#else
-PK_FLT(p_src)
- W_ p_src[];
-#endif
{
float_thing y;
y.fu = *p_src;
\begin{code}
StgDouble
-#if __STDC__
__encodeDouble (MP_INT *s, I_ e) /* result = s * 2^e */
-#else
-__encodeDouble (s, e)
- MP_INT *s; I_ e;
-#endif /* ! __STDC__ */
{
StgDouble r;
I_ i;
r = -r;
/*
- temp = xmalloc(mpz_sizeinbase(s,10)+2);
+ temp = stgMallocBytes(mpz_sizeinbase(s,10)+2);
fprintf(stderr, "__encodeDouble(%s, %ld) => %g\n", mpz_get_str(temp,10,s), e, r);
*/
#if ! alpha_TARGET_ARCH
/* On the alpha, Stg{Floats,Doubles} are the same */
StgFloat
-#if __STDC__
__encodeFloat (MP_INT *s, I_ e) /* result = s * 2^e */
-#else
-__encodeFloat (s, e)
- MP_INT *s; I_ e;
-#endif /* ! __STDC__ */
{
StgFloat r;
I_ i;
#endif /* alpha */
void
-#if __STDC__
__decodeDouble (MP_INT *man, I_ *exp, StgDouble dbl)
-#else
-__decodeDouble (man, exp, dbl)
- MP_INT *man;
- I_ *exp;
- StgDouble dbl;
-#endif /* ! __STDC__ */
{
#if ! IEEE_FLOATING_POINT
fprintf(stderr, "__decodeDouble: non-IEEE not yet supported\n");
}
/*
- temp = xmalloc(mpz_sizeinbase(man,10)+2);
+ temp = stgMallocBytes(mpz_sizeinbase(man,10)+2);
fprintf(stderr, "__decodeDouble(%g) => %s, %ld\n", dbl, mpz_get_str(temp,10,man), *exp);
*/
#if ! alpha_TARGET_ARCH
/* Again, on the alpha we do not have separate "StgFloat" routines */
void
-#if __STDC__
__decodeFloat (MP_INT *man, I_ *exp, StgFloat flt)
-#else
-__decodeFloat (man, exp, flt)
- MP_INT *man;
- I_ *exp;
- StgFloat flt;
-#endif /* ! __STDC__ */
{
#if ! IEEE_FLOATING_POINT
fprintf(stderr, "__decodeFloat: non-IEEE not yet supported\n");
*/
SAVE_Hp += total_size_in_words;
-#if ! defined(DO_SPAT_PROFILING)
- /* Note: ActivityReg is not defined in this .lc file */
-
ALLOC_HEAP(total_size_in_words); /* ticky-ticky profiling */
/* ALLOC_CON(DATA_HS,data_size_in_words,0); */
ALLOC_PRIM(DATA_HS,data_size_in_words,0,total_size_in_words);
-#endif /* ! DO_SPAT_PROFILING */
+
CC_ALLOC(CCC,total_size_in_words,CON_K); /* cc profiling */
/* NB: HACK WARNING: The above line will do The WRONG THING
if the CurrCostCentre reg is ever put in a Real Machine Register (TM).
*/
-#if defined(LIFE_PROFILE) /* HACK warning -- Bump HpLim (see also StgMacros.lh)*/
- SAVE_HpLim += 1; /* SET_DATA_HDR attempted HpLim++ in wrong window */
-#endif
-
/* and return what we said we would */
return(stuff_ptr);
}
#include "rtsdefs.h"
\end{code}
-Only have cost centres if @USE_COST_CENTRES@ defined (by the driver),
-or if running CONCURRENT.
+Only have cost centres if @PROFILING@ defined (by the driver),
+or if running PAR.
\begin{code}
-#if defined(USE_COST_CENTRES) || defined(CONCURRENT)
+#if defined(PROFILING) || defined(PAR)
CC_DECLARE(CC_MAIN, "MAIN", "MAIN", "MAIN", CC_IS_BORING,/*not static*/);
CC_DECLARE(CC_GC, "GC", "GC", "GC", CC_IS_BORING,/*not static*/);
-# ifdef GUM
+# ifdef PAR
CC_DECLARE(CC_MSG, "MSG", "MSG", "MSG", CC_IS_BORING,/*not static*/);
CC_DECLARE(CC_IDLE, "IDLE", "IDLE", "IDLE", CC_IS_BORING,/*not static*/);
# endif
\begin{code}
CostCentre CCC; /* _not_ initialised */
-#endif /* defined(USE_COST_CENTRES) || defined(CONCURRENT) */
+#endif /* defined(PROFILING) || defined(PAR) */
\end{code}
The rest is for real cost centres (not thread activities).
\begin{code}
-#if defined(USE_COST_CENTRES) || defined(GUM)
+#if defined(PROFILING) || defined(PAR)
\end{code}
%************************************************************************
%* *
-\subsection[initial-cost-centres]{Initial Cost Centres}
+\subsection{Initial Cost Centres}
%* *
%************************************************************************
Cost centres which are always required:
\begin{code}
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
CC_DECLARE(CC_OVERHEAD, "OVERHEAD_of", "PROFILING", "MAIN", CC_IS_CAF,/*not static*/);
CC_DECLARE(CC_SUBSUMED, "SUBSUMED", "MAIN", "MAIN", CC_IS_SUBSUMED,/*not static*/);
CostCentre Registered_CC = REGISTERED_END;
\end{code}
+
%************************************************************************
%* *
-\subsection[profiling-arguments]{Profiling RTS Arguments}
+\subsection{Profiling RTS Arguments}
%* *
%************************************************************************
\begin{code}
-I_ cc_profiling = 0; /* 0 => not "cc_profiling"
- >1 => do serial time profile
- (other magic meanings, too, apparently) WDP 94/07
- */
-char cc_profiling_sort = SORTCC_TIME;
I_ dump_intervals = 0;
/* And for the report ... */
I_ rts_argc;
char *rts_argv[], *prog_argv[];
{
- I_ arg, ch, error = 0;
- I_ prof_req = 0;
+ I_ arg, ch;
+#ifndef PAR
char *select_cc = 0;
char *select_mod = 0;
char *select_grp = 0;
char *select_descr = 0;
char *select_type = 0;
char *select_kind = 0;
- I_ select_age = 0;
char *left, *right;
+#endif
prog_argv_save = prog_argv;
rts_argv_save = rts_argv;
-#ifdef GUM
+#ifdef PAR
sprintf(prof_filename, PROF_FILENAME_FMT_GUM, prog_argv[0], thisPE);
#else
sprintf(prof_filename, PROF_FILENAME_FMT, prog_argv[0]);
#endif
- for (arg = 0; arg < rts_argc; arg++) {
- if (rts_argv[arg][0] == '-') {
- switch (rts_argv[arg][1]) {
- case 'P': /* detailed cost centre profiling (time/alloc) */
- cc_profiling++;
- case 'p': /* cost centre profiling (time/alloc) */
- cc_profiling++;
- for (ch = 2; rts_argv[arg][ch]; ch++) {
- switch (rts_argv[arg][2]) {
- case SORTCC_LABEL:
- case SORTCC_TIME:
- case SORTCC_ALLOC:
- cc_profiling_sort = rts_argv[arg][ch];
- break;
- default:
- fprintf(stderr, "Invalid profiling sort option %s\n", rts_argv[arg]);
- error = 1;
- }}
- break;
-
-#if defined(USE_COST_CENTRES)
- case 'h': /* serial heap profile */
- switch (rts_argv[arg][2]) {
- case '\0':
- case CCchar:
- prof_req = HEAP_BY_CC;
- break;
- case MODchar:
- prof_req = HEAP_BY_MOD;
- break;
- case GRPchar:
- prof_req = HEAP_BY_GRP;
- break;
- case DESCRchar:
- prof_req = HEAP_BY_DESCR;
- break;
- case TYPEchar:
- prof_req = HEAP_BY_TYPE;
- break;
- case TIMEchar:
- prof_req = HEAP_BY_TIME;
- if (rts_argv[arg][3]) {
- char *start_str = strchr(rts_argv[arg]+3, ',');
- I_ intervals;
- if (start_str) *start_str = '\0';
-
- if ((intervals = decode(rts_argv[arg]+3)) != 0) {
- time_intervals = (hash_t) intervals;
- /* ToDo: and what if it *is* zero intervals??? */
- }
- if (start_str) {
- earlier_ticks = (I_)((atof(start_str + 1) * TICK_FREQUENCY));
- }
- }
- break;
- default:
- fprintf(stderr, "Invalid heap profile option: %s\n",
- rts_argv[arg]);
- error = 1;
- }
- break;
-
- case 'z': /* size of index tables */
- switch (rts_argv[arg][2]) {
- case CCchar:
- max_cc_no = (hash_t) decode(rts_argv[arg]+3);
- if (max_cc_no == 0) {
- fprintf(stderr, "Bad number of cost centres %s\n", rts_argv[arg]);
- error = 1;
- }
- break;
- case MODchar:
- max_mod_no = (hash_t) decode(rts_argv[arg]+3);
- if (max_mod_no == 0) {
- fprintf(stderr, "Bad number of modules %s\n", rts_argv[arg]);
- error = 1;
- }
- break;
- case GRPchar:
- max_grp_no = (hash_t) decode(rts_argv[arg]+3);
- if (max_grp_no == 0) {
- fprintf(stderr, "Bad number of groups %s\n", rts_argv[arg]);
- error = 1;
- }
- break;
- case DESCRchar:
- max_descr_no = (hash_t) decode(rts_argv[arg]+3);
- if (max_descr_no == 0) {
- fprintf(stderr, "Bad number of closure descriptions %s\n", rts_argv[arg]);
- error = 1;
- }
- break;
- case TYPEchar:
- max_type_no = (hash_t) decode(rts_argv[arg]+3);
- if (max_type_no == 0) {
- fprintf(stderr, "Bad number of type descriptions %s\n", rts_argv[arg]);
- error = 1;
- }
- break;
- default:
- fprintf(stderr, "Invalid index table size option: %s\n",
- rts_argv[arg]);
- error = 1;
- }
- break;
-
- case 'c': /* cost centre label select */
- case 'm': /* cost centre module select */
- case 'g': /* cost centre group select */
- case 'd': /* closure descr select */
- case 'y': /* closure type select */
- case 'k': /* closure kind select */
- left = strchr(rts_argv[arg], '{');
- right = strrchr(rts_argv[arg], '}');
- if (! left || ! right ||
- strrchr(rts_argv[arg], '{') != left ||
- strchr(rts_argv[arg], '}') != right) {
- fprintf(stderr, "Invalid heap profiling selection bracketing\n %s\n", rts_argv[arg]);
- error = 1;
- } else {
- *right = '\0';
- switch (rts_argv[arg][1]) {
- case 'c': /* cost centre label select */
- select_cc = left + 1;
- break;
- case 'm': /* cost centre module select */
- select_mod = left + 1;
- break;
- case 'g': /* cost centre group select */
- select_grp = left + 1;
- break;
- case 'd': /* closure descr select */
- select_descr = left + 1;
- break;
- case 't': /* closure type select */
- select_type = left + 1;
- break;
- case 'k': /* closure kind select */
- select_kind = left + 1;
- break;
- }
- }
- break;
-
- case 'a': /* closure age select */
- select_age = decode(rts_argv[arg]+2);
-
-#endif /* defined(USE_COST_CENTRES) */
-
- case 'i': /* serial profiling -- initial timer interval */
- interval_ticks = (I_) ((atof(rts_argv[arg]+2) * TICK_FREQUENCY));
- if (interval_ticks <= 0)
- interval_ticks = 1;
- break;
- }
- }
- }
- if (error) return 1;
-
/* Now perform any work to initialise profiling ... */
- if (cc_profiling || prof_req != HEAP_NO_PROFILING) {
+ if (RTSflags.CcFlags.doCostCentres
+#ifdef PROFILING
+ || RTSflags.ProfFlags.doHeapProfile
+#endif
+ ) {
time_profiling++;
/* set dump_intervals: if heap profiling only dump every 10 intervals */
- if (prof_req == HEAP_NO_PROFILING) {
- dump_intervals = 1;
- } else {
- dump_intervals = 10;
- }
+#ifdef PROFILING
+ dump_intervals = (RTSflags.ProfFlags.doHeapProfile) ? 10 : 1;
+#else
+ dump_intervals = 1;
+#endif
- if (cc_profiling > 1) {
+ if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) {
/* produce serial time profile */
-#ifdef GUM
+#ifdef PAR
sprintf(serial_filename, TIME_FILENAME_FMT_GUM, prog_argv[0], thisPE);
#else
sprintf(serial_filename, TIME_FILENAME_FMT, prog_argv[0]);
fprintf(serial_file, "DATE \"%s\"\n", time_str());
fprintf(serial_file, "SAMPLE_UNIT \"seconds\"\n");
+#ifdef PAR
+ fprintf(serial_file, "VALUE_UNIT \"percentage time\"\n");
+#else
fprintf(serial_file, "VALUE_UNIT \"time ticks\"\n");
+#endif
/* output initial 0 sample */
fprintf(serial_file, "BEGIN_SAMPLE 0.00\n");
}
}
-#if defined(USE_COST_CENTRES)
- if (heap_profile_init(prof_req, select_cc, select_mod, select_grp,
- select_descr, select_type, select_kind,
- select_age, prog_argv))
+#if defined(PROFILING)
+ if (heap_profile_init(select_cc, select_mod, select_grp,
+ select_descr, select_type, select_kind,
+ prog_argv))
return 1;
#endif
\begin{code}
extern P_ heap_space; /* pointer to the heap space */
StgFunPtr * register_stack; /* stack of register routines -- heap area used */
-extern I_ heap_profiling_req;
EXTFUN(startCcRegisteringWorld);
REGISTER_CC(CC_MAIN); /* register cost centre CC_MAIN */
REGISTER_CC(CC_GC); /* register cost centre CC_GC */
-#if defined(GUM)
+#if defined(PAR)
REGISTER_CC(CC_MSG); /* register cost centre CC_MSG */
REGISTER_CC(CC_IDLE); /* register cost centre CC_MSG */
#endif
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
REGISTER_CC(CC_OVERHEAD); /* register cost centre CC_OVERHEAD */
REGISTER_CC(CC_DONTZuCARE); /* register cost centre CC_DONT_CARE Right??? ToDo */
#endif
CCC = (CostCentre)STATIC_CC_REF(CC_MAIN);
CCC->scc_count++;
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
/* always register -- if we do not, we get warnings (WDP 94/12) */
-/* if (cc_profiling || heap_profiling_req != HEAP_NO_PROFILING) */
+/* if (RTSflags.CcFlags.doCostCentres || RTSflags.ProfFlags.doHeapProfile) */
register_stack = (StgFunPtr *) heap_space;
miniInterpret((StgFunPtr) startCcRegisteringWorld);
%************************************************************************
%* *
-\subsection[cost-centre-profiling]{Cost Centre Profiling Report}
+\subsection{Cost Centre Profiling Report}
%* *
%************************************************************************
\begin{code}
-
static I_ dump_interval = 0;
+rtsBool
+cc_to_ignore (CostCentre cc)
+ /* return rtsTrue if it is one of the ones that
+ should not be reported normally (because it confuses
+ the users)
+ */
+{
+# if !defined(PROFILING)
+ /* in parallel land, everything is interesting (not ignorable) */
+ return rtsFalse;
+
+# else
+ if ( cc == CC_OVERHEAD || cc == CC_DONTZuCARE || cc == CC_GC ) {
+ return rtsTrue;
+ } else {
+ return rtsFalse;
+ }
+# endif /* PROFILING */
+}
+
void
report_cc_profiling(final)
-I_ final;
+ I_ final;
{
FILE *prof_file;
CostCentre cc;
I_ count;
- char temp[32];
- W_ total_ticks = 0, total_alloc = 0, total_allocs = 0;
+ char temp[128]; /* sigh: magic constant */
+ W_ total_ticks = 0, total_alloc = 0, total_allocs = 0;
+ W_ ignored_ticks = 0, ignored_alloc = 0, ignored_allocs = 0;
+#ifdef PAR
+ I_ final_ticks = 0; /*No. ticks in last sample*/
+#endif
- if (!cc_profiling)
+ if (!RTSflags.CcFlags.doCostCentres)
return;
blockVtAlrmSignal();
StgFloat seconds = (previous_ticks + current_ticks) / (StgFloat) TICK_FREQUENCY;
if (final) {
- /* ignore partial sample at end of execution */
+ fprintf(serial_file, "BEGIN_SAMPLE %0.2f\n", seconds);
+#ifdef PAR
+ /*In the parallel world we're particularly interested in the last sample*/
+ for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered) {
+ if (! cc_to_ignore(cc))
+ final_ticks += cc->time_ticks;
+ }
- /* output final 0 sample */
- fprintf(serial_file, "BEGIN_SAMPLE %0.2f\n", seconds);
+ for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered) {
+ if (cc->time_ticks != 0 && ! cc_to_ignore(cc))
+ fprintf(serial_file, " %0.11s:%0.16s %3ld\n",
+ cc->module, cc->label, cc->time_ticks*100 / final_ticks);
+ }
+#endif
+ /* In the sequential world, ignore partial sample at end of execution */
fprintf(serial_file, "END_SAMPLE %0.2f\n", seconds);
fclose(serial_file);
serial_file = NULL;
} else {
- /* output serail profile sample */
+ /* output serial profile sample */
fprintf(serial_file, "BEGIN_SAMPLE %0.2f\n", seconds);
for (cc = Registered_CC; cc != REGISTERED_END; cc = cc->registered) {
ASSERT_IS_REGISTERED(cc, 0);
- if (cc->time_ticks) {
+ if (cc->time_ticks != 0 && !cc_to_ignore(cc)) {
+#ifdef PAR
+ /* Print _percentages_ in the parallel world */
+ fprintf(serial_file, " %0.11s:%0.16s %3ld\n",
+ cc->module, cc->label, cc->time_ticks * 100/TICK_FREQUENCY);
+#else
fprintf(serial_file, " %0.11s:%0.16s %3ld\n",
cc->module, cc->label, cc->time_ticks);
+#endif
}
}
cc->prev_ticks += cc->time_ticks;
cc->time_ticks = 0;
- total_ticks += cc->prev_ticks;
- total_alloc += cc->mem_alloc;
- total_allocs += cc->mem_allocs;
+ if ( cc_to_ignore(cc) ) { /* reporting these just confuses users... */
+ ignored_ticks += cc->prev_ticks;
+ ignored_alloc += cc->mem_alloc;
+ ignored_allocs += cc->mem_allocs;
+ } else {
+ total_ticks += cc->prev_ticks;
+ total_alloc += cc->mem_alloc;
+ total_allocs += cc->mem_allocs;
+ }
}
- if (total_ticks != current_ticks + previous_ticks)
- fprintf(stderr, "Warning: Cost Centre tick inconsistency: total=%ld, current=%ld, previous=%ld\n", total_ticks, current_ticks, previous_ticks);
+ if (total_ticks + ignored_ticks != current_ticks + previous_ticks)
+ fprintf(stderr, "Warning: Cost Centre tick inconsistency: total=%ld, ignored=%ld, current=%ld, previous=%ld\n", total_ticks, ignored_ticks, current_ticks, previous_ticks);
unblockVtAlrmSignal();
dump_interval = 0;
/* sort cost centres */
- cc_sort(&Registered_CC, cc_profiling_sort);
+ cc_sort(&Registered_CC, RTSflags.CcFlags.sortBy);
/* open profiling output file */
if ((prof_file = fopen(prof_filename, "w")) == NULL) {
*/
fprintf(prof_file, " %5s %5s %6s %6s", "scc", "subcc", "%time", "%alloc");
- if (cc_profiling > 1)
+ if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE)
fprintf(prof_file, " %11s %13s %8s %8s %8s (%5s %8s)", "cafcc", "thunks", "funcs", "PAPs", "closures", "ticks", "bytes");
fprintf(prof_file, "\n\n");
/* Only print cost centres with non 0 data ! */
- if (cc->scc_count || cc->sub_scc_count || cc->prev_ticks || cc->mem_alloc
- || (cc_profiling > 1
- && (cc->thunk_count || cc->function_count || cc->pap_count
- || cc->cafcc_count || cc->sub_cafcc_count))
- || (cc_profiling > 2
- /* print all cost centres if -P -P */ )
- ) {
+ if ( (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_ALL
+ /* force printing of *all* cost centres if -P -P */ )
+
+ || ( ! cc_to_ignore(cc)
+ && (cc->scc_count || cc->sub_scc_count || cc->prev_ticks || cc->mem_alloc
+ || (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE
+ && (cc->thunk_count || cc->function_count || cc->pap_count
+ || cc->cafcc_count || cc->sub_cafcc_count))))
+ ) {
fprintf(prof_file, "%-16.16s %-11.11s", cc->label, cc->module);
/* ToDo:group
total_ticks == 0 ? 0.0 : (cc->prev_ticks / (StgFloat) total_ticks * 100),
total_alloc == 0 ? 0.0 : (cc->mem_alloc / (StgFloat) total_alloc * 100));
- if (cc_profiling > 1)
+ if (RTSflags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE)
fprintf(prof_file, " %8ld %-8ld %8ld %8ld %8ld %8ld (%5ld %8ld)",
cc->cafcc_count, cc->sub_cafcc_count,
cc->thunk_count, cc->function_count, cc->pap_count,
%************************************************************************
%* *
-\subsection[profiling-misc]{Miscellanious Profiling Routines}
+\subsection{Miscellaneous profiling routines}
%* *
%************************************************************************
\begin{code}
static I_
-cc_lt_label(cc1, cc2)
- CostCentre cc1, cc2;
+cc_lt_label(CostCentre cc1, CostCentre cc2)
{
I_ cmp;
}
static I_
-cc_gt_time(cc1, cc2)
- CostCentre cc1, cc2;
+cc_gt_time(CostCentre cc1, CostCentre cc2)
{
/* ToDo: normal then caf then dict (instead of scc at top) */
}
static I_
-cc_gt_alloc(cc1, cc2)
- CostCentre cc1, cc2;
+cc_gt_alloc(CostCentre cc1, CostCentre cc2)
{
/* ToDo: normal then caf then dict (instead of scc at top) */
return (cc_lt_label(cc1, cc2)); /* all data equal: cmp labels */
}
-#ifdef __STDC__
void
cc_sort(CostCentre *sort, char sort_on)
-#else
-void
-cc_sort(sort, sort_on)
- CostCentre *sort;
- char sort_on;
-#endif
{
I_ (*cc_lt)();
CostCentre sorted, insert, *search, insert_rest;
\end{code}
\begin{code}
-#endif /* USE_COST_CENTRES || GUM */
+#endif /* PROFILING || PAR */
\end{code}
-Only have cost centres etc if @USE_COST_CENTRES@ defined
+Only have cost centres etc if @PROFILING@ defined
\begin{code}
/*
*/
#define NULL_REG_MAP
-#include "../storage/SMinternal.h" /* for xmalloc */
+#include "../storage/SMinternal.h" /* for ???? */
-#if defined (USE_COST_CENTRES)
+#if defined (PROFILING)
\end{code}
%************************************************************************
idealised process which should not affect the statistics gathered.
\begin{code}
-
#define MAX_SELECT 10
-I_ heap_profiling_req
- = HEAP_NO_PROFILING; /* type of heap profiling */
-
-static char heap_profiling_char[] /* indexed by heap_profiling_req */
+static char heap_profiling_char[] /* indexed by RTSflags.ProfFlags.doHeapProfile */
= {'?', CCchar, MODchar, GRPchar, DESCRchar, TYPEchar, TIMEchar};
static I_ cc_select = 0; /* are we selecting on Cost Centre */
static I_ kind_selected[] = {0, 0, 0, 0, 0, 0};
static char *kind_select_strs[] = {"","CON","FN","PAP","THK","BH",0};
-static I_ age_select = 0; /* select ages greater than this */
- /* 0 indicates survived to the end of alloced interval */
-
-I_ *resid = 0; /* residencies indexed by hashed feature */
+I_ *resid = 0; /* residencies indexed by hashed feature */
/* For production times we have a resid table of time_intervals */
/* And a seperate resid counter stuff produced earlier & later */
static hash_t earlier_intervals; /* No of earlier intervals grouped together + 1*/
-hash_t dummy_index_time()
+hash_t
+dummy_index_time(STG_NO_ARGS)
{
return time_intervals;
}
static char heap_filename[STATS_FILENAME_MAXLEN]; /* heap log file name = <program>.hp */
static FILE *heap_file = NULL;
-extern I_ SM_force_gc; /* Set here if we force 2-space GC */
-
I_
-heap_profile_init(prof, cc_select_str, mod_select_str, grp_select_str,
+heap_profile_init(cc_select_str, mod_select_str, grp_select_str,
descr_select_str, type_select_str, kind_select_str,
- select_age, argv)
- I_ prof;
+ argv)
char *cc_select_str;
char *mod_select_str;
char *grp_select_str;
char *descr_select_str;
char *type_select_str;
char *kind_select_str;
- I_ select_age;
char *argv[];
{
hash_t count, max, first;
+ W_ heap_prof_style;
- heap_profiling_req = prof;
-
- if (heap_profiling_req == HEAP_NO_PROFILING)
+ if (! RTSflags.ProfFlags.doHeapProfile)
return 0;
/* for now, if using a generational collector and trying
WDP 94/07
*/
#if defined(GCap) || defined(GCgn)
- SM_force_gc = USE_2s;
+ RTSflags.GcFlags.force2s = rtsTrue;
#endif
-#if ! defined(HEAP_PROF_WITH_AGE)
- if (heap_profiling_req == HEAP_BY_TIME || select_age) {
- fprintf(stderr, "heap_profile_init: Heap Profiling not built with AGE field in closures\n");
- return 1;
- }
-#endif /* ! HEAP_PROF_WITH_AGE */
+ heap_prof_style = RTSflags.ProfFlags.doHeapProfile;
/* process select strings -- will break them into bits */
}
clcat_select |= kind_select_no > 0;
}
- age_select = select_age;
-
/* open heap profiling log file */
/* write start of log file */
fprintf(heap_file, "JOB \"%s", argv[0]);
- fprintf(heap_file, " +RTS -h%c", heap_profiling_char[heap_profiling_req]);
- if (heap_profiling_req == HEAP_BY_TIME) {
+ fprintf(heap_file, " +RTS -h%c", heap_profiling_char[heap_prof_style]);
+ if (heap_prof_style == HEAP_BY_TIME) {
fprintf(heap_file, "%ld", time_intervals);
if (earlier_ticks) {
fprintf(heap_file, ",%3.1f",
}
fprintf(heap_file, "}");
}
- if (select_age) {
- fprintf(heap_file, " -a%ld", age_select);
- }
+
fprintf(heap_file, " -i%4.2f -RTS", interval_ticks/(StgFloat)TICK_FREQUENCY);
for(count = 1; argv[count]; count++)
fprintf(heap_file, " %s", argv[count]);
/* initialise required heap profiling data structures & hashing */
earlier_intervals = (earlier_ticks / interval_ticks) + 1;
- max = (* init_index_fns[heap_profiling_req])();
- resid = (I_ *) xmalloc(max * sizeof(I_));
- for (count = 0; count < max; count++) resid[count] = 0;
+ max = (* init_index_fns[heap_prof_style])();
+ resid = (I_ *) stgMallocBytes(max * sizeof(I_), "heap_profile_init");
+
+ for (count = 0; count < max; count++)
+ resid[count] = 0;
return 0;
}
\begin{code}
void
-set_selected_ccs() /* set selection before we profile heap */
+set_selected_ccs(STG_NO_ARGS) /* set selection before we profile heap */
{
I_ x;
CostCentre cc;
I_
-selected_clcat(clcat)
- ClCategory clcat;
+selected_clcat(ClCategory clcat)
{
I_ x;
words).
\begin{code}
-#define NON_PROF_HS (FIXED_HS - PROF_FIXED_HDR - AGE_FIXED_HDR)
+#define NON_PROF_HS (FIXED_HS - PROF_FIXED_HDR - TICKY_FIXED_HDR)
void
-profile_closure_none(closure,size)
- P_ closure;
- I_ size;
+profile_closure_none(P_ closure, I_ size)
{
return;
}
void
-profile_closure_cc(closure,size)
- P_ closure;
- I_ size;
+profile_closure_cc(P_ closure, I_ size)
{
CostCentre cc = (CostCentre) CC_HDR(closure);
resid[index_cc(cc)] += size + NON_PROF_HS;
}
void
-profile_closure_cc_select(closure,size)
- P_ closure;
- I_ size;
+profile_closure_cc_select(P_ closure, I_ size)
{
CostCentre cc; ClCategory clcat;
return; /* all selected if ! cc_select */
clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
- if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
+ if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
return;
-#if defined(HEAP_PROF_WITH_AGE)
- if (age_select) {
- I_ age, ts = AGE_HDR(closure);
-
- if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
- AGE_HDR(closure) = (W_)current_interval;
- age = - age_select;
- }
- else {
- age = current_interval - ts - age_select;
- }
- if (age < 0) return;
- }
-#endif /* HEAP_PROF_WITH_AGE */
-
resid[index_cc(cc)] += size + NON_PROF_HS;
return;
}
void
-profile_closure_mod(closure,size)
- P_ closure;
- I_ size;
+profile_closure_mod(P_ closure, I_ size)
{
CostCentre cc = (CostCentre) CC_HDR(closure);
resid[index_mod(cc)] += size + NON_PROF_HS;
}
void
-profile_closure_mod_select(closure,size)
- P_ closure;
- I_ size;
+profile_closure_mod_select(P_ closure, I_ size)
{
CostCentre cc; ClCategory clcat;
return;
clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
- if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
+ if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
return;
-#if defined(HEAP_PROF_WITH_AGE)
- if (age_select) {
- I_ age, ts = AGE_HDR(closure);
-
- if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
- AGE_HDR(closure) = (W_)current_interval;
- age = - age_select;
- }
- else {
- age = current_interval - ts - age_select;
- }
- if (age < 0) return;
- }
-#endif /* HEAP_PROF_WITH_AGE */
-
resid[index_mod(cc)] += size + NON_PROF_HS;
return;
}
void
-profile_closure_grp(closure,size)
- P_ closure;
- I_ size;
+profile_closure_grp(P_ closure, I_ size)
{
CostCentre cc = (CostCentre) CC_HDR(closure);
resid[index_grp(cc)] += size + NON_PROF_HS;
return;
}
+
void
-profile_closure_grp_select(closure,size)
- P_ closure;
- I_ size;
+profile_closure_grp_select(P_ closure, I_ size)
{
CostCentre cc; ClCategory clcat;
return;
clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
- if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
+ if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
return;
-#if defined(HEAP_PROF_WITH_AGE)
- if (age_select) {
- I_ age, ts = AGE_HDR(closure);
-
- if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
- AGE_HDR(closure) = (W_)current_interval;
- age = - age_select;
- }
- else {
- age = current_interval - ts - age_select;
- }
- if (age < 0) return;
- }
-#endif /* HEAP_PROF_WITH_AGE */
-
resid[index_grp(cc)] += size + NON_PROF_HS;
return;
}
void
-profile_closure_descr(closure,size)
- P_ closure;
- I_ size;
+profile_closure_descr(P_ closure, I_ size)
{
ClCategory clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
resid[index_descr(clcat)] += size + NON_PROF_HS;
}
void
-profile_closure_descr_select(closure,size)
- P_ closure;
- I_ size;
+profile_closure_descr_select(P_ closure, I_ size)
{
CostCentre cc; ClCategory clcat;
return; /* all selected if ! cc_select */
clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
- if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
+ if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
return;
-#if defined(HEAP_PROF_WITH_AGE)
- if (age_select) {
- I_ age, ts = AGE_HDR(closure);
-
- if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
- AGE_HDR(closure) = (W_)current_interval;
- age = - age_select;
- }
- else {
- age = current_interval - ts - age_select;
- }
- if (age < 0) return;
- }
-#endif /* HEAP_PROF_WITH_AGE */
-
resid[index_descr(clcat)] += size + NON_PROF_HS;
return;
}
void
-profile_closure_type(closure,size)
- P_ closure;
- I_ size;
+profile_closure_type(P_ closure, I_ size)
{
ClCategory clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
resid[index_type(clcat)] += size + NON_PROF_HS;
}
void
-profile_closure_type_select(closure,size)
- P_ closure;
- I_ size;
+profile_closure_type_select(P_ closure, I_ size)
{
CostCentre cc; ClCategory clcat;
if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
return;
-#if defined(HEAP_PROF_WITH_AGE)
- if (age_select) {
- I_ age, ts = AGE_HDR(closure);
-
- if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
- AGE_HDR(closure) = (W_)current_interval;
- age = - age_select;
- }
- else {
- age = current_interval - ts - age_select;
- }
- if (age < 0) return;
- }
-#endif /* HEAP_PROF_WITH_AGE */
-
resid[index_type(clcat)] += size + NON_PROF_HS;
return;
}
void
-profile_closure_time(closure,size)
- P_ closure;
- I_ size;
+profile_closure_time(P_ closure, I_ size)
{
-#if defined(HEAP_PROF_WITH_AGE)
- I_ ts = AGE_HDR(closure);
-
- if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
- AGE_HDR(closure) = (W_)current_interval;
- ts = current_interval;
- }
-
- ts -= earlier_intervals;
-
- if (ts < 0) {
- resid_earlier += size + NON_PROF_HS;
- }
- else if (ts < time_intervals) {
- resid[ts] += size + NON_PROF_HS;
- }
- else {
- resid_later += size + NON_PROF_HS;
- }
-#endif /* HEAP_PROF_WITH_AGE */
-
return;
}
void
-profile_closure_time_select(closure,size)
- P_ closure;
- I_ size;
+profile_closure_time_select(P_ closure, I_ size)
{
-#if defined(HEAP_PROF_WITH_AGE)
- CostCentre cc; ClCategory clcat; I_ age, ts;
-
- cc = (CostCentre) CC_HDR(closure);
- if (! cc->selected) /* selection determined before profile */
- return; /* all selected if ! cc_select */
-
- clcat = (ClCategory) INFO_CAT(INFO_PTR(closure));
- if (clcat_select && ! selected_clcat(clcat)) /* selection memoised during profile */
- return;
-
- ts = AGE_HDR(closure);
- if (ts == 0) { /* Set to 0 when alloced -- now set to current interval */
- AGE_HDR(closure) = (W_)current_interval;
- ts = current_interval;
- age = - age_select;
- }
- else {
- age = current_interval - ts - age_select;
- }
- if (age < 0)
- return;
-
- ts -= earlier_intervals;
-
- if (ts < 0) {
- resid_earlier += size + NON_PROF_HS;
- }
- else if (ts < time_intervals) {
- resid[ts] += size + NON_PROF_HS;
- }
- else {
- resid_later += size + NON_PROF_HS;
- }
-#endif /* HEAP_PROF_WITH_AGE */
-
return;
}
\end{code}
void
heap_profile_setup(STG_NO_ARGS) /* called at start of heap profile */
{
- if (heap_profiling_req == HEAP_NO_PROFILING)
+ W_ heap_prof_style;
+
+ if (! RTSflags.ProfFlags.doHeapProfile)
return;
- if (cc_select || clcat_select || age_select) {
+ heap_prof_style = RTSflags.ProfFlags.doHeapProfile;
+
+ if (cc_select || clcat_select) {
set_selected_ccs(); /* memoise cc selection */
- heap_profile_fn = profiling_fns_select[heap_profiling_req];
+ heap_profile_fn = profiling_fns_select[heap_prof_style];
} else {
- heap_profile_fn = profiling_fns[heap_profiling_req];
+ heap_profile_fn = profiling_fns[heap_prof_style];
}
}
void
heap_profile_done(STG_NO_ARGS) /* called at end of heap profile */
{
- CostCentre cc; ClCategory clcat; hash_t ind, max;
+ CostCentre cc;
+ ClCategory clcat;
+ hash_t ind, max;
StgFloat seconds;
+ W_ heap_prof_style;
- if (heap_profiling_req == HEAP_NO_PROFILING)
+ if (! RTSflags.ProfFlags.doHeapProfile)
return;
+ heap_prof_style = RTSflags.ProfFlags.doHeapProfile;
heap_profile_fn = profile_closure_none;
seconds = (previous_ticks + current_ticks) / (StgFloat)TICK_FREQUENCY;
fprintf(heap_file, "BEGIN_SAMPLE %0.2f\n", seconds);
- max = (* init_index_fns[heap_profiling_req])();
+ max = (* init_index_fns[heap_prof_style])();
- switch (heap_profiling_req) {
+ switch (heap_prof_style) {
case HEAP_BY_CC:
for (ind = 0; ind < max; ind++) {
- if ((cc = index_cc_table[ind]) != 0) {
+ if ((cc = index_cc_table[ind]) != 0 && ! cc_to_ignore(cc)) {
fprintf(heap_file, " %0.11s:%0.16s %ld\n", cc->module, cc->label, resid[ind] * sizeof(W_));
}
resid[ind] = 0;
case HEAP_BY_MOD:
for (ind = 0; ind < max; ind++) {
- if ((cc = index_mod_table[ind]) != 0) {
+ if ((cc = index_mod_table[ind]) != 0 && ! cc_to_ignore(cc)) {
fprintf(heap_file, " %0.11s %ld\n", cc->module, resid[ind] * sizeof(W_));
}
resid[ind] = 0;
case HEAP_BY_GRP:
for (ind = 0; ind < max; ind++) {
- if ((cc = index_grp_table[ind]) != 0) {
+ if ((cc = index_grp_table[ind]) != 0 && ! cc_to_ignore(cc)) {
fprintf(heap_file, " %0.11s %ld\n", cc->group, resid[ind] * sizeof(W_));
}
resid[ind] = 0;
case HEAP_BY_DESCR:
for (ind = 0; ind < max; ind++) {
- if ((clcat = index_descr_table[ind]) != 0) {
+ if ((clcat = index_descr_table[ind]) != 0 && ! cc_to_ignore(cc)) {
fprintf(heap_file, " %0.28s %ld\n", clcat->descr, resid[ind] * sizeof(W_));
}
resid[ind] = 0;
case HEAP_BY_TYPE:
for (ind = 0; ind < max; ind++) {
- if ((clcat = index_type_table[ind]) != 0) {
+ if ((clcat = index_type_table[ind]) != 0 && ! cc_to_ignore(cc)) {
fprintf(heap_file, " %0.28s %ld\n", clcat->type, resid[ind] * sizeof(W_));
}
resid[ind] = 0;
}
break;
-
-#if defined(HEAP_PROF_WITH_AGE)
- case HEAP_BY_TIME:
- { I_ resid_tot = 0;
- if (resid_earlier) {
- resid_tot += resid_earlier;
- fprintf(heap_file, " before_%4.2fs %ld\n",
- (earlier_intervals-1)*interval_ticks/(StgFloat)TICK_FREQUENCY,
- resid_earlier * sizeof(StgWord));
- resid_earlier = 0;
- }
- for (ind = 0; ind < max; ind++) {
- if (resid[ind]) {
- resid_tot += resid[ind];
- fprintf(heap_file, " before_%4.2fs %ld\n",
- (ind+earlier_intervals)*interval_ticks/(StgFloat)TICK_FREQUENCY,
- resid[ind] * sizeof(StgWord));
- resid[ind] = 0;
- }
- }
- if (resid_later) {
- resid_tot += resid_later;
- fprintf(heap_file, " later %ld\n", resid_later * sizeof(StgWord));
- resid_later = 0;
- }
-
- if (resid_max < resid_tot) resid_max = resid_tot;
- break;
- }
-#endif /* HEAP_PROF_WITH_AGE */
}
fprintf(heap_file, "END_SAMPLE %0.2f\n", seconds);
{
StgFloat seconds;
- if (heap_profiling_req == HEAP_NO_PROFILING)
+ if (! RTSflags.ProfFlags.doHeapProfile)
return;
seconds = (previous_ticks + current_ticks) / (StgFloat)TICK_FREQUENCY;
\end{code}
\begin{code}
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING */
\end{code}
-Only have cost centres etc if @USE_COST_CENTRES@ defined
+Only have cost centres etc if @PROFILING@ defined
\begin{code}
#define NULL_REG_MAP /* Not threaded */
-#include "../storage/SMinternal.h" /* for xmalloc */
-#if defined (USE_COST_CENTRES)
+#include "../storage/SMinternal.h" /* for ??? */
+#if defined (PROFILING)
\end{code}
%************************************************************************
max_cc_no = max2;
mask_cc = max2 - 1;
- index_cc_table = (CostCentre *) xmalloc(max2 * sizeof(CostCentre));
- for (count = 0; count < max2; count++) index_cc_table[count] = 0;
+ index_cc_table = (CostCentre *) stgMallocBytes(max2 * sizeof(CostCentre), "init_index_cc");
+
+ for (count = 0; count < max2; count++)
+ index_cc_table[count] = 0;
return max2;
}
max_mod_no = max2;
mask_mod = max2 - 1;
- index_mod_table = (CostCentre *) xmalloc(max2 * sizeof(CostCentre));
- for (count = 0; count < max2; count++) index_mod_table[count] = 0;
+ index_mod_table = (CostCentre *) stgMallocBytes(max2 * sizeof(CostCentre), "init_index_mod");
+
+ for (count = 0; count < max2; count++)
+ index_mod_table[count] = 0;
return max2;
}
-hash_t index_mod(cc)
+hash_t
+index_mod(cc)
CostCentre cc;
{
if (cc->index_val == UNHASHED) {
max_grp_no = max2;
mask_grp = max2 - 1;
- index_grp_table = (CostCentre *) xmalloc(max2 * sizeof(CostCentre));
- for (count = 0; count < max2; count++) index_grp_table[count] = 0;
+ index_grp_table = (CostCentre *) stgMallocBytes(max2 * sizeof(CostCentre), "init_index_grp");
+
+ for (count = 0; count < max2; count++)
+ index_grp_table[count] = 0;
return max2;
}
-hash_t index_grp(cc)
+hash_t
+index_grp(cc)
CostCentre cc;
{
if (cc->index_val == UNHASHED) {
max_descr_no = max2;
mask_descr = max2 - 1;
- index_descr_table = (ClCategory *) xmalloc(max2 * sizeof(ClCategory));
- for (count = 0; count < max2; count++) index_descr_table[count] = 0;
+ index_descr_table = (ClCategory *) stgMallocBytes(max2 * sizeof(ClCategory), "init_index_descr");
+
+ for (count = 0; count < max2; count++)
+ index_descr_table[count] = 0;
return max2;
}
-hash_t index_descr(clcat)
+hash_t
+index_descr(clcat)
ClCategory clcat;
{
if (clcat->index_val == UNHASHED) {
max_type_no = max2;
mask_type = max2 - 1;
- index_type_table = (ClCategory *) xmalloc(max2 * sizeof(ClCategory));
- for (count = 0; count < max2; count++) index_type_table[count] = 0;
+ index_type_table = (ClCategory *) stgMallocBytes(max2 * sizeof(ClCategory), "init_index_type");
+
+ for (count = 0; count < max2; count++)
+ index_type_table[count] = 0;
return max2;
}
\end{code}
\begin{code}
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING */
\end{code}
+++ /dev/null
-\section[LifeProfile.lc]{Code for Lifetime Profiling}
-
-\tr{life_profile} is the accumulated age at death profile. It is
-calculated from the difference of the prev and cur age profiles.
-
-\tr{update_profile} is the accumulated age at update profile.
-
-\begin{code}
-#include "rtsdefs.h"
-\end{code}
-
-Only have lifetime profiling if @LIFE_PROFILE@ defined
-
-\begin{code}
-#if defined(LIFE_PROFILE)
-\end{code}
-
-Note: Heap Lookahead may cause age increment when no alloc occurs !
-
-Could avoid it and assume space is available. If a closure was then
-allocated it may be given a younger age. Subsequent Heap Check would
-increment age.
-
-\begin{code}
-I_ do_life_prof = 0; /* Global Flag */
-I_ CurrentTime = 0; /* Current time (in LifeIntervals) */
-I_ LifeInterval = DEFAULT_LIFE_INTERVAL; /* words alloced */
-
-W_ closures_updated = 0;
-W_ closures_alloced = 0;
-
-static W_ words_allocated = 0;
-
-static StgChar* prog;
-static I_ over_alloc = 0;
-static I_ progress = 999;
-\end{code}
-
-
-\tr{cur_age_profile} is a histogram of live words of each age.
-
-\tr{prev_age_profile} is a histogram of the live words at the last
-profile expressed in the ages they wold be at the current profile.
-When the current is copied into the previous it must be shifted along.
-\tr{prev_age_profile[0]} is always 0!
-
-\begin{code}
-static I_ intervals; /* No of active intervals -- report to 10Mb */
-
-static W_ cur_age_profile[INTERVALS];
-static W_ cur_older = 0;
-static W_ prev_age_profile[INTERVALS];
-static W_ prev_older = 0;
-
-static W_ life_profile[INTERVALS];
-static W_ life_older = 0;
-static W_ update_profile[INTERVALS];
-static W_ update_older = 0;
-\end{code}
-
-\begin{code}
-I_
-life_profile_init(rts_argv, prog_argv)
- StgChar *rts_argv[];
- StgChar *prog_argv[];
-{
- I_ i;
-
- if (! do_life_prof)
- return 0;
-
- prog = prog_argv[0];
-
- /* report up to 10Mb (2.5 Mwords) */
- intervals = 2500000 / LifeInterval;
- if (intervals > INTERVALS)
- intervals = INTERVALS;
-
- for (i = 0; i < intervals; i++) {
- cur_age_profile[i] = 0;
- prev_age_profile[i] = 0;
- life_profile[i] = 0;
- update_profile[i] = 0;
- }
-
- return 0;
-}
-
-void life_profile_setup(STG_NO_ARGS)
-{
- return;
-}
-
-I_
-life_profile_done(alloc, reqsize)
- I_ alloc;
- I_ reqsize;
-{
- I_ i, actual_alloc, slop, shift_prev_age;
-
- life_profile[0] += cur_age_profile[0]; /* age 0 still alive */
-
- for (i = 1; i < intervals; i++) {
- life_profile[i] += prev_age_profile[i] - cur_age_profile[i];
- prev_age_profile[i] = cur_age_profile[i-1];
- cur_age_profile[i-1] = 0;
- }
- life_older += prev_older - cur_older;
- prev_older = cur_age_profile[intervals-1] + cur_older;
- cur_age_profile[intervals-1] = 0;
- cur_older = 0;
-
- CurrentTime++;
-
- words_allocated += alloc;
-
- actual_alloc = words_allocated - closures_alloced;
- slop = CurrentTime * LifeInterval - actual_alloc;
-
- shift_prev_age = 0;
- while (slop < 0) {
- /* over allocated due to large reqsize */
- CurrentTime++;
- slop += LifeInterval;
- over_alloc++;
- shift_prev_age++;
- }
- if (shift_prev_age) {
- /* shift prev age profile as we have skipped profiles */
- for (i = intervals - 1; i >= intervals - shift_prev_age; i--) {
- prev_older += prev_age_profile[i];
- }
- for (i = intervals - 1; i >= shift_prev_age; i--) {
- prev_age_profile[i] = prev_age_profile[i-shift_prev_age];
- }
- for (i = shift_prev_age - 1; i >= 0; i--) {
- prev_age_profile[i] = 0;
- }
- }
-
- if (++progress == 1000 || do_life_prof > 1) {
- fprintf(stderr, "%s: intervals %ld interval %ld alloc %ld slop %ld req %ld (over %ld)\n",
- prog, CurrentTime, LifeInterval, actual_alloc, slop, reqsize, over_alloc);
- progress = 0;
- }
-
- if (slop + LifeInterval < reqsize) {
- return(reqsize);
- } else {
- return(slop + LifeInterval);
- }
-}
-
-void
-life_profile_finish(alloc, prog_argv)
- I_ alloc;
- StgChar *prog_argv[];
-{
- I_ report, i;
- StgChar life_filename[STATS_FILENAME_MAXLEN];
- FILE *life_file;
- W_ total_life, total_upd, total_interval,
- accum_life, accum_upd;
-
- if (! do_life_prof)
- return;
-
- total_interval = words_allocated + alloc - closures_alloced;
-
- /* convert age 0 still alive to age 0 died */
- life_profile[0] = closures_alloced - life_profile[0];
-
- /* All the prev stuff just died ! */
- for (i = 1; i < intervals; i++) {
- life_profile[i] += prev_age_profile[i];
- }
- life_older += prev_older;
-
- /* Produce liftime reports */
- sprintf(life_filename, LIFE_FILENAME_FMT, prog_argv[0]);
- if ( (life_file = fopen(life_filename,"w")) == NULL ) {
- fprintf(stderr, "Can't open life profile report file %s\n", life_filename);
- }
- else {
- for(i = 0, total_life = total_upd = 0; i < intervals; i++) {
- total_life += life_profile[i];
- total_upd += update_profile[i];
- }
- total_life += life_older;
- total_upd += update_older;
-
- if (total_life != closures_alloced) {
- fprintf(stderr, "Warning: Life Profile: %1lu closures in profile, %1lu allocated\n",
- total_life, closures_alloced);
- }
- if (total_upd != closures_updated) {
- fprintf(stderr, "Warning: Update Age Profile: %1lu closures in profile, %1lu updated\n",
- total_upd, closures_updated);
- }
-
- fprintf(life_file, "\tClosure Lifetime Profile (%s)\n", time_str());
- fprintf(life_file, "\n\t ");
- for(i = 0; prog_argv[i]; i++)
- fprintf(life_file, " %s", prog_argv[i]);
- fprintf(life_file, "\n\n\ttotal closures alloced: %lu\n",
- closures_alloced);
- fprintf(life_file, "\ttotal closures updated: %lu\n",
- closures_updated);
- fprintf(life_file, "\ttotal bytes alloced: %lu\n",
- total_interval*sizeof(W_));
- fprintf(life_file, "\n age (allocation) liftime age when updated\n");
- fprintf(life_file, " bytes %%total %%closures No %%updates No\n");
-
- accum_life = 0;
- accum_upd = 0;
-
- report = 0;
- while (report < intervals) {
- I_ life = 0;
- I_ upd = 0;
-
- i = report;
- report += GROUPED;
-
- while(i < report) {
- life += life_profile[i];
- upd += update_profile[i];
- i++;
- }
-
- accum_life += life;
- accum_upd += upd;
-
- fprintf(life_file, " %8ld %7.3f %6.2f%9lu %6.2f%9lu\n",
- (report)*LifeInterval*sizeof(W_),
- (report)*LifeInterval/(StgFloat)total_interval*100,
- accum_life/(StgFloat)closures_alloced*100,
- life,
- accum_upd/(StgFloat)closures_updated*100,
- upd);
- }
-
- fprintf(life_file, " older %6.2f%9lu %6.2f%9lu\n\n",
- life_older/(StgFloat)closures_alloced*100,
- life_older,
- update_older/(StgFloat)closures_updated*100,
- update_older);
-
- fprintf(life_file, "Raw Data: lifetime update\n");
- for(i = 0; i < intervals; i++) {
- fprintf(life_file, " %8ld %9lu %9lu\n",
- (i+1)*LifeInterval*sizeof(W_), life_profile[i], update_profile[i]);
- }
-
- fclose(life_file);
- }
- return;
-}
-
-
-void
-life_profile_closure(closure, size)
- P_ closure;
- I_ size;
-{
- I_ age;
-
- age = CurrentTime - AGE_HDR(closure);
- if (age < intervals)
- cur_age_profile[age] += 1;
- else
- cur_older += 1;
- return;
-}
-
-extern void update_profile_closure(closure)
- P_ closure;
-{
- I_ age;
-
- if (! do_life_prof)
- return;
-
- age = CurrentTime - AGE_HDR(closure);
- if (age < intervals)
- update_profile[age] += 1;
- else
- update_older += 1;
- closures_updated++;
- return;
-}
-
-\end{code}
-
-
-\begin{code}
-#endif /* LIFE_PROFILE */
-\end{code}
-
-Only have cost centres etc if @USE_COST_CENTRES@ defined
+Only have cost centres etc if @PROFILING@ defined
\begin{code}
#include "rtsdefs.h"
-#if defined (USE_COST_CENTRES) || defined(GUM)
+#if defined (PROFILING) || defined(PAR)
\end{code}
%************************************************************************
I_ previous_ticks = 0; /* ticks in previous intervals */
I_ current_ticks = 0; /* ticks in current interval */
-#ifdef CONCURRENT
-I_ tick_millisecs; /* milliseconds per timer tick */
-#endif
-
void
-set_profile_timer(ms)
-I_ ms;
+set_profile_timer(I_ ms)
{
if (initialize_virtual_timer(ms)) {
fflush(stdout);
CC_TICK(CCC);
/* fprintf(stderr,"tick for %s\n", CCC->label); */
-#if defined(USE_COST_CENTRES) && defined(DEBUG)
+#if defined(PROFILING) && defined(DEBUG)
/* Why is this here? --JSM Debugging --WDP */
if (CCC == STATIC_CC_REF(CC_OVERHEAD))
abort();
#endif
if (++current_ticks >= interval_ticks && CCC != STATIC_CC_REF(CC_GC)) {
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
interval_expired = 1; /* stop to process interval */
#else
report_cc_profiling(0 /*partial*/);
handle_tick_noserial(STG_NO_ARGS)
{
CC_TICK(CCC);
+ ++current_ticks;
return;
}
void
restart_time_profiler()
{ /* Restarts time profile */
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
if (interval_expired)
#endif
{
start_time_profiler()
{ /* Starts time profile */
if (time_profiling) {
-#ifdef CONCURRENT
- set_profile_timer(tick_millisecs);
+#ifdef PAR
+ set_profile_timer(RTSflags.CcFlags.msecsPerTick);
#else
set_profile_timer(TICK_MILLISECS);
#endif
\end{code}
\begin{code}
-#endif /* USE_COST_CENTRES || GUM */
+#endif /* PROFILING || PAR */
\end{code}
+++ /dev/null
-\section[Force_GC.lc]{Code for Forcing Garbage Collections}
-
-\begin{code}
-#include "rtsdefs.h"
-\end{code}
-
-Only have GC forcing if @FORCE_GC@ defined
-
-- currently only works with appel GC
-- in normal appel GC, if the force_gc flag is set *major* GC occurs
- at the next scheduled minor GC if at least GCInterval word allocations have happened
- since the last major GC.
- (It also occurs when the normal conditions for a major GC is met)
-- if the force2s and force_gc flags are set
- (forcing appel GC to work as a 2 space GC) GC occurs
- at least at every GCInterval word allocations
- (it also occurs when the semi-space limit is reached).
- Therefore it has no effect if the interval specified is >= semi-space.
-
-
-\begin{code}
-#if defined(FORCE_GC)
-\end{code}
-
-\begin{code}
-I_ force_GC = 0; /* Global Flag */
-I_ GCInterval = DEFAULT_GC_INTERVAL; /* words alloced */
-I_ alloc_since_last_major_GC = 0; /* words alloced since last major GC */
-
-
-#endif /* FORCE_GC */
-\end{code}
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
P_ hp_start; /* Value of Hp when reduction was resumed */
-I_
-initHeap( sm )
- smInfo *sm;
+rtsBool
+initHeap( smInfo *sm )
{
if (heap_space == 0) { /* allocates if it doesn't already exist */
/* Allocate the roots space */
- sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) );
+ sm->roots = (P_ *) stgMallocWords(SM_MAXROOTS, "initHeap (roots)");
/* Allocate the heap */
- heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_));
+ heap_space = (P_) stgMallocWords(RTSflags.GcFlags.heapSize + EXTRA_HEAP_WORDS,
+ "initHeap (heap)");
- compactingInfo.bit_words = (SM_word_heap_size + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
- compactingInfo.bits = (BitWord *)(heap_space + SM_word_heap_size) - compactingInfo.bit_words;
+ compactingInfo.bit_words
+ = (RTSflags.GcFlags.heapSize + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
+ compactingInfo.bits
+ = (BitWord *)(heap_space + RTSflags.GcFlags.heapSize) - compactingInfo.bit_words;
- compactingInfo.heap_words = SM_word_heap_size - compactingInfo.bit_words;
+ compactingInfo.heap_words = RTSflags.GcFlags.heapSize - compactingInfo.bit_words;
compactingInfo.base = HEAP_FRAME_BASE(heap_space, compactingInfo.heap_words);
compactingInfo.lim = HEAP_FRAME_LIMIT(heap_space, compactingInfo.heap_words);
sm->hp = hp_start = compactingInfo.base - 1;
- if (SM_alloc_size) {
- sm->hplim = sm->hp + SM_alloc_size;
- SM_alloc_min = 0; /* No min; alloc size specified */
+ if (! RTSflags.GcFlags.allocAreaSizeGiven) {
+ sm->hplim = compactingInfo.lim;
+ } else {
+ sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
+
+ RTSflags.GcFlags.minAllocAreaSize = 0; /* specified size takes precedence */
if (sm->hplim > compactingInfo.lim) {
fprintf(stderr, "Not enough heap for requested alloc size\n");
- return -1;
+ return rtsFalse;
}
- } else {
- sm->hplim = compactingInfo.lim;
}
sm->CAFlist = NULL;
initExtensions( sm );
#endif /* !PAR */
- if (SM_trace) {
+ if (RTSflags.GcFlags.trace) {
fprintf(stderr, "COMPACTING Heap: Base 0x%lx, Lim 0x%lx, Bits 0x%lx, bit words 0x%lx\n",
(W_) compactingInfo.base, (W_) compactingInfo.lim,
(W_) compactingInfo.bits, (W_) compactingInfo.bit_words);
(W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
}
- return 0;
+ return rtsTrue; /* OK */
}
I_
SAVE_REGS(&ScanRegDump); /* Save registers */
- if (SM_trace)
- {
+ if (RTSflags.GcFlags.trace) {
fflush(stdout); /* Flush stdout at start of GC */
fprintf(stderr, "COMPACTING Start: base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n",
(W_) compactingInfo.base, (W_) compactingInfo.lim,
resident = sm->hp - (compactingInfo.base - 1);
DO_MAX_RESIDENCY(resident); /* stats only */
- if (SM_alloc_size) {
- sm->hplim = sm->hp + SM_alloc_size;
+ if (! RTSflags.GcFlags.allocAreaSizeGiven) {
+ sm->hplim = compactingInfo.lim;
+ free_space = sm->hplim - sm->hp;
+ } else {
+ sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
if (sm->hplim > compactingInfo.lim) {
free_space = 0;
} else {
- free_space = SM_alloc_size;
+ free_space = RTSflags.GcFlags.allocAreaSize;
}
- } else {
- sm->hplim = compactingInfo.lim;
- free_space = sm->hplim - sm->hp;
}
hp_start = sm->hp;
stat_endGC(alloc, compactingInfo.heap_words, resident, "");
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
fprintf(stderr, "COMPACTING Done: base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
(W_) compactingInfo.base, (W_) compactingInfo.lim,
(W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_)));
RESTORE_REGS(&ScanRegDump); /* Restore Registers */
- if ((SM_alloc_min > free_space) || (reqsize > free_space))
+ if (free_space < RTSflags.GcFlags.minAllocAreaSize || free_space < reqsize)
return GC_HARD_LIMIT_EXCEEDED; /* Heap exhausted */
else
return GC_SUCCESS; /* Heap OK */
P_ hp_start; /* Value of Hp when reduction was resumed */
-I_ initHeap( sm )
- smInfo *sm;
+rtsBool
+initHeap(smInfo * sm)
{
if (heap_space == 0) { /* allocates if it doesn't already exist */
- I_ semispaceSize = SM_word_heap_size / 2;
+ I_ semispaceSize = RTSflags.GcFlags.heapSize / 2;
/* Allocate the roots space */
- sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) );
+ sm->roots = (P_ *) stgMallocWords(SM_MAXROOTS, "initHeap (roots)");
/* Allocate the heap */
- heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_));
+ heap_space = (P_) stgMallocWords(RTSflags.GcFlags.heapSize + EXTRA_HEAP_WORDS,
+ "initHeap (heap)");
/* Define the semi-spaces */
semispaceInfo[0].base = HEAP_FRAME_BASE(heap_space, semispaceSize);
sm->hp = hp_start = semispaceInfo[semispace].base - 1;
sm->hardHpOverflowSize = 0;
- if (SM_alloc_size) {
- sm->hplim = sm->hp + SM_alloc_size;
- SM_alloc_min = 0; /* No min; alloc size specified */
+ if (! RTSflags.GcFlags.allocAreaSizeGiven) {
+ sm->hplim = semispaceInfo[semispace].lim;
+ } else {
+ sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
+
+ RTSflags.GcFlags.minAllocAreaSize = 0; /* specified size takes precedence */
if (sm->hplim > semispaceInfo[semispace].lim) {
fprintf(stderr, "Not enough heap for requested alloc size\n");
- return -1;
+ return rtsFalse;
}
- } else {
- sm->hplim = semispaceInfo[semispace].lim;
}
-#if defined(FORCE_GC)
- if (force_GC) {
- if (sm->hplim > sm->hp + GCInterval) {
- sm->hplim = sm->hp + GCInterval;
- }
- else {
- force_GC = 0; /* forcing GC has no effect, as semi-space is smaller than GCInterval */
+ if (RTSflags.GcFlags.forceGC) {
+ if (sm->hplim > sm->hp + RTSflags.GcFlags.forcingInterval) {
+ sm->hplim = sm->hp + RTSflags.GcFlags.forcingInterval;
+ } else {
+ RTSflags.GcFlags.forceGC = rtsFalse;
+ /* forcing GC has no effect, as semi-space is smaller than forcingInterval */
}
}
-#endif /* FORCE_GC */
-
-#if defined(LIFE_PROFILE)
- sm->hplim = sm->hp + ((sm->hplim - sm->hp) / 2); /* space for HpLim incr */
- if (do_life_prof) {
- sm->hplim = sm->hp + LifeInterval;
- }
-#endif /* LIFE_PROFILE */
sm->CAFlist = NULL;
initExtensions( sm );
#endif /* !PAR */
- if (SM_trace) {
+ if (RTSflags.GcFlags.trace) {
fprintf(stderr, "TWO SPACE Heap: 0base, 0lim, 1base, 1lim\n 0x%lx, 0x%lx, 0x%lx, 0x%lx\n",
(W_) semispaceInfo[0].base, (W_) semispaceInfo[0].lim,
(W_) semispaceInfo[1].base, (W_) semispaceInfo[1].lim);
(W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
}
- return 0;
+ return rtsTrue; /* OK */
}
I_
smInfo *sm;
rtsBool do_full_collection; /* ignored */
{
-#if defined(LIFE_PROFILE)
- I_ next_interval; /* if doing profile */
-#endif
-
I_ free_space, /* No of words of free space following GC */
alloc, /* Number of words allocated since last GC */
resident, /* Number of words remaining after GC */
fflush(stdout); /* Flush stdout at start of GC */
SAVE_REGS(&ScavRegDump); /* Save registers */
-#if defined(LIFE_PROFILE)
- if (do_life_prof) { life_profile_setup(); }
-#endif /* LIFE_PROFILE */
-
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
if (interval_expired) { heap_profile_setup(); }
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING */
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
fprintf(stderr, "TWO SPACE Start: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n",
semispace, (W_) semispaceInfo[semispace].base,
(W_) semispaceInfo[semispace].lim,
resident = sm->hp - (semispaceInfo[semispace].base - 1);
DO_MAX_RESIDENCY(resident); /* stats only */
- if (SM_alloc_size) {
- sm->hplim = sm->hp + SM_alloc_size;
+ if (! RTSflags.GcFlags.allocAreaSizeGiven) {
+ sm->hplim = semispaceInfo[semispace].lim;
+ free_space = sm->hplim - sm->hp;
+ } else {
+ sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
if (sm->hplim > semispaceInfo[semispace].lim) {
free_space = 0;
} else {
- free_space = SM_alloc_size;
+ free_space = RTSflags.GcFlags.allocAreaSize;
}
- } else {
- sm->hplim = semispaceInfo[semispace].lim;
- free_space = sm->hplim - sm->hp;
}
- if (SM_stats_verbose) {
+ if (RTSflags.GcFlags.giveStats) {
char comment_str[BIG_STRING_LEN];
#ifndef PAR
sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu",
0, 0, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0, 0);
#endif
-#if defined(LIFE_PROFILE)
- if (do_life_prof) {
- strcat(comment_str, " life");
- }
-#endif
-#if defined(USE_COST_CENTRES)
- if (interval_expired) {
- strcat(comment_str, " prof");
- }
+#if defined(PROFILING)
+ if (interval_expired) { strcat(comment_str, " prof"); }
#endif
- stat_endGC(alloc, SM_word_heap_size, resident, comment_str);
+ stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, comment_str);
} else {
- stat_endGC(alloc, SM_word_heap_size, resident, "");
+ stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, "");
}
-#if defined(LIFE_PROFILE)
- free_space = free_space / 2; /* space for HpLim incr */
- if (do_life_prof) {
- next_interval = life_profile_done(alloc, reqsize);
- free_space -= next_interval; /* ensure interval available */
- }
-#endif /* LIFE_PROFILE */
-
-#if defined(USE_COST_CENTRES) || defined(GUM)
+#if defined(PROFILING) || defined(PAR)
if (interval_expired) {
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
heap_profile_done();
#endif
report_cc_profiling(0 /*partial*/);
}
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING */
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
fprintf(stderr, "TWO SPACE Done: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
semispace, (W_) semispaceInfo[semispace].base,
(W_) semispaceInfo[semispace].lim,
RESTORE_REGS(&ScavRegDump); /* Restore Registers */
- if ( (SM_alloc_min > free_space) || (reqsize > free_space) ) {
+ if (free_space < RTSflags.GcFlags.minAllocAreaSize || free_sapce < reqsize)
return( GC_HARD_LIMIT_EXCEEDED ); /* Heap absolutely exhausted */
- } else {
-#if defined(FORCE_GC)
- if (force_GC) {
- if (sm->hplim > sm->hp + GCInterval) {
- sm->hplim = sm->hp + GCInterval;
- }
- }
-#endif /* FORCE_GC */
-+
-#if defined(LIFE_PROFILE)
- /* space for HpLim incr */
- sm->hplim = sm->hp + ((sm->hplim - sm->hp) / 2);
- if (do_life_prof) {
- /* set hplim for next life profile */
- sm->hplim = sm->hp + next_interval;
- }
-#endif /* LIFE_PROFILE */
-
- if (reqsize + sm->hardHpOverflowSize > free_space) {
- return( GC_SOFT_LIMIT_EXCEEDED ); /* Heap nearly exhausted */
- } else {
- return( GC_SUCCESS ); /* Heap OK */
- }
+ else {
+ if (RTSflags.GcFlags.forceGC
+ && sm->hplim > sm->hp + RTSflags.GcFlags.forcingInterval) {
+ sm->hplim = sm->hp + RTSflags.GcFlags.forcingInterval;
+ }
+
+ if (reqsize + sm->hardHpOverflowSize > free_space) {
+ return( GC_SOFT_LIMIT_EXCEEDED ); /* Heap nearly exhausted */
+ } else {
+ return( GC_SUCCESS ); /* Heap OK */
+ }
}
}
#endif /* GC2s */
-
\end{code}
+++ /dev/null
-[
- SMalloc seems a BAD choice of name. I expected this to be the routines I
- could use to allocate memory, not those used by the storage manager internally.
-
- KH
-]
-
-Routines that deal with memory allocation:
-
-All dynamic allocation must be done before the stacks and heap are
-allocated. This allows us to use the lower level sbrk routines if
-required.
-
-\begin{code}
-#define NULL_REG_MAP
-#include "SMinternal.h"
-
-/* Return a ptr to n StgWords (note: WORDS not BYTES!) or die miserably */
-/* ToDo: Should allow use of valloc to allign on page boundary */
-
-char *
-#ifdef __STDC__
-xmalloc(size_t n)
-#else
-xmalloc(n)
- size_t n;
-#endif
-{
- char *space;
-
- if ((space = (char *) malloc(n)) == NULL) {
- MallocFailHook((W_) n); /*msg*/
- EXIT(EXIT_FAILURE);
- }
- return space;
-}
-\end{code}
P_ hp_start; /* Value of Hp when reduction was resumed */
-#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */
-P_ thisbase; /* Start of old gen before this minor collection */
-P_ prevbase; /* Start of old gen before previous minor collection */
-I_ prev_prom = 0; /* Promoted previous minor collection */
-I_ dead_prev_prom = 0; /* Dead words promoted previous minor */
-#endif /* PROMOTION_DATA */
-
-#if defined(_GC_DEBUG)
+static I_ allocd_since_last_major_GC = 0;
+ /* words alloced since last major GC; used when forcing GC */
+
+#if defined(DEBUG)
void
debug_look_for (start, stop, villain)
P_ start, stop, villain;
}
#endif
-I_
-initHeap( sm )
- smInfo *sm;
+rtsBool
+initHeap(smInfo * sm)
{
if (heap_space == 0) { /* allocates if it doesn't already exist */
/* Allocate the roots space */
- sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) );
+ sm->roots = (P_ *) stgMallocWords(SM_MAXROOTS, "initHeap (roots)");
/* Allocate the heap */
- heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_));
+ heap_space = (P_) stgMallocWords(RTSflags.GcFlags.heapSize + EXTRA_HEAP_WORDS,
+ "initHeap (heap)");
/* ToDo (ADR): trash entire heap contents */
- if (SM_force_gc == USE_2s) {
+ if (RTSflags.GcFlags.force2s) {
stat_init("TWOSPACE(APPEL)",
" No of Roots Caf Caf Astk Bstk",
"Astk Bstk Reg No bytes bytes bytes");
}
sm->hardHpOverflowSize = 0;
- if (SM_force_gc == USE_2s) {
- I_ semi_space_words = SM_word_heap_size / 2;
+ if (RTSflags.GcFlags.force2s) {
+ I_ semi_space_words = RTSflags.GcFlags.heapSize / 2;
appelInfo.space[0].base = HEAP_FRAME_BASE(heap_space, semi_space_words);
appelInfo.space[1].base = HEAP_FRAME_BASE(heap_space + semi_space_words, semi_space_words);
appelInfo.space[0].lim = HEAP_FRAME_LIMIT(heap_space, semi_space_words);
sm->hp = hp_start = appelInfo.space[appelInfo.semi_space].base - 1;
- if (SM_alloc_size) {
- sm->hplim = sm->hp + SM_alloc_size;
- SM_alloc_min = 0; /* No min; alloc size specified */
+ if (! RTSflags.GcFlags.allocAreaSizeGiven) {
+ sm->hplim = appelInfo.space[appelInfo.semi_space].lim;
+ } else {
+ sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
+
+ RTSflags.GcFlags.minAllocAreaSize = 0; /* specified size takes precedence */
if (sm->hplim > appelInfo.space[appelInfo.semi_space].lim) {
fprintf(stderr, "Not enough heap for requested alloc size\n");
- return -1;
+ return rtsFalse;
}
- } else {
- sm->hplim = appelInfo.space[appelInfo.semi_space].lim;
}
-#if defined(FORCE_GC)
- if (force_GC) {
- if (sm->hplim > sm->hp + GCInterval) {
- sm->hplim = sm->hp + GCInterval;
- }
- else {
+ if (RTSflags.GcFlags.forceGC) {
+ if (sm->hplim > sm->hp + RTSflags.GcFlags.forcingInterval) {
+ sm->hplim = sm->hp + RTSflags.GcFlags.forcingInterval;
+ } else {
/* no point in forcing GC,
- as the semi-space is smaller than GCInterval */
- force_GC = 0;
+ as the semi-space is smaller than forcingInterval */
+ RTSflags.GcFlags.forceGC = rtsFalse;
}
}
-#endif /* FORCE_GC */
-
-#if defined(LIFE_PROFILE)
- sm->hplim = sm->hp + ((sm->hplim - sm->hp) / 2); /* space for HpLim incr */
- if (do_life_prof) {
- sm->hplim = sm->hp + LifeInterval;
- }
-#endif /* LIFE_PROFILE */
sm->OldLim = appelInfo.oldlim;
sm->CAFlist = NULL;
initExtensions( sm );
#endif
- if (SM_trace) {
+ if (RTSflags.GcFlags.trace) {
fprintf(stderr, "APPEL(2s) Heap: 0x%lx .. 0x%lx\n",
- (W_) heap_space, (W_) (heap_space - 1 + SM_word_heap_size));
+ (W_) heap_space, (W_) (heap_space - 1 + RTSflags.GcFlags.heapSize));
fprintf(stderr, "Initial: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
appelInfo.semi_space,
(W_) appelInfo.space[appelInfo.semi_space].base,
(W_) appelInfo.space[appelInfo.semi_space].lim,
(W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
}
- return 0;
+ return rtsTrue;
}
/* So not forced 2s */
- appelInfo.newlim = heap_space + SM_word_heap_size - 1;
- if (SM_alloc_size) {
- appelInfo.newfixed = SM_alloc_size;
- appelInfo.newmin = SM_alloc_size;
- appelInfo.newbase = heap_space + SM_word_heap_size - appelInfo.newfixed;
+ appelInfo.newlim = heap_space + RTSflags.GcFlags.heapSize - 1;
+ if (RTSflags.GcFlags.allocAreaSizeGiven) {
+ appelInfo.newfixed = RTSflags.GcFlags.allocAreaSize;
+ appelInfo.newmin = RTSflags.GcFlags.allocAreaSize;
+ appelInfo.newbase = heap_space + RTSflags.GcFlags.heapSize - appelInfo.newfixed;
} else {
appelInfo.newfixed = 0;
- appelInfo.newmin = SM_alloc_min;
- appelInfo.newbase = heap_space + (SM_word_heap_size / 2);
+ appelInfo.newmin = RTSflags.GcFlags.minAllocAreaSize;
+ appelInfo.newbase = heap_space + (RTSflags.GcFlags.heapSize / 2);
}
appelInfo.oldbase = heap_space;
appelInfo.oldlim = heap_space - 1;
appelInfo.oldlast = heap_space - 1;
- appelInfo.oldmax = heap_space - 1 + SM_word_heap_size - 2*appelInfo.newmin;
+ appelInfo.oldmax = heap_space - 1 + RTSflags.GcFlags.heapSize - 2*appelInfo.newmin;
if (appelInfo.oldbase > appelInfo.oldmax) {
fprintf(stderr, "Not enough heap for requested/minimum allocation area\n");
- return -1;
+ fprintf(stderr, "heap_space=%ld\n", heap_space);
+ fprintf(stderr, "heapSize=%ld\n", RTSflags.GcFlags.heapSize);
+ fprintf(stderr, "newmin=%ld\n", appelInfo.newmin);
+ return rtsFalse;
}
- appelInfo.bit_words = (SM_word_heap_size + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
+ appelInfo.bit_words = (RTSflags.GcFlags.heapSize + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
appelInfo.bits = (BitWord *)(appelInfo.newlim) - appelInfo.bit_words;
+
if (appelInfo.bit_words > appelInfo.newmin)
- appelInfo.oldmax = heap_space - 1 + SM_word_heap_size - appelInfo.bit_words - appelInfo.newmin;
+ appelInfo.oldmax = heap_space - 1 + RTSflags.GcFlags.heapSize - appelInfo.bit_words - appelInfo.newmin;
- if (SM_major_gen_size) {
- appelInfo.oldthresh = heap_space -1 + SM_major_gen_size;
+ if (RTSflags.GcFlags.specifiedOldGenSize) {
+ appelInfo.oldthresh = heap_space -1 + RTSflags.GcFlags.specifiedOldGenSize;
if (appelInfo.oldthresh > appelInfo.oldmax) {
fprintf(stderr, "Not enough heap for requested major resid size\n");
- return -1;
+ return rtsFalse;
}
} else {
- appelInfo.oldthresh = heap_space + SM_word_heap_size * 2 / 3; /* Initial threshold -- 2/3rds */
+ appelInfo.oldthresh = heap_space + RTSflags.GcFlags.heapSize * 2 / 3; /* Initial threshold -- 2/3rds */
if (appelInfo.oldthresh > appelInfo.oldmax)
appelInfo.oldthresh = appelInfo.oldmax;
}
sm->hp = hp_start = appelInfo.newbase - 1;
sm->hplim = appelInfo.newlim;
-#if defined(FORCE_GC)
- if (force_GC && (sm->hplim > sm->hp + GCInterval)) {
- sm->hplim = sm->hp + GCInterval;
- }
-#endif /* FORCE_GC */
+ if (RTSflags.GcFlags.forceGC
+ && sm->hplim > sm->hp + RTSflags.GcFlags.forcingInterval) {
+ sm->hplim = sm->hp + RTSflags.GcFlags.forcingInterval;
+ }
sm->OldLim = appelInfo.oldlim;
appelInfo.PromMutables = 0;
-#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */
- prevbase = appelInfo.oldlim + 1;
- thisbase = appelInfo.oldlim + 1;
-#endif /* PROMOTION_DATA */
-
- if (SM_trace) {
+ if (RTSflags.GcFlags.trace) {
fprintf(stderr, "APPEL Heap: 0x%lx .. 0x%lx\n",
- (W_) heap_space, (W_) (heap_space - 1 + SM_word_heap_size));
+ (W_) heap_space, (W_) (heap_space - 1 + RTSflags.GcFlags.heapSize));
fprintf(stderr, "Initial: newbase 0x%lx newlim 0x%lx; base 0x%lx lim 0x%lx thresh 0x%lx max 0x%lx\n hp 0x%lx, hplim 0x%lx\n",
(W_) appelInfo.newbase, (W_) appelInfo.newlim,
(W_) appelInfo.oldbase, (W_) appelInfo.oldlim,
(W_) sm->hp, (W_) sm->hplim);
}
- return 0;
+ return rtsTrue; /* OK */
}
static I_
-collect2s(reqsize, sm)
- W_ reqsize;
- smInfo *sm;
+collect2s(W_ reqsize, smInfo *sm)
{
-#if defined(LIFE_PROFILE)
- I_ next_interval; /* if doing profile */
-#endif
I_ free_space, /* No of words of free space following GC */
alloc, /* Number of words allocated since last GC */
resident, /* Number of words remaining after GC */
SAVE_REGS(&ScavRegDump); /* Save registers */
-#if defined(LIFE_PROFILE)
- if (do_life_prof) { life_profile_setup(); }
-#endif /* LIFE_PROFILE */
-
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING)
if (interval_expired) { heap_profile_setup(); }
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING */
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
fprintf(stderr, "Start: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n",
appelInfo.semi_space,
(W_) appelInfo.space[appelInfo.semi_space].base,
resident = sm->hp - (appelInfo.space[appelInfo.semi_space].base - 1);
DO_MAX_RESIDENCY(resident); /* stats only */
- if (SM_alloc_size) {
- sm->hplim = sm->hp + SM_alloc_size;
+ if (! RTSflags.GcFlags.allocAreaSizeGiven) {
+ sm->hplim = appelInfo.space[appelInfo.semi_space].lim;
+ free_space = sm->hplim - sm->hp;
+ } else {
+ sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
if (sm->hplim > appelInfo.space[appelInfo.semi_space].lim) {
free_space = 0;
} else {
- free_space = SM_alloc_size;
+ free_space = RTSflags.GcFlags.allocAreaSize;
}
- } else {
- sm->hplim = appelInfo.space[appelInfo.semi_space].lim;
- free_space = sm->hplim - sm->hp;
}
-#if defined(FORCE_GC)
- if (force_GC && (sm->hplim > sm->hp + GCInterval)) {
- sm->hplim = sm->hp + GCInterval;
- }
-#endif /* FORCE_GC */
+ if (RTSflags.GcFlags.forceGC
+ && sm->hplim > sm->hp + RTSflags.GcFlags.forcingInterval) {
+ sm->hplim = sm->hp + RTSflags.GcFlags.forcingInterval;
+ }
- if (SM_stats_verbose) {
+ if (RTSflags.GcFlags.giveStats) {
char comment_str[BIG_STRING_LEN];
#ifndef PAR
- sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu 2s",
- (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
+ sprintf(comment_str, "%4lu %4ld %3ld %3ld %6lu %6lu %6lu 2s",
+ (W_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
bstk_roots, sm->rootno,
caf_roots, extra_caf_words*sizeof(W_),
- (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_),
- (SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_));
+ (W_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_),
+ (W_) (SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_));
#else
/* ToDo: come up with some interesting statistics for the parallel world */
sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu 2s",
#endif
-#if defined(LIFE_PROFILE)
- if (do_life_prof) {
- strcat(comment_str, " life");
- }
-#endif
-#if defined(USE_COST_CENTRES)
- if (interval_expired) {
- strcat(comment_str, " prof");
- }
+#if defined(PROFILING)
+ if (interval_expired) { strcat(comment_str, " prof"); }
#endif
- stat_endGC(alloc, SM_word_heap_size, resident, comment_str);
+ stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, comment_str);
} else {
- stat_endGC(alloc, SM_word_heap_size, resident, "");
+ stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, "");
}
-#if defined(LIFE_PROFILE)
- free_space = free_space / 2; /* space for HpLim incr */
- if (do_life_prof) {
- next_interval = life_profile_done(alloc, reqsize);
- free_space -= next_interval; /* ensure interval available */
- }
-#endif /* LIFE_PROFILE */
-
-#if defined(USE_COST_CENTRES) || defined(GUM)
+#if defined(PROFILING) || defined(PAR)
if (interval_expired) {
-# if defined(USE_COST_CENTRES)
+# if defined(PROFILING)
heap_profile_done();
# endif
report_cc_profiling(0 /*partial*/);
}
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING */
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
fprintf(stderr, "Done: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
appelInfo.semi_space,
(W_) appelInfo.space[appelInfo.semi_space].base,
we just came from. */
{
I_ old_space = NEXT_SEMI_SPACE(appelInfo.semi_space);
+
TrashMem(appelInfo.space[old_space].base, appelInfo.space[old_space].lim);
TrashMem(sm->hp+1, sm->hplim);
}
RESTORE_REGS(&ScavRegDump); /* Restore Registers */
- if ( (SM_alloc_min > free_space) || (reqsize > free_space) ) {
+ if (free_space < RTSflags.GcFlags.minAllocAreaSize || free_space < reqsize)
return( GC_HARD_LIMIT_EXCEEDED ); /* Heap absolutely exhausted */
- } else {
-
-#if defined(LIFE_PROFILE)
- /* ToDo: this may not be right now (WDP 94/11) */
-
- /* space for HpLim incr */
- sm->hplim = sm->hp + ((sm->hplim - sm->hp) / 2);
- if (do_life_prof) {
- /* set hplim for next life profile */
- sm->hplim = sm->hp + next_interval;
- }
-#endif /* LIFE_PROFILE */
-
+ else {
if (reqsize + sm->hardHpOverflowSize > free_space) {
return( GC_SOFT_LIMIT_EXCEEDED ); /* Heap nearly exhausted */
} else {
rtsBool do_full_collection; /* do a major collection regardless? */
{
I_ bstk_roots, caf_roots, mutable, old_words;
- P_ oldptr, old_start, mutptr, prevmut;
+ P_ old_start, mutptr, prevmut;
P_ CAFptr, prevCAF;
- P_ next;
I_ alloc, /* Number of words allocated since last GC */
resident; /* Number of words remaining after GC */
-#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */
- I_ promote, /* Promoted this minor collection */
- dead_prom, /* Dead words promoted this minor */
- dead_prev; /* Promoted words that died since previos minor collection */
- I_ root;
- P_ base[2];
-#endif /* PROMOTION_DATA */
-
fflush(stdout); /* Flush stdout at start of GC */
- if (SM_force_gc == USE_2s) {
+ if (RTSflags.GcFlags.force2s) {
return collect2s(reqsize, sm);
}
SAVE_REGS(&ScavRegDump); /* Save registers */
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
fprintf(stderr, "Start: newbase 0x%lx, newlim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n",
(W_) appelInfo.newbase, (W_) appelInfo.newlim, (W_) sm->hp, (W_) sm->hplim, reqsize * sizeof(W_));
alloc = sm->hp - hp_start;
stat_startGC(alloc);
-#ifdef FORCE_GC
- alloc_since_last_major_GC += sm->hplim - hp_start;
+ allocd_since_last_major_GC += sm->hplim - hp_start;
/* this is indeed supposed to be less precise than alloc above */
-#endif /* FORCE_GC */
/* COPYING COLLECTION */
while ( mutptr ) {
/* Scavenge the OldMutable */
+ P_ orig_mutptr = mutptr;
P_ info = (P_) INFO_PTR(mutptr);
StgScavPtr scav_code = SCAV_CODE(info);
Scav = mutptr;
prevmut = mutptr;
mutptr = (P_) MUT_LINK(mutptr);
}
+
mutable++;
}
resident = appelInfo.oldlim - sm->OldLim;
/* DONT_DO_MAX_RESIDENCY -- it is just a minor collection */
- if (SM_stats_verbose) {
+ if (RTSflags.GcFlags.giveStats) {
char minor_str[BIG_STRING_LEN];
#ifndef PAR
- sprintf(minor_str, "%4u %4ld %3ld %3ld %4ld Minor",
- (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
+ sprintf(minor_str, "%4lu %4ld %3ld %3ld %4ld Minor",
+ (W_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
bstk_roots, sm->rootno, caf_roots, mutable); /* oldnew_roots, old_words */
#else
/* ToDo: come up with some interesting statistics for the parallel world */
/* Note: if do_full_collection we want to force a full collection. [ADR] */
-#ifdef FORCE_GC
- if (force_GC && (alloc_since_last_major_GC >= GCInterval)) {
- do_full_collection = 1;
+ if (RTSflags.GcFlags.forceGC
+ && allocd_since_last_major_GC >= RTSflags.GcFlags.forcingInterval) {
+ do_full_collection = 1;
}
-#endif /* FORCE_GC */
-
-#if defined(PROMOTION_DATA) /* For dead promote & premature promote data major required */
-
- if (! SM_stats_verbose &&
- (appelInfo.oldlim < appelInfo.oldthresh) &&
- (reqsize + sm->hardHpOverflowSize <= appelInfo.newlim - appelInfo.newbase) &&
- (! do_full_collection) ) {
-
-#else /* ! PROMOTION_DATA */
if ((appelInfo.oldlim < appelInfo.oldthresh) &&
(reqsize + sm->hardHpOverflowSize <= appelInfo.newlim - appelInfo.newbase) &&
(! do_full_collection) ) {
-#endif /* ! PROMOTION_DATA */
-
sm->hp = hp_start = appelInfo.newbase - 1;
sm->hplim = appelInfo.newlim;
-#if defined(FORCE_GC)
- if (force_GC &&
- (alloc_since_last_major_GC + (sm->hplim - hp_start) > GCInterval))
- {
- sm->hplim = sm->hp + (GCInterval - alloc_since_last_major_GC);
+ if (RTSflags.GcFlags.forceGC
+ && (allocd_since_last_major_GC + (sm->hplim - hp_start) > RTSflags.GcFlags.forcingInterval)) {
+ sm->hplim = sm->hp + (RTSflags.GcFlags.forcingInterval - allocd_since_last_major_GC);
}
-#endif /* FORCE_GC */
sm->OldLim = appelInfo.oldlim;
- if (SM_trace) {
+ if (RTSflags.GcFlags.trace) {
fprintf(stderr, "Minor: newbase 0x%lx newlim 0x%lx; base 0x%lx lim 0x%lx thresh 0x%lx max 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
(W_) appelInfo.newbase, (W_) appelInfo.newlim,
(W_) appelInfo.oldbase, (W_) appelInfo.oldlim,
DEBUG_STRING("Major Collection Required");
-#ifdef FORCE_GC
- alloc_since_last_major_GC = 0;
-#endif /* FORCE_GC */
+ allocd_since_last_major_GC = 0;
stat_startGC(0);
alloc = (appelInfo.oldlim - appelInfo.oldbase) + 1;
-#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */
- if (SM_stats_verbose) {
- promote = appelInfo.oldlim - thisbase + 1;
- }
-#endif /* PROMOTION_DATA */
-
appelInfo.bit_words = (alloc + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
appelInfo.bits = (BitWord *)(appelInfo.newlim) - appelInfo.bit_words;
/* For some reason, this doesn't seem to use the last
LinkCAFs(appelInfo.OldCAFlist);
-#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */
- /* What does this have to do with CAFs? -- JSM */
- if (SM_stats_verbose) {
- base[0] = thisbase;
- base[1] = prevbase;
-
- if (SM_trace) {
- fprintf(stderr, "Promote Bases: lim 0x%lx this 0x%lx prev 0x%lx Actual: ",
- appelInfo.oldlim + 1, thisbase, prevbase);
- }
-
- /* search for first live closure for thisbase & prevbase */
- for (root = 0; root < 2; root++) {
- P_ baseptr, search, scan_w_start;
- I_ prev_words, bit_words, bit_rem;
- BitWord *bit_array_ptr, *bit_array_end;
-
- baseptr = base[root];
- prev_words = (baseptr - appelInfo.oldbase);
- bit_words = prev_words / BITS_IN(BitWord);
- bit_rem = prev_words & (BITS_IN(BitWord) - 1);
-
- bit_array_ptr = appelInfo.bits + bit_words;
- bit_array_end = appelInfo.bits + appelInfo.bit_words;
- scan_w_start = baseptr - bit_rem;
-
- baseptr = 0;
- while (bit_array_ptr < bit_array_end && !baseptr) {
- BitWord w = *(bit_array_ptr++);
- search = scan_w_start;
- if (bit_rem) {
- search += bit_rem;
- w >>= bit_rem;
- bit_rem = 0;
- }
- while (w && !baseptr) {
- if (w & 0x1) { /* bit set -- found first closure */
- baseptr = search;
- } else {
- search++; /* look at next bit */
- w >>= 1;
- }
- }
- scan_w_start += BITS_IN(BitWord);
- }
- if (SM_trace) {
- fprintf(stderr, "0x%lx%s", baseptr, root == 2 ? "\n" : " ");
- }
-
- base[root] = baseptr;
- if (baseptr) {
- LINK_LOCATION_TO_CLOSURE(base + root);
- }
- }
- }
-#endif /* PROMOTION_DATA */
-
LinkRoots( sm->roots, sm->rootno );
#ifdef CONCURRENT
LinkSparks();
/* set major threshold, if not fixed */
/* next major collection when old gen occupies 2/3rds of the free space or exceeds oldmax */
- if (! SM_major_gen_size) {
+ if (! RTSflags.GcFlags.specifiedOldGenSize) {
appelInfo.oldthresh = appelInfo.oldlim + (appelInfo.newlim - appelInfo.oldlim) * 2 / 3;
if (appelInfo.oldthresh > appelInfo.oldmax)
appelInfo.oldthresh = appelInfo.oldmax;
sm->hp = hp_start = appelInfo.newbase - 1;
sm->hplim = appelInfo.newlim;
-#if defined(FORCE_GC)
- if (force_GC && (sm->hplim > sm->hp + GCInterval)) {
- sm->hplim = sm->hp + GCInterval;
- }
-#endif /* FORCE_GC */
+ if (RTSflags.GcFlags.forceGC
+ && sm->hplim > sm->hp + RTSflags.GcFlags.forcingInterval) {
+ sm->hplim = sm->hp + RTSflags.GcFlags.forcingInterval;
+ }
sm->OldLim = appelInfo.oldlim;
-#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */
- if (SM_stats_verbose) {
- /* restore moved thisbase & prevbase */
- thisbase = base[0] ? base[0] : appelInfo.oldlim + 1;
- prevbase = base[1] ? base[1] : appelInfo.oldlim + 1;
-
- /* here are the numbers we want */
- dead_prom = promote - (appelInfo.oldlim + 1 - thisbase);
- dead_prev = prev_prom - (thisbase - prevbase) - dead_prev_prom;
-
- if (SM_trace) {
- fprintf(stderr, "Collect Bases: lim 0x%lx this 0x%lx prev 0x%lx\n",
- appelInfo.oldlim + 1, thisbase, prevbase);
- fprintf(stderr, "Promoted: %ld Dead: this %ld prev %ld + %ld\n",
- promote, dead_prom, dead_prev_prom, dead_prev);
- }
-
- /* save values for next collection */
- prev_prom = promote;
- dead_prev_prom = dead_prom;
- prevbase = thisbase;
- thisbase = appelInfo.oldlim + 1;
- }
-#endif /* PROMOTION_DATA */
-
#ifdef HAVE_VADVISE
vadvise(VA_NORM);
#endif
- if (SM_stats_verbose) {
+ if (RTSflags.GcFlags.giveStats) {
char major_str[BIG_STRING_LEN];
#ifndef PAR
- sprintf(major_str, "%4u %4ld %3ld %3ld %4d %4d *Major* %4.1f%%",
- (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
+ sprintf(major_str, "%4lu %4ld %3ld %3ld %4d %4d *Major* %4.1f%%",
+ (W_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
bstk_roots, sm->rootno, appelInfo.OldCAFno,
- 0, 0, resident / (StgFloat) SM_word_heap_size * 100);
+ 0, 0, resident / (StgDouble) RTSflags.GcFlags.heapSize * 100);
#else
/* ToDo: come up with some interesting statistics for the parallel world */
sprintf(major_str, "%4u %4ld %3ld %3ld %4d %4d *Major* %4.1f%%",
0, 0L, sm->rootno, appelInfo.OldCAFno, 0, 0,
- resident / (StgFloat) SM_word_heap_size * 100);
+ resident / (StgDouble) RTSflags.GcFlags.heapSize * 100);
#endif
-#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */
- { char *promote_str[BIG_STRING_LEN];
- sprintf(promote_str, " %6ld %6ld", dead_prom*sizeof(W_), dead_prev*sizeof(W_));
- strcat(major_str, promote_str);
- }
-#endif /* PROMOTION_DATA */
-
stat_endGC(0, alloc, resident, major_str);
} else {
stat_endGC(0, alloc, resident, "");
}
- if (SM_trace) {
+ if (RTSflags.GcFlags.trace) {
fprintf(stderr, "Major: newbase 0x%lx newlim 0x%lx; base 0x%lx lim 0x%lx thresh 0x%lx max 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
(W_) appelInfo.newbase, (W_) appelInfo.newlim,
(W_) appelInfo.oldbase, (W_) appelInfo.oldlim,
#include "SMinternal.h"
#define isHeapPtr(p) \
- ((p) >= heap_space && (p) < heap_space + SM_word_heap_size)
+ ((p) >= heap_space && (p) < heap_space + RTSflags.GcFlags.heapSize)
#if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */
#define validInfoPtr(i) \
/* Two cases needed, depending on whether the 2-space GC is forced
SLPJ 17 June 93 */
#define validHeapPtr(p) \
- (SM_force_gc == USE_2s ? \
+ (RTSflags.GcFlags.force2s ? \
((p) >= appelInfo.space[appelInfo.semi_space].base && \
(p) <= appelInfo.space[appelInfo.semi_space].lim) : \
(((p) >= appelInfo.oldbase && (p) <= appelInfo.oldlim) || \
#ifdef PAR
void
-LinkLiveGAs(base, bits)
-P_ base;
-BitWord *bits;
+LinkLiveGAs(P_ base, BitWord *bits)
{
GALA *gala;
GALA *next;
prev = gala;
} else {
/* Since we have all of the weight, this GA is no longer needed */
- W_ pga = PACK_GA(thisPE, gala->ga.loc.gc.slot);
+ W_ pga = PackGA(thisPE, gala->ga.loc.gc.slot);
#ifdef FREE_DEBUG
fprintf(stderr, "Freeing slot %d\n", gala->ga.loc.gc.slot);
bit = 1L << (_hp_word & (BITS_IN(BitWord) - 1));
if (!(bits[bit_index] & bit)) {
int pe = taskIDtoPE(gala->ga.loc.gc.gtid);
- W_ pga = PACK_GA(pe, gala->ga.loc.gc.slot);
- int i;
+ W_ pga = PackGA(pe, gala->ga.loc.gc.slot);
(void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
freeRemoteGA(pe, &(gala->ga));
DEBUG_STRING("Linking B Stack:");
for (updateFramePtr = stackB;
- SUBTRACT_B_STK(updateFramePtr, botB) > 0;
- /* re-initialiser given explicitly */ ) {
+ SUBTRACT_B_STK(updateFramePtr, botB) > 0;
+ updateFramePtr = GRAB_SuB(updateFramePtr)) {
P_ updateClosurePtr = updateFramePtr + BREL(UF_UPDATEE);
LINK_LOCATION_TO_CLOSURE(updateClosurePtr);
-
- updateFramePtr = GRAB_SuB(updateFramePtr);
}
}
#endif /* not PAR */
\begin{code}
I_
-CountCAFs(CAFlist)
-P_ CAFlist;
+CountCAFs(P_ CAFlist)
{
I_ caf_no = 0;
\begin{code}
void
-LinkCAFs(CAFlist)
-P_ CAFlist;
+LinkCAFs(P_ CAFlist)
{
DEBUG_STRING("Linking CAF Ptr Locations:");
while(CAFlist != NULL) {
}
}
-\end{code}
-
-\begin{code}
-
-#ifdef PAR
-
-#endif /* PAR */
-
#endif /* defined(_INFO_COMPACTING) */
\end{code}
\section[SMcompacting-header]{Header file for SMcompacting}
\begin{code}
-extern void LinkRoots PROTO((P_ roots[], I_ rootno));
-extern void LinkAStack PROTO((PP_ stackA, PP_ botA));
-extern void LinkBStack PROTO((P_ stackB, P_ botB));
-extern I_ CountCAFs PROTO((P_ CAFlist));
+void LinkRoots PROTO((P_ roots[], I_ rootno));
+void LinkAStack PROTO((PP_ stackA, PP_ botA));
+void LinkBStack PROTO((P_ stackB, P_ botB));
+I_ CountCAFs PROTO((P_ CAFlist));
-extern void LinkCAFs PROTO((P_ CAFlist));
+void LinkCAFs PROTO((P_ CAFlist));
+#ifdef CONCURRENT
+void LinkSparks(STG_NO_ARGS);
+#endif
\end{code}
\begin{code}
void
-SetCAFInfoTables( CAFlist )
- P_ CAFlist;
+SetCAFInfoTables(P_ CAFlist)
{
P_ CAFptr;
\begin{code}
void
-EvacuateRoots( roots, rootno )
- P_ roots[];
- I_ rootno;
+EvacuateRoots(P_ roots[], I_ rootno)
{
I_ root;
\begin{code}
#ifndef PAR
void
-EvacuateAStack( stackA, botA )
- PP_ stackA;
- PP_ botA; /* botA points to bottom-most word */
+EvacuateAStack(PP_ stackA, PP_ botA /* botA points to bottom-most word */)
{
PP_ stackptr;
#endif /* not PAR */
\end{code}
-When we do a copying collection, we want to evacuate all of the local entries
-in the GALA table for which there are outstanding remote pointers (i.e. for
-which the weight is not MAX_GA_WEIGHT.)
+When we do a copying collection, we want to evacuate all of the local
+entries in the GALA table for which there are outstanding remote
+pointers (i.e. for which the weight is not MAX_GA_WEIGHT.)
\begin{code}
-
#ifdef PAR
void
-EvacuateLocalGAs(full)
-rtsBool full;
+EvacuateLocalGAs(rtsBool full)
{
GALA *gala;
GALA *next;
prev = gala;
} else {
/* Since we have all of the weight, this GA is no longer needed */
- W_ pga = PACK_GA(thisPE, gala->ga.loc.gc.slot);
+ W_ pga = PackGA(thisPE, gala->ga.loc.gc.slot);
#ifdef FREE_DEBUG
fprintf(stderr, "Freeing slot %d\n", gala->ga.loc.gc.slot);
EXTDATA_RO(Forward_Ref_info);
void
-RebuildGAtables(full)
-rtsBool full;
+RebuildGAtables(rtsBool full)
{
GALA *gala;
GALA *next;
#endif
if (INFO_PTR(closure) != (W_) Forward_Ref_info) {
int pe = taskIDtoPE(gala->ga.loc.gc.gtid);
- W_ pga = PACK_GA(pe, gala->ga.loc.gc.slot);
- int i;
+ W_ pga = PackGA(pe, gala->ga.loc.gc.slot);
(void) removeHashTable(pGAtoGALAtable, pga, (void *) gala);
freeRemoteGA(pe, &(gala->ga));
\begin{code}
void
-Scavenge()
+Scavenge(void)
{
DEBUG_SCAN("Scavenging Start", Scav, "ToHp", ToHp);
while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
CAFptr != NULL;
CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
- EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
- caf_roots++;
-
- DEBUG_SCAN("Scavenging CAF", Scav, "ToHp", ToHp);
- while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
- DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
+ EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */
+ caf_roots++;
- /* this_extra_caf_words = ToHp - this_caf_start; */
- /* ToDo: Report individual CAF space */
+ DEBUG_SCAN("Scavenging CAF", Scav, "ToHp", ToHp);
+ while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))();
+ DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp);
}
*extra_words = ToHp - caf_start;
*roots = caf_roots;
\section[SMcopying-header]{Header file for SMcopying}
\begin{code}
-extern void SetCAFInfoTables PROTO(( P_ CAFlist ));
-extern void EvacuateRoots PROTO(( P_ roots[], I_ rootno ));
-extern void EvacuateAStack PROTO(( PP_ stackA, PP_ botA ));
-extern void EvacuateBStack PROTO(( P_ stackB, P_ botB, I_ *roots ));
-extern void Scavenge PROTO(());
+void SetCAFInfoTables PROTO(( P_ CAFlist ));
+void EvacuateRoots PROTO(( P_ roots[], I_ rootno ));
+void EvacuateAStack PROTO(( PP_ stackA, PP_ botA ));
+void EvacuateBStack PROTO(( P_ stackB, P_ botB, I_ *roots ));
+void Scavenge (STG_NO_ARGS);
+
+#ifdef CONCURRENT
+void EvacuateSparks(STG_NO_ARGS);
+#endif
#ifdef GCdu
extern void EvacuateCAFs PROTO(( P_ CAFlist ));
P_ hp_start; /* Value of Hp when reduction was resumed */
-I_
-initHeap( sm )
- smInfo *sm;
+rtsBool
+initHeap(smInfo * sm)
{
if (heap_space == 0) { /* allocates if it doesn't already exist */
- I_ semispaceSize = SM_word_heap_size / 2;
+ I_ semispaceSize = RTSflags.GcFlags.heapSize / 2;
/* Allocate the roots space */
- sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) );
+ sm->roots = (P_ *) stgMallocWords(SM_MAXROOTS, "initHeap (roots)");
/* Allocate the heap */
- heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_));
+ heap_space = (P_) stgMallocWords(RTSflags.GcFlags.heapSize + EXTRA_HEAP_WORDS,
+ "initHeap (heap)");
dualmodeInfo.modeinfo[TWO_SPACE_BOT].heap_words =
- dualmodeInfo.modeinfo[TWO_SPACE_TOP].heap_words = SM_word_heap_size;
+ dualmodeInfo.modeinfo[TWO_SPACE_TOP].heap_words = RTSflags.GcFlags.heapSize;
dualmodeInfo.modeinfo[TWO_SPACE_BOT].base =
HEAP_FRAME_BASE(heap_space, semispaceSize);
dualmodeInfo.modeinfo[TWO_SPACE_TOP].lim =
HEAP_FRAME_LIMIT(heap_space + semispaceSize, semispaceSize);
- dualmodeInfo.bit_words = (SM_word_heap_size + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
- dualmodeInfo.bits = (BitWord *)(heap_space + SM_word_heap_size) - dualmodeInfo.bit_words;
+ dualmodeInfo.bit_words = (RTSflags.GcFlags.heapSize + BITS_IN(BitWord) - 1) / BITS_IN(BitWord);
+ dualmodeInfo.bits = (BitWord *)(heap_space + RTSflags.GcFlags.heapSize) - dualmodeInfo.bit_words;
dualmodeInfo.modeinfo[COMPACTING].heap_words =
- SM_word_heap_size - dualmodeInfo.bit_words;
+ RTSflags.GcFlags.heapSize - dualmodeInfo.bit_words;
dualmodeInfo.modeinfo[COMPACTING].base =
- HEAP_FRAME_BASE(heap_space, SM_word_heap_size - dualmodeInfo.bit_words);
+ HEAP_FRAME_BASE(heap_space, RTSflags.GcFlags.heapSize - dualmodeInfo.bit_words);
dualmodeInfo.modeinfo[COMPACTING].lim =
- HEAP_FRAME_LIMIT(heap_space, SM_word_heap_size - dualmodeInfo.bit_words);
+ HEAP_FRAME_LIMIT(heap_space, RTSflags.GcFlags.heapSize - dualmodeInfo.bit_words);
stat_init("DUALMODE", "Collection", " Mode ");
}
if (SM_alloc_size) {
sm->hplim = sm->hp + SM_alloc_size;
- SM_alloc_min = 0; /* No min; alloc size specified */
+
+ RTSflags.GcFlags.minAllocAreaSize = 0; /* specified size takes precedence */
if (sm->hplim > dualmodeInfo.modeinfo[dualmodeInfo.mode].lim) {
fprintf(stderr, "Not enough heap for requested alloc size\n");
- return -1;
+ return rtsFalse;
}
} else {
sm->hplim = dualmodeInfo.modeinfo[dualmodeInfo.mode].lim;
initExtensions( sm );
#endif /* !PAR */
- if (SM_trace) {
+ if (RTSflags.GcFlags.trace) {
fprintf(stderr, "DUALMODE Heap: TS base, TS lim, TS base, TS lim, CM base, CM lim, CM bits, bit words\n 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx\n",
(W_) dualmodeInfo.modeinfo[TWO_SPACE_BOT].base,
(W_) dualmodeInfo.modeinfo[TWO_SPACE_BOT].lim,
(W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_));
}
- return 0;
+ return rtsTrue; /* OK */
}
I_
fflush(stdout); /* Flush stdout at start of GC */
SAVE_REGS(&ScavRegDump); /* Save registers */
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
fprintf(stderr, "DUALMODE Start: mode %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n",
dualmodeInfo.mode,
(W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].base,
/* Use residency to determine if a change in mode is required */
resident = sm->hp - (dualmodeInfo.modeinfo[dualmodeInfo.mode].base - 1);
- residency = resident / (StgFloat) SM_word_heap_size;
+ residency = resident / (StgFloat) RTSflags.GcFlags.heapSize;
DO_MAX_RESIDENCY(resident); /* stats only */
if ((start_mode == TWO_SPACE_TOP) &&
stat_endGC(alloc, dualmodeInfo.modeinfo[start_mode].heap_words,
resident, dualmodeInfo.modeinfo[start_mode].name);
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
fprintf(stderr, "DUALMODE Done: mode %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
dualmodeInfo.mode,
(W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].base,
RESTORE_REGS(&ScavRegDump); /* Restore Registers */
- if ((SM_alloc_min > free_space) || (reqsize > free_space))
+ if (free_space < RTSflags.GcFlags.minAllocAreaSize || free_space < reqsize)
return GC_HARD_LIMIT_EXCEEDED; /* Heap exhausted */
else
return GC_SUCCESS; /* Heap OK */
/*** DEBUGGING MACROS ***/
-#if defined(_GC_DEBUG)
+#if defined(DEBUG)
#define DEBUG_EVAC(sizevar) \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: 0x%lx -> 0x%lx, info 0x%lx, size %ld\n", \
evac, ToHp, INFO_PTR(evac), sizevar)
#define DEBUG_EVAC_DYN \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Dyn info 0x%lx, size %lu\n", \
evac, ToHp, INFO_PTR(evac), DYN_CLOSURE_SIZE(evac))
#define DEBUG_EVAC_TUPLE \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Tuple info 0x%lx, size %lu\n", \
evac, ToHp, INFO_PTR(evac), TUPLE_CLOSURE_SIZE(evac))
#define DEBUG_EVAC_MUTUPLE \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: 0x%lx -> 0x%lx, MuTuple info 0x%lx, size %lu\n", \
evac, ToHp, INFO_PTR(evac), MUTUPLE_CLOSURE_SIZE(evac))
#define DEBUG_EVAC_DATA \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Data info 0x%lx, size %lu\n", \
evac, ToHp, INFO_PTR(evac), DATA_CLOSURE_SIZE(evac))
#define DEBUG_EVAC_BH(sizevar) \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BH info 0x%lx, size %ld\n", \
evac, ToHp, INFO_PTR(evac), sizevar)
#define DEBUG_EVAC_FORWARD \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: Forward 0x%lx -> 0x%lx, info 0x%lx\n", \
evac, FORWARD_ADDRESS(evac), INFO_PTR(evac))
#define DEBUG_EVAC_IND1 \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: Indirection 0x%lx -> Evac(0x%lx), info 0x%lx\n", \
evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))
#define DEBUG_EVAC_IND2 \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: Indirection Done -> 0x%lx\n", evac)
#define DEBUG_EVAC_PERM_IND \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: Permanent Indirection 0x%lx -> Evac(0x%lx), info 0x%lx\n", \
evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))
#define DEBUG_EVAC_CAF_EVAC1 \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: Caf 0x%lx -> Evac(0x%lx), info 0x%lx\n", \
evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))
#define DEBUG_EVAC_CAF_EVAC2 \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: Caf Done -> 0x%lx\n", evac)
#define DEBUG_EVAC_CAF_RET \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: Caf 0x%lx -> 0x%lx, info 0x%lx\n", \
evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac))
#define DEBUG_EVAC_STAT \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: Static 0x%lx -> 0x%lx, info 0x%lx\n", \
evac, evac, INFO_PTR(evac))
#define DEBUG_EVAC_CONST \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: Const 0x%lx -> 0x%lx, info 0x%lx\n", \
evac, CONST_STATIC_CLOSURE(INFO_PTR(evac)), INFO_PTR(evac))
#define DEBUG_EVAC_CHARLIKE \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: CharLike (%lx) 0x%lx -> 0x%lx, info 0x%lx\n", \
evac, CHARLIKE_VALUE(evac), CHARLIKE_CLOSURE(CHARLIKE_VALUE(evac)), INFO_PTR(evac))
#define DEBUG_EVAC_INTLIKE_TO_STATIC \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Evac: IntLike to Static (%ld) 0x%lx -> 0x%lx, info 0x%lx\n", \
INTLIKE_VALUE(evac), evac, INTLIKE_CLOSURE(INTLIKE_VALUE(evac)), INFO_PTR(evac))
#define DEBUG_EVAC_TO_OLD \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Old ")
#define DEBUG_EVAC_TO_NEW \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "New ")
#define DEBUG_EVAC_OLD_TO_NEW(oldind, evac, new) \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, " OldRoot: 0x%lx -> Old 0x%lx (-> New 0x%lx)\n", \
evac, oldind, newevac)
#define DEBUG_EVAC_OLDROOT_FORWARD \
- if (SM_trace & 2) { \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) { \
fprintf(stderr, "Evac: OldRoot Forward 0x%lx -> Old 0x%lx ", evac, FORWARD_ADDRESS(evac)); \
if (! InOldGen(Scav)) fprintf(stderr, "-> New 0x%lx ", IND_CLOSURE_PTR(FORWARD_ADDRESS(evac))); \
fprintf(stderr, "info 0x%lx\n", INFO_PTR(evac)); \
#ifdef CONCURRENT
#define DEBUG_EVAC_BQ \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BQ info 0x%lx, size %lu\n", \
evac, ToHp, INFO_PTR(evac), BQ_CLOSURE_SIZE(evac))
#define DEBUG_EVAC_TSO(size) \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
fprintf(stderr, "Evac TSO: 0x%lx -> 0x%lx, size %ld\n", \
evac, ToHp, size)
#define DEBUG_EVAC_STKO(a,b) \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
fprintf(stderr, "Evac StkO: 0x%lx -> 0x%lx, size %ld (A), %ld (B)\n", \
evac, ToHp, a, b)
# ifdef PAR
# define DEBUG_EVAC_BF \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BF info 0x%lx, size %lu\n", \
evac, ToHp, INFO_PTR(evac), BF_CLOSURE_SIZE(dummy))
# endif
# endif
#endif
-#endif /* not _GC_DEBUG */
+#endif /* not DEBUG */
#if defined(GCgn)
FORWARD_ADDRESS(closure) = (W_)(forw)
-P_
-_Evacuate_Old_Forward_Ref(evac)
-P_ evac;
+EVAC_FN(Old_Forward_Ref)
{
/* Forward ref to old generation -- just return */
DEBUG_EVAC_FORWARD;
return(evac);
}
-P_
-_Evacuate_New_Forward_Ref(evac)
-P_ evac;
+EVAC_FN(New_Forward_Ref)
{
/* Forward ref to new generation -- check scavenged from the old gen */
DEBUG_EVAC_FORWARD;
return(evac);
}
-P_
-_Evacuate_OldRoot_Forward(evac)
-P_ evac;
+EVAC_FN(OldRoot_Forward)
{
/* Forward ref to old generation root -- return old root or new gen closure */
DEBUG_EVAC_OLDROOT_FORWARD;
DEBUG_EVAC_OLD_TO_NEW(oldind, evac, newevac);
- INFO_PTR(evac) = (W_) OldRoot_Forward_Ref_info;
- FORWARD_ADDRESS(evac) = (W_)oldind;
+ INFO_PTR(evac) = (W_) OldRoot_Forward_Ref_info;
+ FORWARD_ADDRESS(evac) = (W_)oldind;
- INFO_PTR(oldind) = (W_) OldRoot_info;
- IND_CLOSURE_PTR(oldind) = (W_) newevac;
+ INFO_PTR(oldind) = (W_) OldRoot_info;
+ IND_CLOSURE_PTR(oldind) = (W_) newevac;
IND_CLOSURE_LINK(oldind) = (W_) genInfo.OldInNew;
genInfo.OldInNew = oldind;
genInfo.OldInNewno++;
/*** Real Evac Code -- simply passed closure ***/
-#define EVAC_FN(suffix) \
- P_ CAT2(_Evacuate_,suffix)(evac) \
- P_ evac;
+#define EVAC_FN(suffix) P_ CAT2(_Evacuate_,suffix)(P_ evac)
/*** FORWARD REF STUFF ***/
\end{code}
-A @SPEC_RBH@ must be at least size @MIN_UPD_SIZE@ (Who are we fooling?
+A @SPEC_RBH@ must be at least size @MIN_UPD_SIZE@ (Whom are we fooling?
This means 2), and the first word after the fixed header is a
@MUT_LINK@. The second word is a pointer to a blocking queue.
Remaining words are the same as the underlying @SPEC@ closure. Unlike
#ifdef PAR
-#define SPEC_RBH_EVAC_FN(n) \
-EVAC_FN(CAT2(RBH_,n)) \
-{ \
- int i; \
- START_ALLOC(n); \
- DEBUG_EVAC(n); \
- COPY_FIXED_HDR; \
- for (i = 0; i < n - 1; i++) { COPY_WORD(SPEC_RBH_HS + i); } \
- SET_FORWARD_REF(evac,ToHp); \
- evac = ToHp; \
- FINISH_ALLOC(n); \
- PROMOTE_MUTABLE(evac);\
- return(evac); \
+#define SPEC_RBH_EVAC_FN(n) \
+EVAC_FN(CAT2(RBH_,n)) \
+{ \
+ I_ count = FIXED_HS - 1; \
+ I_ size = SPEC_RBH_VHS + (n); \
+ START_ALLOC(size); \
+ DEBUG_EVAC(size); \
+ COPY_FIXED_HDR; \
+ while (++count <= size + (FIXED_HS - 1)) { \
+ COPY_WORD(count); \
+ } \
+ SET_FORWARD_REF(evac,ToHp); \
+ evac = ToHp; \
+ FINISH_ALLOC(size); \
+ \
+ PROMOTE_MUTABLE(evac); \
+ \
+ return(evac); \
}
/* instantiate for 2--12 */
#ifndef PAR
EVAC_FN(MallocPtr)
{
- START_ALLOC(MallocPtr_SIZE);
- DEBUG_EVAC(MallocPtr_SIZE);
+ I_ size = MallocPtr_SIZE;
+ START_ALLOC(size);
+ DEBUG_EVAC(size);
-#if defined(_GC_DEBUG)
- if (SM_trace & 16) {
+#if defined(DEBUG)
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
printf("DEBUG: Evacuating MallocPtr(%x)=<%x,_,%x,%x>", evac, evac[0], evac[2], evac[3]);
printf(" Data = %x, Next = %x\n",
MallocPtr_CLOSURE_DATA(evac), MallocPtr_CLOSURE_LINK(evac) );
MallocPtr_CLOSURE_DATA(ToHp) = MallocPtr_CLOSURE_DATA(evac);
MallocPtr_CLOSURE_LINK(ToHp) = MallocPtr_CLOSURE_LINK(evac);
-#if defined(_GC_DEBUG)
- if (SM_trace & 16) {
+#if defined(DEBUG)
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
printf("DEBUG: Evacuated MallocPtr(%x)=<%x,_,%x,%x>", ToHp, ToHp[0], ToHp[2], ToHp[3]);
printf(" Data = %x, Next = %x\n",
MallocPtr_CLOSURE_DATA(ToHp), MallocPtr_CLOSURE_LINK(ToHp) );
#endif
evac = ToHp;
- FINISH_ALLOC(MallocPtr_SIZE);
+ FINISH_ALLOC(size);
return(evac);
}
#endif /* !PAR */
Evac already contains this address -- just return */
/* Scavenging: Static closures should never be scavenged */
-P_
-_Evacuate_Static(evac)
-P_ evac;
+EVAC_FN(Static)
{
DEBUG_EVAC_STAT;
return(evac);
}
-void
-_Scavenge_Static(STG_NO_ARGS)
-{
- fprintf(stderr,"Called _Scavenge_Static: Closure %lx Info %lx\nShould never occur!\n", (W_) Scav, INFO_PTR(Scav));
- abort();
-}
-
-
/*** BLACK HOLE CODE ***/
EVAC_FN(BH_U)
{
- START_ALLOC(MIN_UPD_SIZE);
- DEBUG_EVAC_BH(MIN_UPD_SIZE);
+ START_ALLOC(BH_U_SIZE);
+ DEBUG_EVAC_BH(BH_U_SIZE);
COPY_FIXED_HDR;
SET_FORWARD_REF(evac,ToHp);
evac = ToHp;
- FINISH_ALLOC(MIN_UPD_SIZE);
+ FINISH_ALLOC(BH_U_SIZE);
return(evac);
}
EVAC_FN(BH_N)
{
- START_ALLOC(MIN_NONUPD_SIZE);
- DEBUG_EVAC_BH(MIN_NONUPD_SIZE);
+ START_ALLOC(BH_N_SIZE);
+ DEBUG_EVAC_BH(BH_N_SIZE);
COPY_FIXED_HDR;
SET_FORWARD_REF(evac,ToHp);
evac = ToHp;
- FINISH_ALLOC(MIN_NONUPD_SIZE);
+ FINISH_ALLOC(BH_N_SIZE);
return(evac);
}
/*** INDIRECTION CODE ***/
-/* Evacuation: Evacuate closure pointed to */
+/* permanent indirections first */
+#if defined(PROFILING) || defined(TICKY_TICKY)
+#undef PI
-P_
-_Evacuate_Ind(evac)
-P_ evac;
+EVAC_FN(PI) /* used for ticky in case just below... */
+{
+#ifdef TICKY_TICKY
+ if (! AllFlags.doUpdEntryCounts) {
+ DEBUG_EVAC_IND1;
+ GC_SHORT_IND(); /* ticky: record that we shorted an indirection */
+
+ evac = (P_) IND_CLOSURE_PTR(evac);
+
+# if defined(GCgn) || defined(GCap)
+ if (evac > OldGen) /* Only evacuate new gen with generational collector */
+ evac = EVACUATE_CLOSURE(evac);
+# else
+ evac = EVACUATE_CLOSURE(evac);
+# endif
+
+ DEBUG_EVAC_IND2;
+ } else {
+#endif
+
+ /* *not* shorting one out... */
+ START_ALLOC(IND_CLOSURE_SIZE(dummy));
+ DEBUG_EVAC_PERM_IND;
+ COPY_FIXED_HDR;
+ COPY_WORD(IND_HS);
+ SET_FORWARD_REF(evac,ToHp);
+ evac = ToHp;
+ FINISH_ALLOC(IND_CLOSURE_SIZE(dummy));
+
+#ifdef TICKY_TICKY
+ }
+#endif
+ return(evac);
+}
+#endif /* PROFILING or TICKY */
+
+EVAC_FN(Ind) /* Indirections are shorted-out; if doing weird ticky
+ stuff, we will have used *permanent* indirections
+ for overwriting updatees...
+ */
{
DEBUG_EVAC_IND1;
+ GC_SHORT_IND(); /* ticky: record that we shorted an indirection */
+
evac = (P_) IND_CLOSURE_PTR(evac);
-#if defined(GCgn) || defined(GCap)
+# if defined(GCgn) || defined(GCap)
if (evac > OldGen) /* Only evacuate new gen with generational collector */
evac = EVACUATE_CLOSURE(evac);
-#else
+# else
evac = EVACUATE_CLOSURE(evac);
-#endif
+# endif
DEBUG_EVAC_IND2;
- return(evac);
/* This will generate a stack of returns for a chain of indirections!
However chains can only be 2 long.
- */
-}
+ */
-#ifdef USE_COST_CENTRES
-#undef PI
-EVAC_FN(PI)
-{
- START_ALLOC(MIN_UPD_SIZE);
- DEBUG_EVAC_PERM_IND;
- COPY_FIXED_HDR;
- COPY_WORD(IND_HS);
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(MIN_UPD_SIZE);
return(evac);
}
-#endif
/*** SELECTORS CODE (much like an indirection) ***/
the n'th field is.
ToDo: what if the constructor is a Gen thing?
+
+ "selector_depth" stuff below: (WDP 95/12)
+
+ It is possible to have a *very* considerable number of selectors
+ all chained together, which will cause the code here to chew up
+ enormous C stack space (very deeply nested set of calls), which
+ can crash the program.
+
+ Various solutions are possible, but we opt for a simple one --
+ we run a "selector_depth" counter, and we stop doing the
+ selections if we get beyond that depth. The main nice property
+ is that it doesn't affect (or slow down) any of the rest of the
+ GC.
+
+ What should the depth be? For SPARC friendliness, it should
+ probably be very small (e.g., 8 or 16), to avoid register-window
+ spillage. However, that would increase the chances that
+ selectors are left undone and lots of junk is promoted to the
+ old generation. So we set it quite a bit higher -- we'd like to
+ do all the selections except in the most extreme circumstances.
*/
+static int selector_depth = 0;
+#define MAX_SELECTOR_DEPTH 100 /* reasonably arbitrary */
+
static P_
-_EvacuateSelector_n(evac, n)
- P_ evac;
- I_ n;
+_EvacuateSelector_n(P_ evac, I_ n)
{
P_ maybe_con = (P_) evac[_FHS];
/* must be a SPEC 2 1 closure */
ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */
-#if defined(_GC_DEBUG)
- if (SM_trace & 2)
- fprintf(stderr, "Evac Selector: 0x%lx, info 0x%lx, maybe_con 0x%lx, info 0x%lx, tag %ld\n",
- evac, INFO_PTR(evac), maybe_con,
+#ifdef TICKY_TICKY
+ /* if a thunk, its update-entry count must be zero */
+ ASSERT(TICKY_HDR(evac) == 0);
+#endif
+
+ selector_depth++; /* see story above */
+
+#if defined(DEBUG)
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC)
+ fprintf(stderr, "Evac Selector (depth %ld): 0x%lx, info 0x%lx, maybe_con 0x%lx, info 0x%lx, tag %ld\n",
+ selector_depth, evac, INFO_PTR(evac), maybe_con,
INFO_PTR(maybe_con), INFO_TAG(INFO_PTR(maybe_con)));
#endif
- if (INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */
+ if (INFO_TAG(INFO_PTR(maybe_con)) < 0 /* not in WHNF */
+#if !defined(CONCURRENT)
+ || (! RTSflags.GcFlags.lazyBlackHoling) /* see "price of laziness" paper */
+#endif
+ || selector_depth > MAX_SELECTOR_DEPTH
+ || (! RTSflags.GcFlags.doSelectorsAtGC)
+ ) {
+#ifdef TICKY_TICKY
+ if (INFO_TAG(INFO_PTR(maybe_con)) >= 0) { /* we *could* have done it */
+ GC_SEL_ABANDONED();
+ }
+#endif
/* Evacuate as normal (it is size *2* because of MIN_UPD_SIZE) */
return( _Evacuate_2(evac) );
+ }
-#if defined(_GC_DEBUG)
- if (SM_trace & 2)
+#if defined(DEBUG)
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC)
fprintf(stderr, "Evac Selector:shorting: 0x%lx -> 0x%lx\n",
evac, maybe_con[_FHS + n]);
#endif
/* Ha! Short it out */
evac = (P_) (maybe_con[_FHS + n]); /* evac now has the result of the selection */
+ GC_SEL_MINOR(); /* ticky-ticky */
+
#if defined(GCgn) || defined(GCap)
if (evac > OldGen) /* Only evacuate new gen with generational collector */
evac = EVACUATE_CLOSURE(evac);
evac = EVACUATE_CLOSURE(evac);
#endif
+ selector_depth--; /* see story above */
+
return(evac);
}
#ifdef CONCURRENT
EVAC_FN(BQ)
{
- START_ALLOC(MIN_UPD_SIZE);
+ START_ALLOC(BQ_CLOSURE_SIZE(dummy));
DEBUG_EVAC_BQ;
COPY_FIXED_HDR;
SET_FORWARD_REF(evac,ToHp);
evac = ToHp;
- FINISH_ALLOC(MIN_UPD_SIZE);
+ FINISH_ALLOC(BQ_CLOSURE_SIZE(dummy));
/* Add to OldMutables list (if evacuated to old generation) */
PROMOTE_MUTABLE(evac);
EVAC_FN(TSO)
{
I_ count;
+ I_ size = TSO_VHS + TSO_CTS_SIZE;
- START_ALLOC(TSO_VHS + TSO_CTS_SIZE);
- DEBUG_EVAC_TSO(TSO_VHS + TSO_CTS_SIZE);
+ START_ALLOC(size);
+ DEBUG_EVAC_TSO(size);
COPY_FIXED_HDR;
for (count = FIXED_HS; count < FIXED_HS + TSO_VHS; count++) {
SET_FORWARD_REF(evac, ToHp);
evac = ToHp;
- FINISH_ALLOC(TSO_VHS + TSO_CTS_SIZE);
+ FINISH_ALLOC(size);
/* Add to OldMutables list (if evacuated to old generation) */
PROMOTE_MUTABLE(evac);
EVAC_FN(StkO)
{
I_ count;
- I_ size = STKO_CLOSURE_SIZE(evac);
+ I_ size = STKO_CLOSURE_SIZE(evac);
I_ spa_offset = STKO_SpA_OFFSET(evac);
I_ spb_offset = STKO_SpB_OFFSET(evac);
I_ sub_offset = STKO_SuB_OFFSET(evac);
I_ offset;
+ ASSERT(sanityChk_StkO(evac));
+
START_ALLOC(size);
DEBUG_EVAC_STKO(STKO_CLOSURE_CTS_SIZE(evac) - spa_offset + 1, spb_offset);
COPY_FIXED_HDR;
-#ifdef DO_REDN_COUNTING
+#ifdef TICKY_TICKY
COPY_WORD(STKO_ADEP_LOCN);
COPY_WORD(STKO_BDEP_LOCN);
#endif
EVAC_FN(BF)
{
I_ count;
+ I_ size = BF_CLOSURE_SIZE(evac);
- START_ALLOC(BF_CLOSURE_SIZE(evac));
+ START_ALLOC(size);
DEBUG_EVAC_BF;
COPY_FIXED_HDR;
SET_FORWARD_REF(evac, ToHp);
evac = ToHp;
- FINISH_ALLOC(BF_CLOSURE_SIZE(evac));
+ FINISH_ALLOC(size);
/* Add to OldMutables list (if evacuated to old generation) */
PROMOTE_MUTABLE(evac);
/*** SPECIAL CAF CODE ***/
/* Evacuation: Return closure pointed to (already explicitly evacuated) */
-/* Scavenging: Should not be scavenged */
-P_
-_Evacuate_Caf(evac)
-P_ evac;
+EVAC_FN(Caf)
{
DEBUG_EVAC_CAF_RET;
+ GC_SHORT_CAF(); /* ticky: record that we shorted an indirection */
+
evac = (P_) IND_CLOSURE_PTR(evac);
return(evac);
}
/* In addition we need an internal Caf indirection which evacuates,
- updates and returns the indirection. Before GC is started the
+ updates and returns the indirection. Before GC is started, the
@CAFlist@ must be traversed and the info tables set to this.
*/
-P_
-_Evacuate_Caf_Evac_Upd(evac)
- P_ evac;
+EVAC_FN(Caf_Evac_Upd)
{
P_ closure = evac;
DEBUG_EVAC_CAF_EVAC1;
- INFO_PTR(evac) = (W_) Caf_info; /* Change to return CAF */
+
+ INFO_PTR(evac) = (W_) Caf_info; /* Change back to Caf_info */
evac = (P_) IND_CLOSURE_PTR(evac); /* Grab reference and evacuate */
/*** CONST CLOSURE CODE ***/
/* Evacuation: Just return address of the static closure stored in the info table */
-/* Scavenging: Const closures should never be scavenged */
-P_
-_Evacuate_Const(evac)
-P_ evac;
+EVAC_FN(Const)
{
+#ifdef TICKY_TICKY
+ if (AllFlags.doUpdEntryCounts) {
+ /* evacuate as if a closure of size 0
+ (there is no _Evacuate_0 to call)
+ */
+ START_ALLOC(0);
+ DEBUG_EVAC(0);
+ COPY_FIXED_HDR;
+ SET_FORWARD_REF(evac,ToHp);
+ evac = ToHp;
+ FINISH_ALLOC(0);
+
+ } else {
+#endif
+
DEBUG_EVAC_CONST;
+ GC_COMMON_CONST(); /* ticky */
+
evac = CONST_STATIC_CLOSURE(INFO_PTR(evac));
- return(evac);
-}
-void
-_Scavenge_Const(STG_NO_ARGS)
-{
- fprintf(stderr,"Called _Scavenge_Const: Closure %lx Info %lx\nShould never occur!\n", (W_) Scav, INFO_PTR(Scav));
- abort();
+#ifdef TICKY_TICKY
+ }
+#endif
+ return(evac);
}
-
/*** CHARLIKE CLOSURE CODE ***/
/* Evacuation: Just return address of the static closure stored fixed array */
-/* Scavenging: CharLike closures should never be scavenged */
-P_
-_Evacuate_CharLike(evac)
-P_ evac;
+EVAC_FN(CharLike)
{
+#ifdef TICKY_TICKY
+ if (AllFlags.doUpdEntryCounts) {
+ evac = _Evacuate_1(evac); /* evacuate closure of size 1 */
+ } else {
+#endif
+
DEBUG_EVAC_CHARLIKE;
+ GC_COMMON_CHARLIKE(); /* ticky */
+
evac = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(evac));
- return(evac);
-}
-void
-_Scavenge_CharLike(STG_NO_ARGS)
-{
- fprintf(stderr,"Called _Scavenge_CharLike: Closure %lx Info %lx\nShould never occur!\n", (W_) Scav, INFO_PTR(Scav));
- abort();
+#ifdef TICKY_TICKY
+ }
+#endif
+ return(evac);
}
\end{code}
Evacuation: Return address of the static closure if available
Otherwise evacuate converting to aux closure.
-Scavenging: IntLike closures should never be scavenged.
-
There are some tricks here:
\begin{enumerate}
\item
{
I_ val = INTLIKE_VALUE(evac);
- if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) { /* in range of static closures */
+ if (val >= MIN_INTLIKE /* in range of static closures */
+ && val <= MAX_INTLIKE
+#ifdef TICKY_TICKY
+ && !AllFlags.doUpdEntryCounts
+#endif
+ ) {
DEBUG_EVAC_INTLIKE_TO_STATIC;
- evac = (P_) INTLIKE_CLOSURE(val); /* return appropriate static closure */
+ GC_COMMON_INTLIKE(); /* ticky */
+
+ evac = (P_) INTLIKE_CLOSURE(val); /* return appropriate static closure */
}
else {
- START_ALLOC(1); /* evacuate closure of size 1 */
- DEBUG_EVAC(1);
- COPY_FIXED_HDR;
- SPEC_COPY_FREE_VAR(1);
- SET_FORWARD_REF(evac,ToHp);
- evac = ToHp;
- FINISH_ALLOC(1);
+ evac = _Evacuate_1(evac); /* evacuate closure of size 1 */
+
+#ifdef TICKY_TICKY
+ if (!AllFlags.doUpdEntryCounts) GC_COMMON_INTLIKE_FAIL();
+#endif
}
+
return(evac);
}
{
/* assertion overly strong - if free_mem == 0, sm->hp == sm->hplim */
/* ASSERT( from <= to ); */
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
printf("Trashing from 0x%lx to 0x%lx inclusive\n", (W_) from, (W_) to);
while (from <= to) {
*from++ = DEALLOCATED_TRASH;
void
Trash_MallocPtr_Closure(mptr)
P_ mptr;
-{ int i;
- for( i = 0; i != MallocPtr_SIZE + _FHS; i++ ) {
- mptr[ i ] = DEALLOCATED_TRASH;
- }
+{
+ int i;
+ for( i = 0; i < MallocPtr_SIZE + _FHS; i++ ) {
+ mptr[ i ] = DEALLOCATED_TRASH;
+ }
}
\end{code}
Trace_MallocPtr( MPptr )
P_ MPptr;
{
- if (SM_trace & 16) {
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
printf("DEBUG: MallocPtr(%lx)=<%lx,_,%lx,%lx,%lx>\n", (W_) MPptr, (W_) MPptr[0], (W_) MPptr[1], (W_) MPptr[2], (W_) MPptr[3]);
printf(" Data = %lx, Next = %lx\n",
(W_) MallocPtr_CLOSURE_DATA(MPptr), (W_) MallocPtr_CLOSURE_LINK(MPptr) );
void
Trace_MPdies()
{
- if (SM_trace & 16) {
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
printf(" dying\n");
}
}
void
Trace_MPlives()
{
- if (SM_trace & 16) {
- printf(" lived to tell the tale \n");
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
+ printf(" lived to tell the tale\n");
}
}
Trace_MPforwarded( MPPtr, newAddress )
P_ MPPtr, newAddress;
{
- if (SM_trace & 16) {
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
printf(" forwarded to %lx\n", (W_) newAddress);
}
}
\begin{code}
#ifndef PAR
-extern void initExtensions PROTO((smInfo *sm));
+void initExtensions PROTO((smInfo *sm));
-#if defined(_INFO_COPYING)
+# if defined(_INFO_COPYING)
-extern void evacSPTable PROTO((smInfo *sm));
-extern void reportDeadMallocPtrs PROTO((StgPtr oldMPList, StgPtr new, StgPtr *newMPLust));
+void evacSPTable PROTO((smInfo *sm));
+void reportDeadMallocPtrs PROTO((StgPtr oldMPList, StgPtr new, StgPtr *newMPLust));
-#endif /* _INFO_COPYING */
+# endif /* _INFO_COPYING */
-#if defined(_INFO_COMPACTING)
+# if defined(_INFO_COMPACTING)
-extern void sweepUpDeadMallocPtrs PROTO((
- P_ MallocPtrList,
- P_ base,
- BitWord *bits
- ));
+void sweepUpDeadMallocPtrs PROTO((P_ MallocPtrList,
+ P_ base,
+ BitWord *bits
+ ));
-#endif /* _INFO_COMPACTING */
+# endif /* _INFO_COMPACTING */
-extern void TrashMem PROTO(( P_ from, P_ to ));
+void TrashMem PROTO(( P_ from, P_ to ));
-#if defined(DEBUG)
+# if defined(DEBUG)
-extern void Trash_MallocPtr_Closure PROTO((P_ mptr));
-extern void Validate_MallocPtrList PROTO(( P_ MallocPtrList ));
+void Trash_MallocPtr_Closure PROTO((P_ mptr));
+void Validate_MallocPtrList PROTO(( P_ MallocPtrList ));
-extern void Trace_MPdies PROTO((void));
-extern void Trace_MPlives PROTO((void));
-extern void Trace_MPforwarded PROTO(( P_ MPPtr, P_ newAddress ));
+void Trace_MPdies PROTO((void));
+void Trace_MPlives PROTO((void));
+void Trace_MPforwarded PROTO(( P_ MPPtr, P_ newAddress ));
-
-#endif /* DEBUG */
+# endif /* DEBUG */
#endif /* !PAR */
\end{code}
P_ hp_start; /* Value of Hp when reduction was resumed */
/* Always allocbase - 1 */
-I_
-initHeap( sm )
- smInfo *sm;
+rtsBool
+initHeap(smInfo * sm)
{
I_ heap_error = 0;
I_ bit_words;
if (heap_space == 0) { /* allocates if it doesn't already exist */
/* Allocate the roots space */
- sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) );
+ sm->roots = (P_ *) stgMallocWords(SM_MAXROOTS, "initHeap (roots)");
/* Allocate the heap */
- heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_));
+ heap_space = (P_) stgMallocWords(SM_word_heap_size + EXTRA_HEAP_WORDS,
+ "initHeap (heap)");
- if (SM_force_gc == USE_2s) {
+ if (RTSflags.GcFlags.force2s) {
stat_init("TWOSPACE(GEN)",
" No of Roots Caf Caf Astk Bstk",
"Astk Bstk Reg No bytes bytes bytes");
}
}
- if (SM_force_gc == USE_2s) {
- genInfo.semi_space = SM_word_heap_size / 2;
+ if (RTSflags.GcFlags.force2s) {
+ genInfo.semi_space = RTSflags.GcFlags.heapSize / 2;
genInfo.space[0].base = HEAP_FRAME_BASE(heap_space, genInfo.semi_space);
genInfo.space[1].base = HEAP_FRAME_BASE(heap_space + genInfo.semi_space, genInfo.semi_space);
genInfo.space[0].lim = HEAP_FRAME_LIMIT(heap_space, genInfo.semi_space);
sm->hp = hp_start = genInfo.space[genInfo.semi_space].base - 1;
- if (SM_alloc_size) {
- sm->hplim = sm->hp + SM_alloc_size;
- SM_alloc_min = 0; /* No min; alloc size specified */
+ if (! RTSflags.GcFlags.allocAreaSizeGiven) {
+ sm->hplim = genInfo.space[genInfo.semi_space].lim;
+ } else {
+ sm->hplim = sm->hp + RTSflags.GcFlags.allocAreaSize;
+
+ RTSflags.GcFlags.minAllocAreaSize = 0; /* specified size takes precedence */
if (sm->hplim > genInfo.space[genInfo.semi_space].lim) {
fprintf(stderr, "Not enough heap for requested alloc size\n");
- return -1;
+ return rtsFalse;
}
- } else {
- sm->hplim = genInfo.space[genInfo.semi_space].lim;
}
sm->OldLim = genInfo.oldlim;
initExtensions( sm );
#endif
- if (SM_trace) {
+ if (RTSflags.GcFlags.trace) {
fprintf(stderr, "GEN(2s) Heap: 0x%lx .. 0x%lx\n",
- (W_) heap_space, (W_) (heap_space - 1 + SM_word_heap_size));
+ (W_) heap_space, (W_) (heap_space - 1 + RTSflags.GcFlags.heapSize));
fprintf(stderr, "Initial: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %ld\n",
genInfo.semi_space,
(W_) genInfo.space[genInfo.semi_space].base,
(W_) genInfo.space[genInfo.semi_space].lim,
(W_) sm->hp, (W_) sm->hplim, (I_) (sm->hplim - sm->hp));
}
- return 0;
+ return rtsTrue;
}
- if (SM_alloc_size == 0) SM_alloc_size = DEFAULT_ALLOC_SIZE;
-
- genInfo.alloc_words = SM_alloc_size;
- genInfo.new_words = SM_alloc_size;
+ genInfo.alloc_words = RTSflags.GcFlags.allocAreaSize;
+ genInfo.new_words = RTSflags.GcFlags.allocAreaSize;
- genInfo.allocbase = heap_space + SM_word_heap_size - genInfo.alloc_words;
- genInfo.alloclim = heap_space + SM_word_heap_size - 1;
+ genInfo.allocbase = heap_space + RTSflags.GcFlags.heapSize - genInfo.alloc_words;
+ genInfo.alloclim = heap_space + RTSflags.GcFlags.heapSize - 1;
genInfo.newgen[0].newbase = genInfo.allocbase - genInfo.new_words;
genInfo.newgen[0].newlim = genInfo.newgen[0].newbase - 1;
genInfo.oldbase = heap_space;
- if (SM_major_gen_size) {
- genInfo.old_words = SM_major_gen_size;
+ if (RTSflags.GcFlags.specifiedOldGenSize) {
+ genInfo.old_words = RTSflags.GcFlags.specifiedOldGenSize;
genInfo.oldend = heap_space + genInfo.old_words - 1;
genInfo.oldthresh = genInfo.oldend - genInfo.new_words;
/* ToDo: extra old ind words not accounted for ! */
if (genInfo.bit_vect + bit_words >= (BitWord *) genInfo.newgen[1].newbase) heap_error = 1;
}
} else {
- genInfo.old_words = SM_word_heap_size - genInfo.alloc_words - 2 * genInfo.new_words;
+ genInfo.old_words = RTSflags.GcFlags.heapSize - genInfo.alloc_words - 2 * genInfo.new_words;
genInfo.oldend = heap_space + genInfo.old_words - 1;
genInfo.oldthresh = genInfo.oldend - genInfo.new_words;
/* ToDo: extra old ind words not accounted for ! */
}
if (heap_error) {
- fprintf(stderr, "initHeap: Requested heap size: %ld\n", SM_word_heap_size);
+ fprintf(stderr, "initHeap: Requested heap size: %ld\n", RTSflags.GcFlags.heapSize);
fprintf(stderr, " Alloc area %ld Delay area %ld Old area %ld Bit area %ld\n",
genInfo.alloc_words, genInfo.new_words * 2, genInfo.old_words,
genInfo.bit_vect == (BitWord *) genInfo.allocbase ? 0 : bit_words);
initExtensions( sm );
#endif
- if (SM_trace) {
+ if (RTSflags.GcFlags.trace) {
fprintf(stderr, "GEN Heap: 0x%lx .. 0x%lx\n",
- (W_) heap_space, (W_) (heap_space + SM_word_heap_size - 1));
+ (W_) heap_space, (W_) (heap_space + RTSflags.GcFlags.heapSize - 1));
fprintf(stderr, " alloc %ld, new %ld, old %ld, bit %ld\n",
genInfo.alloc_words, genInfo.new_words, genInfo.old_words, bit_words);
fprintf(stderr, " allocbase 0x%lx, alloclim 0x%lx\n",
SAVE_REGS(&ScavRegDump); /* Save registers */
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
fprintf(stderr, "Start: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n",
genInfo.semi_space,
(W_) genInfo.space[genInfo.semi_space].base,
/* DONT_DO_MAX_RESIDENCY -- because this collector is utterly hosed */
free_space = sm->hplim - sm->hp;
- if (SM_stats_verbose) {
+ if (RTSflags.GcFlags.giveStats) {
char comment_str[BIG_STRING_LEN];
#ifndef PAR
sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu 2s",
sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu 2s",
0, 0, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0, 0);
#endif
- stat_endGC(alloc, SM_word_heap_size, resident, comment_str);
+ stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, comment_str);
} else {
- stat_endGC(alloc, SM_word_heap_size, resident, "");
+ stat_endGC(alloc, RTSflags.GcFlags.heapSize, resident, "");
}
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
fprintf(stderr, "Done: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
genInfo.semi_space,
(W_) genInfo.space[genInfo.semi_space].base,
RESTORE_REGS(&ScavRegDump); /* Restore Registers */
- if ((SM_alloc_size > free_space) || (reqsize > free_space))
+ if ((RTSflags.GcFlags.allocAreaSize > free_space) || (reqsize > free_space))
return(-1); /* Heap exhausted */
return(0); /* Heap OK */
fflush(stdout); /* Flush stdout at start of GC */
- if (SM_force_gc == USE_2s) {
+ if (RTSflags.GcFlags.force2s) {
return collect2s(reqsize, sm);
}
SAVE_REGS(&ScavRegDump); /* Save registers */
- if (SM_trace) fprintf(stderr, "GEN Start: hp 0x%lx, hplim 0x%lx, req %ld Minor\n",
+ if (RTSflags.GcFlags.trace)
+ fprintf(stderr, "GEN Start: hp 0x%lx, hplim 0x%lx, req %ld Minor\n",
(W_) sm->hp, (W_) sm->hplim, (I_) (reqsize * sizeof(W_)));
alloc = sm->hp - hp_start;
sm->MallocPtrList = NULL; /* all (new) MallocPtrs have been promoted */
#endif /* PAR */
- if (SM_stats_verbose) {
+ if (RTSflags.GcFlags.giveStats) {
char minor_str[BIG_STRING_LEN];
#ifndef PAR
sprintf(minor_str, "%6lu %4lu %4lu %4ld %3ld %3ld %4ld %3ld %3ld %6ld Minor",
sm->hplim = genInfo.alloclim;
sm->OldLim = genInfo.oldlim;
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
fprintf(stderr, "GEN End: oldbase 0x%lx, oldlim 0x%lx, oldthresh 0x%lx, newbase 0x%lx, newlim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
(W_) genInfo.oldbase, (W_) genInfo.oldlim, (W_) genInfo.oldthresh,
(W_) genInfo.newgen[genInfo.curnew].newbase,
genInfo.oldwas = genInfo.oldlim;
genInfo.minor_since_major = 0;
- if (SM_stats_verbose) {
+ if (RTSflags.GcFlags.giveStats) {
char major_str[BIG_STRING_LEN];
#ifndef PAR
sprintf(major_str, "%6d %4ld %4u %4ld %3ld %3ld %4d %3d %3d %6.6s *Major* %4.1f%%",
0, genInfo.OldInNewno,
(SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1),
bstk_roots, sm->rootno, genInfo.NewCAFno + genInfo.OldCAFno,
- 0, 0, 0, "", total_resident / (StgFloat) SM_word_heap_size * 100);
+ 0, 0, 0, "", total_resident / (StgDouble) RTSflags.GcFlags.heapSize * 100);
#else
sprintf(major_str, "%6d %4ld %4u %4ld %3ld %3ld %4d %3d %3d %6.6s *Major* %4.1f%%",
0, genInfo.OldInNewno,
0, 0, sm->rootno, genInfo.NewCAFno + genInfo.OldCAFno,
- 0, 0, 0, "", total_resident / (StgFloat) SM_word_heap_size * 100);
+ 0, 0, 0, "", total_resident / (StgDouble) RTSflags.GcFlags.heapSize * 100);
#endif
stat_endGC(0, alloc, resident, major_str);
} else {
stat_endGC(0, alloc, resident, "");
}
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
fprintf(stderr, "GEN Major: oldbase 0x%lx, oldlim 0x%lx, oldthresh 0x%lx, newbase 0x%lx, newlim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n",
(W_) genInfo.oldbase, (W_) genInfo.oldlim, (W_) genInfo.oldthresh,
(W_) genInfo.newgen[genInfo.curnew].newbase,
\begin{code}
#define NULL_REG_MAP
#include "SMinternal.h"
-
-/* global vars to hold some storage-mgr details; */
-/* decls for these are in SMinternal.h */
-I_ SM_force_gc = 0;
-I_ SM_alloc_size = 0;
-I_ SM_alloc_min = 0;
-I_ SM_major_gen_size = 0;
-FILE *SM_statsfile = NULL;
-I_ SM_trace = 0;
-I_ SM_stats_summary = 0;
-I_ SM_stats_verbose = 0;
-I_ SM_ring_bell = 0;
-
-/*To SizeHooks: I_ SM_word_heap_size = DEFAULT_HEAP_SIZE; */
-/*To SizeHooks: StgFloat SM_pc_free_heap = DEFAULT_PC_FREE; */
-extern I_ SM_word_stk_size; /*To SizeHooks: = DEFAULT_STACKS_SIZE; */
-
-I_ MaxResidency = 0; /* in words; for stats only */
-I_ ResidencySamples = 0; /* for stats only */
-
-#ifndef atof
-extern double atof();
-/* no proto because some machines use const and some do not */
-#endif
-
-I_
-decode(s)
- char *s;
-{
- I_ c;
- StgDouble m;
- if (!*s)
- return 0;
- m = atof(s);
- c = s[strlen(s)-1];
- if (c == 'g' || c == 'G')
- m *= 1000*1000*1000; /* UNchecked! */
- else if (c == 'm' || c == 'M')
- m *= 1000*1000; /* We do not use powers of 2 (1024) */
- else if (c == 'k' || c == 'K') /* to avoid possible bad effects on */
- m *= 1000; /* a direct-mapped cache. */
- else if (c == 'w' || c == 'W')
- m *= sizeof(W_);
- return (I_)m;
-}
-
-static void
-badoption(s)
- char *s;
-{
- fflush(stdout);
- fprintf(stderr, "initSM: Bad RTS option: %s\n", s);
- EXIT(EXIT_FAILURE);
-}
-
-extern long strtol PROTO((const char *, char **, int)); /* ToDo: properly? */
-
-I_
-initSM(rts_argc, rts_argv, statsfile)
- I_ rts_argc;
- char **rts_argv;
- FILE *statsfile;
-{
- I_ arg;
-
- /* save statsfile info */
- SM_statsfile = statsfile;
-
- /* slurp through RTS args */
-
- for (arg = 0; arg < rts_argc; arg++) {
- if (rts_argv[arg][0] == '-') {
- switch(rts_argv[arg][1]) {
- case 'H':
- SM_word_heap_size = decode(rts_argv[arg]+2) / sizeof(W_);
-
- if (SM_word_heap_size <= 0) badoption( rts_argv[arg] );
- break;
-
- case 'M':
- SM_pc_free_heap = atof(rts_argv[arg]+2);
-
- if ((SM_pc_free_heap < 0) || (SM_pc_free_heap > 100))
- badoption( rts_argv[arg] );
- break;
-
- case 'A':
- SM_alloc_size = decode(rts_argv[arg]+2) / sizeof(W_);
-
- if (SM_alloc_size == 0) SM_alloc_size = DEFAULT_ALLOC_SIZE;
- break;
-
- case 'G':
- SM_major_gen_size = decode(rts_argv[arg]+2) / sizeof(W_);
- break;
-
- case 'F':
- if (strcmp(rts_argv[arg]+2, "2s") == 0) {
- SM_force_gc = USE_2s;
- } else if (strcmp(rts_argv[arg]+2, "1s") == 0) {
- badoption( rts_argv[arg] ); /* ToDo ! */
- } else {
- badoption( rts_argv[arg] );
- }
- break;
-
- case 'K':
- SM_word_stk_size = decode(rts_argv[arg]+2) / sizeof(W_);
-
- if (SM_word_stk_size == 0) badoption( rts_argv[arg] );
- break;
-
- case 'S':
- SM_stats_verbose++;
- /* statsfile has already been determined */
- break;
- case 's':
- SM_stats_summary++;
- /* statsfile has already been determined */
- break;
- case 'B':
- SM_ring_bell++;
- break;
-
- case 'T':
- if (rts_argv[arg][2] != '\0')
- SM_trace = (I_) strtol(rts_argv[arg]+2, (char **)NULL, 0);
- else
- SM_trace = 1;
- break;
-
-#ifdef GCdu
- case 'u':
- dualmodeInfo.resid_to_compact = atof(rts_argv[arg]+2);
- dualmodeInfo.resid_from_compact = dualmodeInfo.resid_from_compact + 0.05;
- if (dualmodeInfo.resid_from_compact < 0.0 ||
- dualmodeInfo.resid_to_compact > 1.0) {
- badoption( rts_argv[arg] );
- }
-#endif
-
- default:
- /* otherwise none of my business */
- break;
- }
- }
- /* else none of my business */
- }
-
- SM_alloc_min = (I_) (SM_word_heap_size * SM_pc_free_heap / 100);
-
- return(0); /* all's well */
-}
\end{code}
-
\section[storage-manager-exit]{Winding up the storage manager}
\begin{code}
-
-I_
-exitSM (sm_info)
- smInfo *sm_info;
+rtsBool
+exitSM (smInfo *sm_info)
{
stat_exit(sm_info->hp - hp_start);
- return(0); /* I'm happy */
+ return rtsTrue; /* I'm happy */
}
\end{code}
#include <sys/vadvise.h>
#endif
-extern I_ SM_force_gc;
-#define USE_2s 1
-#define USE_1s 2
-
-extern I_ SM_word_heap_size; /* all defined in SMinit.lc */
-extern I_ SM_alloc_min;
-extern StgFloat SM_pc_free_heap;
-extern I_ SM_alloc_size;
-extern I_ SM_major_gen_size;
-/*moved: extern I_ SM_word_stk_size; */
-extern FILE *SM_statsfile;
-extern I_ SM_trace;
-extern I_ SM_stats_summary;
-extern I_ SM_stats_verbose;
-extern I_ SM_ring_bell;
-
extern P_ heap_space;
extern P_ hp_start;
-extern void stat_init PROTO((char *collector, char *c1, char *c2));
-extern void stat_startGC PROTO((I_ alloc));
-extern void stat_endGC PROTO((I_ alloc, I_ collect, I_ live, char *comment));
-extern void stat_exit PROTO((I_ alloc));
+void stat_init PROTO((char *collector, char *c1, char *c2));
+void stat_startGC PROTO((I_ alloc));
+void stat_endGC PROTO((I_ alloc, I_ collect, I_ live, char *comment));
+void stat_exit PROTO((I_ alloc));
extern I_ MaxResidency; /* in words; for stats only */
extern I_ ResidencySamples; /* for stats only */
} \
} while (0)
-extern StgFunPtr _Dummy_entry(STG_NO_ARGS);
-extern char *xmalloc PROTO((size_t));
+StgFunPtr _Dummy_entry(STG_NO_ARGS);
-#if defined(_GC_DEBUG)
+#if defined(DEBUG)
#define DEBUG_SCAN(str, pos, to, topos) \
- if (SM_trace & 2) fprintf(stderr, "%s: 0x%lx, %s 0x%lx\n", str, pos, to, topos)
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
+ fprintf(stderr, "%s: 0x%lx, %s 0x%lx\n", str, pos, to, topos)
#define DEBUG_STRING(str) \
- if (SM_trace & 2) fprintf(stderr, "%s\n", str)
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
+ fprintf(stderr, "%s\n", str)
#else
#define DEBUG_SCAN(str, pos, to, topos)
#define DEBUG_STRING(str)
#endif
-/************************ Default HEAP and STACK sizes **********************/
-
-/* A user can change these main defaults with a
- "hooks" file equiv to runtime/hooks/SizeHooks.lc.
-*/
-
-#define DEFAULT_STACKS_SIZE 0x10002 /* 2^16 = 16Kwords = 64Kbytes */
-
-#define DEFAULT_HEAP_SIZE 0x100002 /* 2^20 = 1Mwords = 4Mbytes */
-#define DEFAULT_ALLOC_SIZE 0x4002 /* 2^14 = 16k words = 64k bytes */
-#define DEFAULT_PC_FREE 3 /* 3% */
-
-/* I added a couple of extra words above, to be more sure of avoiding
- bad effects on direct-mapped caches. (WDP)
-*/
-
#define NEXT_SEMI_SPACE(space) ((space + 1) % 2)
/************************ Random stuff **********************/
#define EVAC_CODE(infoptr) ((StgEvacPtr) ((P_)(INFO_RTBL(infoptr)))[COPY_INFO_OFFSET])
#define SCAV_CODE(infoptr) ((StgScavPtr) ((P_)(INFO_RTBL(infoptr)))[COPY_INFO_OFFSET+1])
-extern void Scavenge(STG_NO_ARGS);
-extern void _Scavenge_Forward_Ref(STG_NO_ARGS);
+void Scavenge(STG_NO_ARGS);
+void _Scavenge_Forward_Ref(STG_NO_ARGS);
/* Note: any change to FORWARD_ADDRESS should be
reflected in layout of MallocPtrs (includes/SMClosures.lh)
const W_ MK_REP_LBL(,evac_forward,)[] = { \
INCLUDE_TYPE_INFO(INTERNAL) \
INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
+ INCLUDE_PAR_INFO \
INCLUDE_COPYING_INFO(evac_forward,_Scavenge_Forward_Ref)\
INCLUDE_COMPACTING_INFO(INFO_UNUSED,INFO_UNUSED,INFO_UNUSED,INFO_UNUSED) \
}
const W_ MK_REP_LBL(Caf_Evac_Upd,,)[] = { \
INCLUDE_TYPE_INFO(INTERNAL) \
INCLUDE_SIZE_INFO(MIN_UPD_SIZE,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
+ INCLUDE_PAR_INFO \
INCLUDE_COPYING_INFO(_Evacuate_Caf_Evac_Upd,_Scavenge_Caf) \
INCLUDE_COMPACTING_INFO(INFO_UNUSED,INFO_UNUSED,INFO_UNUSED,INFO_UNUSED) \
}
#if defined(_INFO_MARKING)
-extern I_ markHeapRoots PROTO((smInfo *sm, P_ cafs1, P_ cafs2,
- P_ base, P_ lim, BitWord *bit_array));
+I_ markHeapRoots PROTO((smInfo *sm, P_ cafs1, P_ cafs2,
+ P_ base, P_ lim, BitWord *bit_array));
#define PRMARK_CODE(infoptr) \
(((FP_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+1])
MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextRoot,)
MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextCAF,)
-#define DUMMY_PRRETURN_RTBL(prreturn_code,dummy_code) \
- const W_ MK_REP_LBL(,prreturn_code,)[] = { \
- INCLUDE_TYPE_INFO(INTERNAL) \
- INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
- INCLUDE_PAR_INFO \
- INCLUDE_COPYING_INFO(dummy_code,dummy_code) \
+#define DUMMY_PRRETURN_RTBL(prreturn_code,dummy_code) \
+ const W_ MK_REP_LBL(,prreturn_code,)[] = { \
+ INCLUDE_TYPE_INFO(INTERNAL) \
+ INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \
+ INCLUDE_PAR_INFO \
+ INCLUDE_COPYING_INFO(dummy_code,dummy_code) \
INCLUDE_COMPACTING_INFO(dummy_code,dummy_code,dummy_code,prreturn_code) \
}
#endif /* ! GCgn */
-#if defined(_GC_DEBUG)
+#if defined(DEBUG)
#if defined(GCgn)
#define DEBUG_LINK_LOCATION(location, closure, linklim) \
- if (SM_trace & 4) { \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MAJOR_GC) { \
if (DYNAMIC_CLOSURE(closure) && (closure <= linklim)) \
fprintf(stderr, " Link Loc: 0x%lx to 0x%lx\n", location, closure); \
else if (! DYNAMIC_CLOSURE(closure)) \
}
#else /* ! GCgn */
#define DEBUG_LINK_LOCATION(location, closure) \
- if (SM_trace & 4) { \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MAJOR_GC) { \
if (DYNAMIC_CLOSURE(closure)) \
fprintf(stderr, " Link Loc: 0x%lx to 0x%lx\n", location, closure); \
else \
#endif /* ! GCgn */
#define DEBUG_UNLINK_LOCATION(location, closure, newlocation) \
- if (SM_trace & 4) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MAJOR_GC) \
fprintf(stderr, " UnLink Loc: 0x%lx, 0x%lx -> 0x%lx\n", location, closure, newlocation)
#define DEBUG_LINK_CAF(caf) \
- if (SM_trace & 4) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MAJOR_GC) \
fprintf(stderr, "Caf: 0x%lx Closure: 0x%lx\n", caf, IND_CLOSURE_PTR(caf))
#define DEBUG_SET_MARK(closure, hp_word) \
- if (SM_trace & 8) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
fprintf(stderr, " Set Mark Bit: 0x%lx, word %ld, bit_word %ld, bit %d\n", closure, hp_word, hp_word / BITS_IN(BitWord), hp_word & (BITS_IN(BitWord) - 1))
#else
{
FUNBEGIN;
DEBUG_PR_IND;
+ GC_SHORT_IND(); /* ticky: record that we shorted an indirection */
+
Mark = (P_) IND_CLOSURE_PTR(Mark);
JUMP_MARK;
FUNEND;
``Permanent indirection''---used in profiling. Works basically
like @_PRStart_1@ (one pointer).
\begin{code}
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING) || defined(TICKY_TICKY)
+
STGFUN(_PRStart_PI)
{
FUNBEGIN;
-/* This test would be here if it really was like a PRStart_1.
- But maybe it is not needed because a PI cannot have two
- things pointing at it (so no need to mark it), because
- they are only created in exactly one place in UpdatePAP.
- ??? WDP 95/07
if (IS_MARK_BIT_SET(Mark)) {
DEBUG_PR_MARKED;
JUMP_MARK_RETURN;
} else {
-*/
INIT_MARK_NODE("PI ",1);
/* the "1" above is dodgy (i.e. wrong), but it is never
used except in debugging info. ToDo??? WDP 95/07
*/
INIT_MSTACK(PERM_IND_CLOSURE_PTR);
-/* } */
+ }
FUNEND;
}
+
STGFUN(_PRIn_PI)
{
FUNBEGIN;
*/
FUNEND;
}
-#endif
+
+#endif /* PROFILING or TICKY */
\end{code}
Marking a ``selector closure'': This is a size-2 SPEC thunk that
or ``on the way back up'' (\tr{_PRIn_Selector})?} Answer: probably on
the way down. Downside: we are flummoxed by indirections, so we'll
have to wait until the {\em next} major GC to do the selections (after
-the indirections are sorted out in this GC). But the downside of
+the indirections are shorted out in this GC). But the downside of
doing selections on the way back up is that we are then in a world of
reversed pointers, and selecting a reversed pointer---we've see this
on selectors for very recursive structures---is a total disaster.
(WDP 94/12)
\begin{code}
-#if defined(_GC_DEBUG)
+#if defined(DEBUG)
#define IF_GC_DEBUG(x) x
#else
#define IF_GC_DEBUG(x) /*nothing*/
#endif
-/* _PRStartSelector_<n> is a (very) glorified _PRStart_1 */
+#if !defined(CONCURRENT)
+# define NOT_BLACKHOLING (! RTSflags.GcFlags.lazyBlackHoling)
+#else
+# define NOT_BLACKHOLING 0
+#endif
-#if 0
-/* testing */
-#define MARK_SELECTOR(n) \
-STGFUN(CAT2(_PRStartSelector_,n)) \
-{ \
- P_ maybe_con; \
- FUNBEGIN; \
- \
- /* must be a SPEC 2 1 closure */ \
- ASSERT(INFO_SIZE(INFO_PTR(Mark)) == 2); \
- ASSERT(INFO_NoPTRS(INFO_PTR(Mark)) == 1); \
- ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */ \
- \
- JMP_(_PRStart_1); \
- \
- FUNEND; \
-}
-#endif /* 0 */
+/* _PRStartSelector_<n> is a (very) glorified _PRStart_1 */
#define MARK_SELECTOR(n) \
STGFUN(CAT2(_PRStartSelector_,n)) \
maybe_con = (P_) *(Mark + _FHS); \
\
IF_GC_DEBUG( \
- if (SM_trace & 2) { \
- fprintf(stderr, "Start Selector %d: 0x%lx, info 0x%lx, size %ld, ptrs %ld, maybe_con 0x%lx, marked? 0x%%lx, info 0x%lx", \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) { \
+ fprintf(stderr, "Start Selector %d: 0x%lx, info 0x%lx, size %ld, ptrs %ld, maybe_con 0x%lx, info 0x%lx", \
(n), Mark, INFO_PTR(Mark), INFO_SIZE(INFO_PTR(Mark)), \
INFO_NoPTRS(INFO_PTR(Mark)), \
maybe_con, /*danger:IS_MARK_BIT_SET(maybe_con),*/ \
INFO_SIZE(INFO_PTR(maybe_con)), \
INFO_NoPTRS(INFO_PTR(maybe_con))); \
if (INFO_TAG(INFO_PTR(maybe_con)) >=0) { \
- /* int i; */ \
- /* for (i = 0; i < INFO_SIZE(INFO_PTR(maybe_con)); i++) { */ \
- /* fprintf(stderr, ", 0x%lx", maybe_con[_FHS + i]); */ \
- /*}*/ \
fprintf(stderr, "=> 0x%lx", maybe_con[_FHS + (n)]); \
} \
fprintf(stderr, "\n"); \
\
if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */\
|| IS_MARK_BIT_SET(maybe_con) /* been here: may be mangled */ \
- || INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */ \
+ || INFO_TAG(INFO_PTR(maybe_con)) < 0 /* not in WHNF */ \
+ || NOT_BLACKHOLING /* see "price of laziness" paper */ \
+ || (! RTSflags.GcFlags.doSelectorsAtGC )) \
/* see below for OLD test we used here (WDP 95/04) */ \
/* ToDo: decide WHNFness another way? */ \
JMP_(_PRStart_1); \
/* ASSERT((n) < INFO_SIZE(INFO_PTR(maybe_con))); not true if static */ \
\
/* OK, it is evaluated: behave just like an indirection */ \
+ GC_SEL_MAJOR(); /* ticky-ticky */ \
\
Mark = (P_) (maybe_con[_FHS + (n)]); \
/* Mark now has the result of the selection */ \
{
FUNBEGIN;
DEBUG_PR_CONST;
+
+#ifndef TICKY_TICKY
+ /* normal stuff */
Mark = (P_) CONST_STATIC_CLOSURE(INFO_PTR(Mark));
+
+#else /* TICKY */
+ if (IS_MARK_BIT_SET(Mark)) {
+ DEBUG_PR_MARKED;
+ } else {
+ if (!AllFlags.doUpdEntryCounts) {
+
+ GC_COMMON_CONST(); /* ticky */
+
+ Mark = (P_) CONST_STATIC_CLOSURE(INFO_PTR(Mark));
+
+ } else { /* no commoning */
+ INIT_MARK_NODE("CONST ",0);
+ }
+ }
+#endif /* TICKY */
+
JUMP_MARK_RETURN;
FUNEND;
}
\begin{code}
STGFUN(_PRStart_CharLike)
{
+ I_ val;
+
FUNBEGIN;
+
DEBUG_PR_CHARLIKE;
+
+#ifndef TICKY_TICKY
+ /* normal stuff */
+
Mark = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(Mark));
+
+#else /* TICKY */
+
+ if (IS_MARK_BIT_SET(Mark)) {
+ DEBUG_PR_MARKED;
+ } else {
+ val = CHARLIKE_VALUE(Mark);
+
+ if (!AllFlags.doUpdEntryCounts) {
+ GC_COMMON_CHARLIKE(); /* ticky */
+
+ INFO_PTR(Mark) = (W_) Ind_info;
+ IND_CLOSURE_PTR(Mark) = (W_) CHARLIKE_CLOSURE(val);
+ Mark = (P_) IND_CLOSURE_PTR(Mark);
+
+ } else { /* no commoning */
+ INIT_MARK_NODE("CHAR ",0);
+ }
+ }
+#endif /* TICKY */
+
JUMP_MARK_RETURN;
FUNEND;
}
if (IS_MARK_BIT_SET(Mark)) {
DEBUG_PR_MARKED;
} else {
- val = INTLIKE_VALUE(Mark);
+ val = INTLIKE_VALUE(Mark);
+
+ if (val >= MIN_INTLIKE
+ && val <= MAX_INTLIKE
+#ifdef TICKY_TICKY
+ && !AllFlags.doUpdEntryCounts
+#endif
+ ) {
+ DEBUG_PR_INTLIKE_TO_STATIC;
+ GC_COMMON_INTLIKE(); /* ticky */
- if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) {
- DEBUG_PR_INTLIKE_TO_STATIC;
INFO_PTR(Mark) = (W_) Ind_info;
IND_CLOSURE_PTR(Mark) = (W_) INTLIKE_CLOSURE(val);
Mark = (P_) IND_CLOSURE_PTR(Mark);
- } else {
- /* out of range of static closures */
- DEBUG_PR_INTLIKE_IN_HEAP;
+
+ } else { /* out of range of static closures */
+ DEBUG_PR_INTLIKE_IN_HEAP;
+#ifdef TICKY_TICKY
+ if (!AllFlags.doUpdEntryCounts) GC_COMMON_INTLIKE_FAIL();
+#endif
INIT_MARK_NODE("INT ",0);
- }
+ }
}
JUMP_MARK_RETURN;
FUNEND;
}
\end{code}
-CHANGE THIS FOR THE @COMMON_ITBLS@ WORLD!
-
-\begin{code}
-#if defined(GCgn)
-
-/* Marking an OldGen root -- treat as indirection if it references the old generation */
-
-STGFUN(_PRStart_OldRoot)
-{
- P_ oldroot;
-
- FUNBEGIN;
- oldroot = (P_) IND_CLOSURE_PTR(Mark);
-
- if (oldroot <= HeapLim) /* does the root reference the old generation ? */
- {
- DEBUG_PR_OLDIND;
- Mark = oldroot; /* short circut if the old generation root */
- JUMP_MARK; /* references an old generation closure */
- }
-
- else
- {
- INIT_MARK_NODE("OldRoot",1); /* oldroot to new generation */
- INIT_MSTACK(SPEC_CLOSURE_PTR); /* treat as _PRStart_1 */
- }
- FUNEND;
-}
-
-#endif /* GCgn */
-
-\end{code}
-
Special error routine, used for closures which should never call their
``in'' code.
I_ cts_size;
FUNBEGIN;
+
+ /* ToDo: ASSERT(sanityChk_StkO(Mark)); ??? */
+
if (IS_MARK_BIT_SET(Mark)) {
DEBUG_PR_MARKED;
JUMP_MARK_RETURN;
%
%****************************************************************************
-A CAF is shorted out as if it is an indirection.
+A CAF is shorted out as if it were an indirection.
The CAF reference is explicitly updated by the garbage collector.
\begin{code}
{
FUNBEGIN;
DEBUG_PR_CAF;
- Mark = (P_) IND_CLOSURE_PTR(Mark);
- JUMP_MARK;
- FUNEND;
-}
-
-#if 0 /* Code to avoid explicit updating of CAF references */
- /* We need auxiliary mark and update reference info table */
-
-CAF_MARK_UPD_ITBL(Caf_Mark_Upd_info,const);
-
-/* Start marking a CAF -- special mark upd info table */
-/* Change to marking state and mark reference */
-
-STGFUN(_PRStart_Caf)
-{
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKED;
- JUMP_MARK_RETURN;
- } else {
- INIT_MARK_NODE("CAF ",1);
- INIT_MSTACK(IND_CLOSURE_PTR2);
- }
- FUNEND;
-}
+ GC_SHORT_CAF(); /* ticky */
-/* Completed marking a CAF -- special mark upd info table */
-/* Change info table back to normal CAF info, return reference (Mark) */
-
-STGFUN(_PRInLast_Caf)
-{
- P_ temp;
-
- FUNBEGIN;
- DEBUG_PRLAST_CAF;
- SET_INFO_PTR(MStack, Caf_info); /* normal marked CAF */
-
- /* Like POP_MSTACK */
- temp = MStack;
- MStack = (P_) IND_CLOSURE_PTR(temp);
- IND_CLOSURE_PTR(temp) = (W_) Mark;
-
- /* Mark left unmodified so CAF reference is returned */
- JUMP_MARK_RETURN;
- FUNEND;
-}
-
-/* Marking a CAF currently being marked -- special mark upd info table */
-/* Just return CAF as if marked -- wont be shorted out */
-/* Marking once reference marked and updated -- normal CAF info table */
-/* Return reference to short CAF out */
-
-STGFUN(_PRStart_Caf)
-{
- FUNBEGIN;
- if (IS_MARK_BIT_SET(Mark)) {
- DEBUG_PR_MARKING_CAF;
- JUMP_MARK_RETURN;
- } else {
- DEBUG_PR_MARKED_CAF;
Mark = (P_) IND_CLOSURE_PTR(Mark);
- JUMP_MARK_RETURN;
- }
+ JUMP_MARK;
FUNEND;
}
-
-#define DEBUG_PR_MARKED_CAF \
- if (SM_trace & 8) \
- fprintf(stderr, "PRMark CAF (Marked): 0x%lx -> 0x%lx, info 0x%lx\n", \
- Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark))
-
-#define DEBUG_PR_MARKING_CAF \
- if (SM_trace & 8) \
- fprintf(stderr, "PRMark CAF (Marking): 0x%lx -> 0x%lx, info 0x%lx\n", \
- Mark, Mark, INFO_PTR(Mark))
-
-#define DEBUG_PRLAST_CAF \
- if (SM_trace & 8) \
- fprintf(stderr, "PRRet Last (CAF ): 0x%lx -> 0x%lx, info 0x%lx -> 0x%lx ptrs 1\n", \
- MStack, Mark, INFO_PTR(MStack), Caf_info)
-
-#endif /* 0 */
-
\end{code}
%****************************************************************************
FUNBEGIN;
fprintf(stderr,"Called _Dummy_PRReturn_entry\nShould never occur!\n");
abort();
- return(0); /* won't happen; quiets compiler warnings */
FUNEND;
}
+/* various ways to call _Dummy_PRReturn_entry: */
+
+INTFUN(_PRMarking_MarkNextRoot_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
+#ifdef CONCURRENT
+INTFUN(_PRMarking_MarkNextSpark_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
+#endif
+#ifdef PAR
+INTFUN(_PRMarking_MarkNextGA_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
+#endif
+INTFUN(_PRMarking_MarkNextAStack_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
+INTFUN(_PRMarking_MarkNextBStack_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
+INTFUN(_PRMarking_MarkNextCAF_entry) { FB_; JMP_(_Dummy_PRReturn_entry); FE_; }
+
+/* end of various ways to call _Dummy_PRReturn_entry */
+
EXTFUN(_PRMarking_MarkNextRoot);
EXTFUN(_PRMarking_MarkNextCAF);
DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextRoot_closure,
_PRMarking_MarkNextRoot_info,
_PRMarking_MarkNextRoot,
- _Dummy_PRReturn_entry);
+ _PRMarking_MarkNextRoot_entry);
#ifdef CONCURRENT
DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextSpark_closure,
_PRMarking_MarkNextSpark_info,
_PRMarking_MarkNextSpark,
- _Dummy_PRReturn_entry);
+ _PRMarking_MarkNextSpark_entry);
#endif
#ifdef PAR
DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextGA_closure,
_PRMarking_MarkNextGA_info,
_PRMarking_MarkNextGA,
- _Dummy_PRReturn_entry);
+ _PRMarking_MarkNextGA_entry);
#else
DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextAStack_closure,
_PRMarking_MarkNextAStack_info,
_PRMarking_MarkNextAStack,
- _Dummy_PRReturn_entry);
+ _PRMarking_MarkNextAStack_entry);
DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextBStack_closure,
_PRMarking_MarkNextBStack_info,
_PRMarking_MarkNextBStack,
- _Dummy_PRReturn_entry);
+ _PRMarking_MarkNextBStack_entry);
#endif /* PAR */
DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextCAF_closure,
_PRMarking_MarkNextCAF_info,
_PRMarking_MarkNextCAF,
- _Dummy_PRReturn_entry);
+ _PRMarking_MarkNextCAF_entry);
+
+extern P_ sm_roots_end; /* &roots[rootno] -- one beyond the end */
STGFUN(_PRMarking_MarkNextRoot)
{
- extern P_ sm_roots_end; /* &roots[rootno] -- one beyond the end */
-
FUNBEGIN;
/* Update root -- may have short circuited Ind */
*MRoot = (W_) Mark;
}
#ifdef CONCURRENT
+extern P_ sm_roots_end; /* PendingSparksTl[pool] */
+
STGFUN(_PRMarking_MarkNextSpark)
{
- extern P_ sm_roots_end; /* PendingSparksTl[pool] */
-
FUNBEGIN;
/* Update root -- may have short circuited Ind */
*MRoot = (W_) Mark;
STGFUN(_PRMarking_MarkNextCAF)
{
FUNBEGIN;
- /* Update root -- may have short circuted Ind */
+
+ /* Update root -- may have short circuited Ind */
IND_CLOSURE_PTR(MRoot) = (W_) Mark;
MRoot = (P_) IND_CLOSURE_LINK(MRoot);
if (MRoot == 0)
RESUME_(miniInterpretEnd);
- Mark = (P_) IND_CLOSURE_PTR(MRoot);
- JUMP_MARK;
- FUNEND;
-}
-\end{code}
-
-\begin{code}
-#if 0 /* Code to avoid explicit updating of CAF references */
+ GC_SHORT_CAF(); /* ticky (ToDo: wrong?) */
-STGFUN(_PRMarking_MarkNextCAF)
-{
- FUNBEGIN;
- MRoot = (P_) IND_CLOSURE_LINK(MRoot);
-
- /* Is the next CAF the end of the list */
- if (MRoot == 0)
- RESUME_(miniInterpretEnd);
-
- Mark = MRoot;
+ Mark = (P_) IND_CLOSURE_PTR(MRoot);
JUMP_MARK;
FUNEND;
}
-#endif /* 0 */
\end{code}
Multi-slurp protection.
Define some debugging macros.
\begin{code}
-#if defined(_GC_DEBUG)
+#if defined(DEBUG)
#define DEBUG_PRSTART(type, ptrsvar) \
- if (SM_trace & 8) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
fprintf(stderr, "PRMark Start (%s): 0x%lx, info 0x%lx ptrs %ld\n", \
type, Mark, INFO_PTR(Mark), ptrsvar)
#define DEBUG_PRIN(type, posvar) \
- if (SM_trace & 8) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
fprintf(stderr, "PRRet In (%s): 0x%lx, info 0x%lx pos %ld\n", \
type, MStack, INFO_PTR(MStack), posvar)
#define DEBUG_PRLAST(type, ptrvar) \
- if (SM_trace & 8) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
fprintf(stderr, "PRRet Last (%s): 0x%lx, info 0x%lx ptrs %ld\n", \
type, MStack, INFO_PTR(MStack), ptrvar)
#define DEBUG_PR_MARKED \
- if (SM_trace & 8) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
fprintf(stderr, "PRMark Marked : 0x%lx, info 0x%lx\n", \
Mark, INFO_PTR(Mark))
#define DEBUG_PR_STAT \
- if (SM_trace & 8) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
fprintf(stderr, "PRMark Static : 0x%lx, info 0x%lx\n", \
Mark, INFO_PTR(Mark))
#define DEBUG_PR_IND \
- if (SM_trace & 8) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
fprintf(stderr, "PRMark Ind : 0x%lx -> PRMark(0x%lx), info 0x%lx\n", \
Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark))
#define DEBUG_PR_CAF \
- if (SM_trace & 8) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
fprintf(stderr, "PRMark Caf : 0x%lx -> PRMark(0x%lx), info 0x%lx\n", \
Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark))
#define DEBUG_PR_CONST \
- if (SM_trace & 8) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
fprintf(stderr, "PRMark Const : 0x%lx -> 0x%lx, info 0x%lx\n", \
Mark, CONST_STATIC_CLOSURE(INFO_PTR(Mark)), INFO_PTR(Mark))
#define DEBUG_PR_CHARLIKE \
- if (SM_trace & 8) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
fprintf(stderr, "PRMark CharLike (%lx) : 0x%lx -> 0x%lx, info 0x%lx\n", \
CHARLIKE_VALUE(Mark), Mark, CHARLIKE_CLOSURE(CHARLIKE_VALUE(Mark)), INFO_PTR(Mark))
#define DEBUG_PR_INTLIKE_TO_STATIC \
- if (SM_trace & 8) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
fprintf(stderr, "PRMark IntLike to Static (%ld) : 0x%lx -> 0x%lx, info 0x%lx\n", \
INTLIKE_VALUE(Mark), Mark, INTLIKE_CLOSURE(INTLIKE_VALUE(Mark)), INFO_PTR(Mark))
#define DEBUG_PR_INTLIKE_IN_HEAP \
- if (SM_trace & 8) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
fprintf(stderr, "PRMark IntLike in Heap (%ld) : 0x%lx, info 0x%lx\n", \
INTLIKE_VALUE(Mark), Mark, INFO_PTR(Mark))
#define DEBUG_PR_OLDIND \
- if (SM_trace & 8) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MARKING) \
fprintf(stderr, "PRMark OldRoot Ind : 0x%lx -> PRMark(0x%lx), info 0x%lx\n", \
Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark))
#define MARK_REG_MAP
#include "SMinternal.h"
-extern I_ doSanityChks; /* ToDo: move tidily */
-
#if defined(_INFO_MARKING)
#if defined (__STG_GCC_REGS__) /* If we are using registers load _SAVE */
int pool;
#endif
-#if 0 /* Code to avoid explicit updating of CAF references */
-
- /* Before marking have to modify CAFs to auxillary info table */
- P_ CAFptr;
- DEBUG_STRING("Setting Mark & Upd CAFs:");
- for (CAFptr = cafs1; CAFptr;
- CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
- INFO_PTR(CAFptr) = (W_) Caf_Mark_Upd_info;
- }
- for (CAFptr = cafs2; CAFptr;
- CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) {
- INFO_PTR(CAFptr) = (W_) Caf_Mark_Upd_info;
- }
- DEBUG_STRING("Marking CAFs:");
- if (cafs1) {
- MRoot = (P_) cafs1;
- Mark = (P_) MRoot;
- MStack = (P_) _PRMarking_MarkNextCAF_closure;
- /*ToDo: debugify */
- miniInterpret((StgFunPtr)_startMarkWorld);
- }
- if (cafs2) {
- MRoot = (P_) cafs2;
- Mark = (P_) MRoot;
- MStack = (P_) _PRMarking_MarkNextCAF_closure;
- /*ToDo: debugify */
- miniInterpret((StgFunPtr)_startMarkWorld);
- }
-
-#endif /* 0 */
-
BitArray = bit_array;
HeapBase = base;
HeapLim = lim;
MRoot = (P_) sm->roots;
Mark = (P_) *MRoot;
MStack = (P_) _PRMarking_MarkNextRoot_closure;
-#if defined(__STG_TAILJUMPS__)
- miniInterpret((StgFunPtr)_startMarkWorld);
-#else
- if (doSanityChks)
- miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL);
- else
+
miniInterpret((StgFunPtr)_startMarkWorld);
-#endif /* ! tail-jumping */
}
#ifdef CONCURRENT
MRoot = (P_) PendingSparksHd[pool];
Mark = (P_) *MRoot;
MStack = (P_) _PRMarking_MarkNextSpark_closure;
-#if defined(__STG_TAILJUMPS__)
- miniInterpret((StgFunPtr)_startMarkWorld);
-#else
- if (doSanityChks)
- miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL);
- else
+
miniInterpret((StgFunPtr)_startMarkWorld);
-#endif /* ! tail-jumping */
}
}
#endif
if (MRoot != NULL) {
Mark = ((GALA *)MRoot)->la;
MStack = (P_) _PRMarking_MarkNextGA_closure;
-#if defined(__STG_TAILJUMPS__)
+
miniInterpret((StgFunPtr) _startMarkWorld);
-#else
- if (doSanityChks)
- miniInterpret_debug((StgFunPtr) _startMarkWorld, NULL);
- else
- miniInterpret((StgFunPtr) _startMarkWorld);
-#endif /* ! tail-jumping */
}
#else
/* Note: no *external* stacks in parallel world */
MRoot = (P_) MAIN_SpA;
Mark = (P_) *MRoot;
MStack = (P_) _PRMarking_MarkNextAStack_closure;
-#if defined(__STG_TAILJUMPS__)
- miniInterpret((StgFunPtr)_startMarkWorld);
-#else
- if (doSanityChks)
- miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL);
- else
+
miniInterpret((StgFunPtr)_startMarkWorld);
-#endif /* ! tail-jumping */
}
DEBUG_STRING("Marking B Stack:");
DEBUG_STRING("Marking & Updating CAFs:");
if (cafs1) {
- MRoot = cafs1;
- Mark = (P_) IND_CLOSURE_PTR(MRoot);
+ MRoot = cafs1;
+ Mark = (P_) IND_CLOSURE_PTR(MRoot);
MStack = (P_) _PRMarking_MarkNextCAF_closure;
-#if defined(__STG_TAILJUMPS__)
- miniInterpret((StgFunPtr)_startMarkWorld);
-#else
- if (doSanityChks)
- miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL);
- else
+
miniInterpret((StgFunPtr)_startMarkWorld);
-#endif /* ! tail-jumping */
}
if (cafs2) {
- MRoot = cafs2;
- Mark = (P_) IND_CLOSURE_PTR(MRoot);
+ MRoot = cafs2;
+ Mark = (P_) IND_CLOSURE_PTR(MRoot);
MStack = (P_) _PRMarking_MarkNextCAF_closure;
-#if defined(__STG_TAILJUMPS__)
- miniInterpret((StgFunPtr)_startMarkWorld);
-#else
- if (doSanityChks)
- miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL);
- else
+
miniInterpret((StgFunPtr)_startMarkWorld);
-#endif /* ! tail-jumping */
}
+
return 0;
}
#endif /* _INFO_MARKING */
-
\end{code}
#endif
{
BitWord *bit_array_ptr, *bit_array_end;
- P_ scan_w_start, info; I_ size;
+ P_ scan_w_start, info;
+ I_ size;
LinkLim = lim; /* Only checked for generational collection */
info = next;
}
INFO_PTR(Scan) = (W_) info;
-/*
-if (SM_trace & 8) {
- fprintf(stderr, " Marked: word %ld, val 0x%lx, cur 0x%lx, Scan_w 0x%lx, Scan 0x%lx, Info 0x%lx, Code 0x%lx\n",
- (bit_array_ptr-1) - bit_array, *(bit_array_ptr-1), w, scan_w_start, Scan, info,
- SCAN_LINK_CODE(info)); };
-*/
size = (*SCAN_LINK_CODE(info))();
w >>= 1;
} else { /* Bit Set -- Enter ScanMove for closure*/
-/*HACK if (SM_trace&8) {fprintf(stderr,"Scan=%x\n",Scan);} */
info = (P_) INFO_PTR(Scan);
-/*HACK if (SM_trace&8) {fprintf(stderr,"info=%x\n",info);} */
while (MARKED_LOCATION(info)) {
P_ next;
info = UNMARK_LOCATION(info);
next = (P_) *info;
-/*HACK if (SM_trace&8) {fprintf(stderr,"next=%x\n",next);} */
DEBUG_UNLINK_LOCATION(info, Scan, New);
-/*HACK if (SM_trace&8) {fprintf(stderr,"New=%x\n",New);} */
*info = (W_) New;
info = next;
-/*HACK if (SM_trace&8) {fprintf(stderr,"*info=%x,info=%x\n",*info,info);} */
}
-/*HACK if (SM_trace&8) {fprintf(stderr,"preNew info=%x\n",info);} */
INFO_PTR(New) = (W_) info;
-/*
-if (SM_trace & 8) {
- fprintf(stderr, " Marked: word %ld, cur 0x%lx, Scan_w 0x%lx, Scan 0x%lx, Info 0x%lx, Code 0x%lx\n",
- (bit_array_ptr-1) - bit_array, w, scan_w_start, Scan, info, SCAN_MOVE_CODE(info)); };
-*/
-
size = (*SCAN_MOVE_CODE(info))();
New += size; /* set New address of next closure */
Scan += size; /* skip size bits */
#endif
-#if defined(_GC_DEBUG)
+#if defined(DEBUG)
#define DEBUG_SCAN_LINK(type, sizevar, ptrvar) \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Scan Link (%s): 0x%lx -> 0x%lx, info 0x%lx, size %ld, ptrs %ld\n", \
type, Scan, New, INFO_PTR(Scan), sizevar, ptrvar)
#define DEBUG_SCAN_MOVE(type, sizevar) \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Scan Move (%s): 0x%lx -> 0x%lx, info 0x%lx, size %ld\n", \
type, Scan, New, INFO_PTR(New), sizevar)
/*** LINKING CLOSURES ***/
+#ifdef TICKY_TICKY
I_
-_ScanLink_1_0(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 1, 0);
- return(FIXED_HS + 1); /* SPEC_VHS is defined to be 0, so "size" really is 1 */
+_ScanLink_0_0(STG_NO_ARGS) {
+ I_ size = 0; /* NB: SPEC_VHS is *defined* to be zero */
+ DEBUG_SCAN_LINK("SPEC", size, 0);
+ return(FIXED_HS + size);
}
+#endif
+
I_
-_ScanLink_2_0(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 2, 0);
- return(FIXED_HS + 2);
+_ScanLink_1_0(STG_NO_ARGS) {
+ I_ size = 1; /* NB: SPEC_VHS is *defined* to be zero */
+ DEBUG_SCAN_LINK("SPEC", size, 0);
+ return(FIXED_HS + size);
}
I_
-_ScanLink_3_0(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 3, 0);
- return(FIXED_HS + 3);
+_ScanLink_1_1(STG_NO_ARGS) {
+ I_ size = 1;
+ DEBUG_SCAN_LINK("SPEC", size, 1);
+ SPEC_LINK_LOCATION(1);
+ return(FIXED_HS + size);
}
I_
-_ScanLink_4_0(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 4, 0);
- return(FIXED_HS + 4);
+_ScanLink_2_0(STG_NO_ARGS) {
+ I_ size = 2;
+ DEBUG_SCAN_LINK("SPEC", size, 0);
+ return(FIXED_HS + size);
}
I_
-_ScanLink_5_0(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 5, 0);
- return(FIXED_HS + 5);
-}
-
-I_
_ScanLink_2_1(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 2, 1);
+ I_ size = 2;
+ DEBUG_SCAN_LINK("SPEC", size, 1);
SPEC_LINK_LOCATION(1);
- return(FIXED_HS + 2);
+ return(FIXED_HS + size);
}
I_
-_ScanLink_3_1(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 3, 1);
+_ScanLink_2_2(STG_NO_ARGS) {
+ I_ size = 2;
+ DEBUG_SCAN_LINK("SPEC", size, 2);
SPEC_LINK_LOCATION(1);
- return(FIXED_HS + 3);
+ SPEC_LINK_LOCATION(2);
+ return(FIXED_HS + size);
}
I_
-_ScanLink_3_2(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 3, 2);
- SPEC_LINK_LOCATION(1);
- SPEC_LINK_LOCATION(2);
- return(FIXED_HS + 3);
+_ScanLink_3_0(STG_NO_ARGS) {
+ I_ size = 3;
+ DEBUG_SCAN_LINK("SPEC", size, 0);
+ return(FIXED_HS + size);
}
-
I_
-_ScanLink_1_1(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 1, 1);
+_ScanLink_3_1(STG_NO_ARGS) {
+ I_ size = 3;
+ DEBUG_SCAN_LINK("SPEC", size, 1);
SPEC_LINK_LOCATION(1);
- return(FIXED_HS + 1);
+ return(FIXED_HS + size);
}
I_
-_ScanLink_2_2(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 2, 2);
+_ScanLink_3_2(STG_NO_ARGS) {
+ I_ size = 3;
+ DEBUG_SCAN_LINK("SPEC", size, 2);
SPEC_LINK_LOCATION(1);
SPEC_LINK_LOCATION(2);
- return(FIXED_HS + 2);
+ return(FIXED_HS + size);
}
I_
_ScanLink_3_3(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 3, 3);
+ I_ size = 3;
+ DEBUG_SCAN_LINK("SPEC", size, 3);
SPEC_LINK_LOCATION(1);
SPEC_LINK_LOCATION(2);
SPEC_LINK_LOCATION(3);
- return(FIXED_HS + 3);
+ return(FIXED_HS + size);
+}
+I_
+_ScanLink_4_0(STG_NO_ARGS) {
+ I_ size = 4;
+ DEBUG_SCAN_LINK("SPEC", size, 0);
+ return(FIXED_HS + size);
}
I_
_ScanLink_4_4(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 4, 4);
+ I_ size = 4;
+ DEBUG_SCAN_LINK("SPEC", size, 4);
SPEC_LINK_LOCATION(1);
SPEC_LINK_LOCATION(2);
SPEC_LINK_LOCATION(3);
SPEC_LINK_LOCATION(4);
- return(FIXED_HS + 4);
+ return(FIXED_HS + size);
+}
+I_
+_ScanLink_5_0(STG_NO_ARGS) {
+ I_ size = 5;
+ DEBUG_SCAN_LINK("SPEC", size, 0);
+ return(FIXED_HS + size);
}
I_
_ScanLink_5_5(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 5, 5);
+ I_ size = 5;
+ DEBUG_SCAN_LINK("SPEC", size, 5);
SPEC_LINK_LOCATION(1);
SPEC_LINK_LOCATION(2);
SPEC_LINK_LOCATION(3);
SPEC_LINK_LOCATION(4);
SPEC_LINK_LOCATION(5);
- return(FIXED_HS + 5);
+ return(FIXED_HS + size);
}
I_
_ScanLink_6_6(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 6, 6);
+ I_ size = 6;
+ DEBUG_SCAN_LINK("SPEC", size, 6);
SPEC_LINK_LOCATION(1);
SPEC_LINK_LOCATION(2);
SPEC_LINK_LOCATION(3);
SPEC_LINK_LOCATION(4);
SPEC_LINK_LOCATION(5);
SPEC_LINK_LOCATION(6);
- return(FIXED_HS + 6);
+ return(FIXED_HS + size);
}
I_
_ScanLink_7_7(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 7, 7);
+ I_ size = 7;
+ DEBUG_SCAN_LINK("SPEC", size, 7);
SPEC_LINK_LOCATION(1);
SPEC_LINK_LOCATION(2);
SPEC_LINK_LOCATION(3);
SPEC_LINK_LOCATION(5);
SPEC_LINK_LOCATION(6);
SPEC_LINK_LOCATION(7);
- return(FIXED_HS + 7);
+ return(FIXED_HS + size);
}
I_
_ScanLink_8_8(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 8, 8);
+ I_ size = 8;
+ DEBUG_SCAN_LINK("SPEC", size, 8);
SPEC_LINK_LOCATION(1);
SPEC_LINK_LOCATION(2);
SPEC_LINK_LOCATION(3);
SPEC_LINK_LOCATION(6);
SPEC_LINK_LOCATION(7);
SPEC_LINK_LOCATION(8);
- return(FIXED_HS + 8);
+ return(FIXED_HS + size);
}
I_
_ScanLink_9_9(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 9, 9);
+ I_ size = 9;
+ DEBUG_SCAN_LINK("SPEC", size, 9);
SPEC_LINK_LOCATION(1);
SPEC_LINK_LOCATION(2);
SPEC_LINK_LOCATION(3);
SPEC_LINK_LOCATION(7);
SPEC_LINK_LOCATION(8);
SPEC_LINK_LOCATION(9);
- return(FIXED_HS + 9);
+ return(FIXED_HS + size);
}
I_
_ScanLink_10_10(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 10, 10);
+ I_ size = 10;
+ DEBUG_SCAN_LINK("SPEC", size, 10);
SPEC_LINK_LOCATION(1);
SPEC_LINK_LOCATION(2);
SPEC_LINK_LOCATION(3);
SPEC_LINK_LOCATION(8);
SPEC_LINK_LOCATION(9);
SPEC_LINK_LOCATION(10);
- return(FIXED_HS + 10);
+ return(FIXED_HS + size);
}
I_
_ScanLink_11_11(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 11, 11);
+ I_ size = 11;
+ DEBUG_SCAN_LINK("SPEC", size, 11);
SPEC_LINK_LOCATION(1);
SPEC_LINK_LOCATION(2);
SPEC_LINK_LOCATION(3);
SPEC_LINK_LOCATION(9);
SPEC_LINK_LOCATION(10);
SPEC_LINK_LOCATION(11);
- return(FIXED_HS + 11);
+ return(FIXED_HS + size);
}
I_
_ScanLink_12_12(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("SPEC", 12, 12);
+ I_ size = 12;
+ DEBUG_SCAN_LINK("SPEC", size, 12);
SPEC_LINK_LOCATION(1);
SPEC_LINK_LOCATION(2);
SPEC_LINK_LOCATION(3);
SPEC_LINK_LOCATION(10);
SPEC_LINK_LOCATION(11);
SPEC_LINK_LOCATION(12);
- return(FIXED_HS + 12);
+ return(FIXED_HS + size);
}
\end{code}
I_
_ScanLink_RBH_2_1(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 2, 1);
+ I_ size = 2 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 1);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- return(FIXED_HS + 2); /* ???? but SPEC_RBH_VHS is *not* zero! */
+ return(FIXED_HS + size);
}
-
I_
_ScanLink_RBH_3_1(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 3, 1);
+ I_ size = 3 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 1);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- return(FIXED_HS + 3);
+ return(FIXED_HS + size);
}
-
I_
_ScanLink_RBH_3_3(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 3, 3);
+ I_ size = 3 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 3);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
- return(FIXED_HS + 3);
+ return(FIXED_HS + size);
}
-
I_
_ScanLink_RBH_4_1(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 4, 1);
+ I_ size = 4 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 1);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- return(FIXED_HS + 4);
+ return(FIXED_HS + size);
}
-
I_
_ScanLink_RBH_4_4(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 4, 4);
+ I_ size = 4 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 4);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
- return(FIXED_HS + 4);
+ return(FIXED_HS + size);
}
-
I_
_ScanLink_RBH_5_1(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 5, 1);
+ I_ size = 5 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 1);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
- return(FIXED_HS + 5);
+ return(FIXED_HS + size);
}
-
I_
_ScanLink_RBH_5_5(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 5, 5);
+ I_ size = 5 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 5);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
- return(FIXED_HS + 5);
+ return(FIXED_HS + size);
}
-
I_
_ScanLink_RBH_6_6(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 6, 6);
+ I_ size = 6 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 6);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
- return(FIXED_HS + 6);
+ return(FIXED_HS + size);
}
-
I_
_ScanLink_RBH_7_7(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 7, 7);
+ I_ size = 7 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 7);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
- return(FIXED_HS + 7);
+ return(FIXED_HS + size);
}
-
I_
_ScanLink_RBH_8_8(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 8, 8);
+ I_ size = 8 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 8);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6);
- return(FIXED_HS + 8);
+ return(FIXED_HS + size);
}
-
I_
_ScanLink_RBH_9_9(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 9, 9);
+ I_ size = 9 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 9);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7);
- return(FIXED_HS + 9);
+ return(FIXED_HS + size);
}
-
I_
_ScanLink_RBH_10_10(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 10, 10);
+ I_ size = 10 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 10);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 8);
- return(FIXED_HS + 10);
+ return(FIXED_HS + size);
}
-
I_
_ScanLink_RBH_11_11(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 11, 11);
+ I_ size = 11 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 11);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 8);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 9);
- return(FIXED_HS + 11);
+ return(FIXED_HS + size);
}
-
I_
_ScanLink_RBH_12_12(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("SRBH", 12, 12);
+ I_ size = 12 + SPEC_RBH_VHS;
+ DEBUG_SCAN_LINK("SRBH", size, 12);
LINK_LOCATION(SPEC_RBH_BQ_LOCN);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 8);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 9);
LINK_LOCATION(SPEC_RBH_BQ_LOCN + 10);
- return(FIXED_HS + 12);
+ return(FIXED_HS + size);
}
#endif
-
\end{code}
Scan-linking a MallocPtr is straightforward: exactly the same as
\begin{code}
#ifndef PAR
-StgInt
+I_
_ScanLink_MallocPtr(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("MallocPtr", MallocPtr_SIZE, 0);
- return(FIXED_HS + MallocPtr_SIZE);
+ I_ size = MallocPtr_SIZE;
+ DEBUG_SCAN_LINK("MallocPtr", size, 0);
+ return(FIXED_HS + size);
}
#endif /* !PAR */
\end{code}
/*** MOVING CLOSURES ***/
+#ifdef TICKY_TICKY
+I_
+_ScanMove_0(STG_NO_ARGS) {
+ I_ size = 0; /* NB: SPEC_VHS defined to be zero, so 0 really is the "size" */
+ DEBUG_SCAN_MOVE("CONST", size);
+ SLIDE_FIXED_HDR;
+ return(FIXED_HS + size);
+}
+#endif
I_
_ScanMove_1(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SPEC", 1);
+ I_ size = 1; /* NB: SPEC_VHS defined to be zero, so 1 really is the "size" */
+ DEBUG_SCAN_MOVE("SPEC", size);
SLIDE_FIXED_HDR;
SPEC_SLIDE_WORD(1);
- return(FIXED_HS + 1); /* NB: SPEC_VHS defined to be zero, so 1 really is the "size" */
+ return(FIXED_HS + size);
}
I_
_ScanMove_2(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SPEC", 2);
+ I_ size = 2;
+ DEBUG_SCAN_MOVE("SPEC", size);
SLIDE_FIXED_HDR;
SPEC_SLIDE_WORD(1);
SPEC_SLIDE_WORD(2);
- return(FIXED_HS + 2);
+ return(FIXED_HS + size);
}
I_
_ScanMove_3(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SPEC", 3);
+ I_ size = 3;
+ DEBUG_SCAN_MOVE("SPEC", size);
SLIDE_FIXED_HDR;
SPEC_SLIDE_WORD(1);
SPEC_SLIDE_WORD(2);
SPEC_SLIDE_WORD(3);
- return(FIXED_HS + 3);
+ return(FIXED_HS + size);
}
I_
_ScanMove_4(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SPEC", 4);
+ I_ size = 4;
+ DEBUG_SCAN_MOVE("SPEC", size);
SLIDE_FIXED_HDR;
SPEC_SLIDE_WORD(1);
SPEC_SLIDE_WORD(2);
SPEC_SLIDE_WORD(3);
SPEC_SLIDE_WORD(4);
- return(FIXED_HS + 4);
+ return(FIXED_HS + size);
}
I_
_ScanMove_5(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SPEC", 5);
+ I_ size = 5;
+ DEBUG_SCAN_MOVE("SPEC", size);
SLIDE_FIXED_HDR;
SPEC_SLIDE_WORD(1);
SPEC_SLIDE_WORD(2);
SPEC_SLIDE_WORD(3);
SPEC_SLIDE_WORD(4);
SPEC_SLIDE_WORD(5);
- return(FIXED_HS + 5);
+ return(FIXED_HS + size);
}
I_
_ScanMove_6(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SPEC", 6);
+ I_ size = 6;
+ DEBUG_SCAN_MOVE("SPEC", size);
SLIDE_FIXED_HDR;
SPEC_SLIDE_WORD(1);
SPEC_SLIDE_WORD(2);
SPEC_SLIDE_WORD(4);
SPEC_SLIDE_WORD(5);
SPEC_SLIDE_WORD(6);
- return(FIXED_HS + 6);
+ return(FIXED_HS + size);
}
I_
_ScanMove_7(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SPEC", 7);
+ I_ size = 7;
+ DEBUG_SCAN_MOVE("SPEC", size);
SLIDE_FIXED_HDR;
SPEC_SLIDE_WORD(1);
SPEC_SLIDE_WORD(2);
SPEC_SLIDE_WORD(5);
SPEC_SLIDE_WORD(6);
SPEC_SLIDE_WORD(7);
- return(FIXED_HS + 7);
+ return(FIXED_HS + size);
}
I_
_ScanMove_8(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SPEC", 8);
+ I_ size = 8;
+ DEBUG_SCAN_MOVE("SPEC", size);
SLIDE_FIXED_HDR;
SPEC_SLIDE_WORD(1);
SPEC_SLIDE_WORD(2);
SPEC_SLIDE_WORD(6);
SPEC_SLIDE_WORD(7);
SPEC_SLIDE_WORD(8);
- return(FIXED_HS + 8);
+ return(FIXED_HS + size);
}
I_
_ScanMove_9(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SPEC", 9);
+ I_ size = 9;
+ DEBUG_SCAN_MOVE("SPEC", size);
SLIDE_FIXED_HDR;
SPEC_SLIDE_WORD(1);
SPEC_SLIDE_WORD(2);
SPEC_SLIDE_WORD(7);
SPEC_SLIDE_WORD(8);
SPEC_SLIDE_WORD(9);
- return(FIXED_HS + 9);
+ return(FIXED_HS + size);
}
I_
_ScanMove_10(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SPEC", 10);
+ I_ size = 10;
+ DEBUG_SCAN_MOVE("SPEC", size);
SLIDE_FIXED_HDR;
SPEC_SLIDE_WORD(1);
SPEC_SLIDE_WORD(2);
SPEC_SLIDE_WORD(8);
SPEC_SLIDE_WORD(9);
SPEC_SLIDE_WORD(10);
- return(FIXED_HS + 10);
+ return(FIXED_HS + size);
}
I_
_ScanMove_11(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SPEC", 11);
+ I_ size = 11;
+ DEBUG_SCAN_MOVE("SPEC", size);
SLIDE_FIXED_HDR;
SPEC_SLIDE_WORD(1);
SPEC_SLIDE_WORD(2);
SPEC_SLIDE_WORD(9);
SPEC_SLIDE_WORD(10);
SPEC_SLIDE_WORD(11);
- return(FIXED_HS + 11);
+ return(FIXED_HS + size);
}
I_
_ScanMove_12(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SPEC", 12);
+ I_ size = 12;
+ DEBUG_SCAN_MOVE("SPEC", size);
SLIDE_FIXED_HDR;
SPEC_SLIDE_WORD(1);
SPEC_SLIDE_WORD(2);
SPEC_SLIDE_WORD(10);
SPEC_SLIDE_WORD(11);
SPEC_SLIDE_WORD(12);
- return(FIXED_HS + 12);
+ return(FIXED_HS + size);
}
#if defined(PAR) && defined(GC_MUT_REQUIRED)
I_
_ScanMove_RBH_2(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SRBH", 2);
+ I_ size = 2 + SPEC_RBH_VHS;
+ DEBUG_SCAN_MOVE("SRBH", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(SPEC_RBH_HS + 0);
MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
StorageMgrInfo.OldMutables = (P_) New;
- return(FIXED_HS + 2); /* ???? SPEC_RBH_VHS is *not* zero! */
+ return(FIXED_HS + size);
}
I_
_ScanMove_RBH_3(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SRBH", 3);
+ I_ size = 3 + SPEC_RBH_VHS;
+ DEBUG_SCAN_MOVE("SRBH", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(SPEC_RBH_HS + 0);
SLIDE_WORD(SPEC_RBH_HS + 1);
MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
StorageMgrInfo.OldMutables = (P_) New;
- return(FIXED_HS + 3);
+ return(FIXED_HS + size);
}
I_
_ScanMove_RBH_4(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SRBH", 4);
+ I_ size = 4 + SPEC_RBH_VHS;
+ DEBUG_SCAN_MOVE("SRBH", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(SPEC_RBH_HS + 0);
SLIDE_WORD(SPEC_RBH_HS + 1);
MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
StorageMgrInfo.OldMutables = (P_) New;
- return(FIXED_HS + 4);
+ return(FIXED_HS + size);
}
I_
_ScanMove_RBH_5(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SRBH", 5);
+ I_ size = 5 + SPEC_RBH_VHS;
+ DEBUG_SCAN_MOVE("SRBH", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(SPEC_RBH_HS + 0);
SLIDE_WORD(SPEC_RBH_HS + 1);
MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
StorageMgrInfo.OldMutables = (P_) New;
- return(FIXED_HS + 5);
+ return(FIXED_HS + size);
}
I_
_ScanMove_RBH_6(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SRBH", 6);
+ I_ size = 6 + SPEC_RBH_VHS;
+ DEBUG_SCAN_MOVE("SRBH", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(SPEC_RBH_HS + 0);
SLIDE_WORD(SPEC_RBH_HS + 1);
MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
StorageMgrInfo.OldMutables = (P_) New;
- return(FIXED_HS + 6);
+ return(FIXED_HS + size);
}
I_
_ScanMove_RBH_7(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SRBH", 7);
+ I_ size = 7 + SPEC_RBH_VHS;
+ DEBUG_SCAN_MOVE("SRBH", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(SPEC_RBH_HS + 0);
SLIDE_WORD(SPEC_RBH_HS + 1);
MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
StorageMgrInfo.OldMutables = (P_) New;
- return(FIXED_HS + 7);
+ return(FIXED_HS + size);
}
I_
_ScanMove_RBH_8(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SRBH", 8);
+ I_ size = 8 + SPEC_RBH_VHS;
+ DEBUG_SCAN_MOVE("SRBH", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(SPEC_RBH_HS + 0);
SLIDE_WORD(SPEC_RBH_HS + 1);
MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
StorageMgrInfo.OldMutables = (P_) New;
- return(FIXED_HS + 8);
+ return(FIXED_HS + size);
}
I_
_ScanMove_RBH_9(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SRBH", 9);
+ I_ size = 9 + SPEC_RBH_VHS;
+ DEBUG_SCAN_MOVE("SRBH", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(SPEC_RBH_HS + 0);
SLIDE_WORD(SPEC_RBH_HS + 1);
MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
StorageMgrInfo.OldMutables = (P_) New;
- return(FIXED_HS + 9);
+ return(FIXED_HS + size);
}
I_
_ScanMove_RBH_10(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SRBH", 10);
+ I_ size = 10 + SPEC_RBH_VHS;
+ DEBUG_SCAN_MOVE("SRBH", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(SPEC_RBH_HS + 0);
SLIDE_WORD(SPEC_RBH_HS + 1);
MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
StorageMgrInfo.OldMutables = (P_) New;
- return(FIXED_HS + 10);
+ return(FIXED_HS + size);
}
I_
_ScanMove_RBH_11(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SRBH", 11);
+ I_ size = 11 + SPEC_RBH_VHS;
+ DEBUG_SCAN_MOVE("SRBH", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(SPEC_RBH_HS + 0);
SLIDE_WORD(SPEC_RBH_HS + 1);
MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
StorageMgrInfo.OldMutables = (P_) New;
- return(FIXED_HS + 11);
+ return(FIXED_HS + size);
}
I_
_ScanMove_RBH_12(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("SRBH", 12);
+ I_ size = 12 + SPEC_RBH_VHS;
+ DEBUG_SCAN_MOVE("SRBH", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(SPEC_RBH_HS + 0);
SLIDE_WORD(SPEC_RBH_HS + 1);
MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables;
StorageMgrInfo.OldMutables = (P_) New;
- return(FIXED_HS + 12);
+ return(FIXED_HS + size);
}
#endif
\end{code}
\begin{code}
#ifndef PAR
-StgInt
+I_
_ScanMove_MallocPtr(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("MallocPtr", MallocPtr_SIZE);
+ I_ size = MallocPtr_SIZE;
+ DEBUG_SCAN_MOVE("MallocPtr", size);
-#if defined(_GC_DEBUG)
- if (SM_trace & 16) {
+#if defined(DEBUG)
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
printf("Moving MallocPtr(%x)=<%x,%x,%x>", Scan, Scan[0], Scan[1], Scan[2]);
printf(" Data = %x, Next = %x\n",
MallocPtr_CLOSURE_DATA(Scan), MallocPtr_CLOSURE_LINK(Scan) );
MallocPtr_SLIDE_DATA;
MallocPtr_RELINK;
-#if defined(_GC_DEBUG)
- if (SM_trace & 16) {
+#if defined(DEBUG)
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MALLOCPTRS) {
printf("Moved MallocPtr(%x)=<%x,_,%x,%x,%x>", New, New[0], New[1], New[2], New[3]);
printf(" Data = %x, Next = %x",
MallocPtr_CLOSURE_DATA(New), MallocPtr_CLOSURE_LINK(New) );
}
#endif
- return(FIXED_HS + MallocPtr_SIZE);
+ return(FIXED_HS + size);
}
#endif /* !PAR */
\end{code}
I_
_ScanLink_BH_U(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("BH ", MIN_UPD_SIZE, 0);
- return(FIXED_HS + BH_U_SIZE); /* size includes _VHS */
- /* NB: pretty intimate knowledge about BH closure layout */
+ I_ size = BH_U_SIZE;
+ DEBUG_SCAN_LINK("BH ", size, 0);
+ return(FIXED_HS + size);
}
I_
_ScanMove_BH_U(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("BH ", MIN_UPD_SIZE);
+ I_ size = BH_U_SIZE;
+ DEBUG_SCAN_MOVE("BH ", size);
SLIDE_FIXED_HDR;
- return(FIXED_HS + BH_U_SIZE);
- /* ditto */
+ return(FIXED_HS + size);
}
I_
_ScanLink_BH_N(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("BH N", MIN_NONUPD_SIZE, 0);
- return(FIXED_HS + BH_N_SIZE); /* size includes _VHS */
- /* NB: pretty intimate knowledge about BH closure layout */
+ I_ size = BH_N_SIZE;
+ DEBUG_SCAN_LINK("BH N", size, 0);
+ return(FIXED_HS + size);
}
I_
_ScanMove_BH_N(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("BH N",MIN_NONUPD_SIZE);
+ I_ size = BH_N_SIZE;
+ DEBUG_SCAN_MOVE("BH N", size);
SLIDE_FIXED_HDR;
- return(FIXED_HS + BH_N_SIZE);
- /* ditto */
+ return(FIXED_HS + size);
}
-#ifdef USE_COST_CENTRES
+#if defined(PROFILING) || defined(TICKY_TICKY)
I_
_ScanLink_PI(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("PI ", IND_CLOSURE_SIZE(dummy), 1);
+ I_ size = IND_CLOSURE_SIZE(dummy);
+ DEBUG_SCAN_LINK("PI ", size, 1);
LINK_LOCATION(IND_HS);
- return(FIXED_HS + IND_CLOSURE_SIZE(dummy) /*MIN_UPD_SIZE*/);
+ return(FIXED_HS + size);
}
I_
_ScanMove_PI(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("PI ", IND_CLOSURE_SIZE(dummy));
+ I_ size = IND_CLOSURE_SIZE(dummy);
+ DEBUG_SCAN_MOVE("PI ", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(IND_HS);
- return(FIXED_HS + IND_CLOSURE_SIZE(dummy) /*MIN_UPD_SIZE*/);
+ return(FIXED_HS + size);
}
#endif
I_
_ScanLink_FetchMe(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("FME ", MIN_UPD_SIZE, 0);
- return(FIXED_HS + FETCHME_CLOSURE_SIZE(dummy) /*MIN_UPD_SIZE*/);
+ I_ size = FETCHME_CLOSURE_SIZE(dummy);
+ DEBUG_SCAN_LINK("FME ", size, 0);
+ return(FIXED_HS + size);
}
I_
_ScanMove_FetchMe(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("FME ",MIN_UPD_SIZE);
+ I_ size = FETCHME_CLOSURE_SIZE(dummy);
+ DEBUG_SCAN_MOVE("FME ", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(FETCHME_GA_LOCN);
ASSERT(GALAlookup(FETCHME_GA(New)) != NULL);
StorageMgrInfo.OldMutables = (P_) New;
#endif
- return(FIXED_HS + FETCHME_CLOSURE_SIZE(dummy) /*MIN_UPD_SIZE*/);
+ return(FIXED_HS + size);
}
I_
_ScanLink_BF(STG_NO_ARGS)
{
- DEBUG_SCAN_LINK("BF", BF_HS, 2 /*possibly wrong (WDP 95/07)*/);
+ I_ size = BF_CLOSURE_SIZE(dummy);
+ DEBUG_SCAN_LINK("BF", size, 2);
LINK_LOCATION(BF_LINK_LOCN);
LINK_LOCATION(BF_NODE_LOCN);
- return(FIXED_HS + BF_CLOSURE_SIZE(dummy));
+ return(FIXED_HS + size);
}
I_
_ScanMove_BF(STG_NO_ARGS)
{
I_ count;
+ I_ size = BF_CLOSURE_SIZE(dummy);
SLIDE_FIXED_HDR;
for (count = FIXED_HS; count < FIXED_HS + BF_VHS; count++) {
StorageMgrInfo.OldMutables = (P_) New;
#endif
- return(FIXED_HS + BF_CLOSURE_SIZE(dummy));
+ return(FIXED_HS + size);
}
#endif /* PAR */
I_
_ScanLink_BQ(STG_NO_ARGS) {
- DEBUG_SCAN_LINK("BQ ", BQ_CLOSURE_SIZE(dummy), BQ_CLOSURE_NoPTRS(Scan));
+ I_ size = BQ_CLOSURE_SIZE(dummy);
+ DEBUG_SCAN_LINK("BQ ", size, BQ_CLOSURE_NoPTRS(Scan));
LINK_LOCATION(BQ_HS);
- return(FIXED_HS + BQ_CLOSURE_SIZE(dummy));
+ return(FIXED_HS + size);
}
I_
_ScanMove_BQ(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("BQ ", BQ_CLOSURE_SIZE(dummy));
+ I_ size = BQ_CLOSURE_SIZE(dummy);
+ DEBUG_SCAN_MOVE("BQ ", size);
SLIDE_FIXED_HDR;
SLIDE_WORD(BQ_HS);
StorageMgrInfo.OldMutables = (P_) New;
#endif
- return(FIXED_HS + BQ_CLOSURE_SIZE(dummy));
+ return(FIXED_HS + size);
}
I_
STGRegisterTable *r = TSO_INTERNAL_PTR(Scan);
W_ liveness = r->rLiveness;
I_ i;
+ I_ size = TSO_VHS + TSO_CTS_SIZE;
- DEBUG_SCAN_LINK("TSO", TSO_HS + TSO_CTS_SIZE, 0/*wrong*/);
+ DEBUG_SCAN_LINK("TSO", size, 0/*wrong*/);
LINK_LOCATION(TSO_LINK_LOCN);
LINK_LOCATION(((P_) &r->rStkO) - Scan);
LINK_LOCATION(((P_) &r->rR[i].p) - Scan)
}
}
- return(TSO_HS + TSO_CTS_SIZE);
+ return(FIXED_HS + size);
}
I_
_ScanMove_TSO(STG_NO_ARGS)
{
I_ count;
+ I_ size = TSO_VHS + TSO_CTS_SIZE;
SLIDE_FIXED_HDR;
for (count = FIXED_HS; count < FIXED_HS + TSO_VHS; count++) {
StorageMgrInfo.OldMutables = (P_) New;
#endif
- return(TSO_HS + TSO_CTS_SIZE);
+ return(FIXED_HS + size);
}
I_
LINK_LOCATION(STKO_LINK_LOCN);
/* Link the locations in the A stack */
- DEBUG_SCAN_LINK("STKO", size, cts_size - STKO_SpA_OFFSET(SCAN) + 1);
+ DEBUG_SCAN_LINK("STKO", size, cts_size - STKO_SpA_OFFSET(Scan) + 1);
for (count = STKO_SpA_OFFSET(Scan); count <= cts_size; count++) {
STKO_LINK_LOCATION(count);
}
sub = STKO_CLOSURE_OFFSET(Scan, subptr);
}
- /*
- I assume what's wanted is the size of the object
- rather the number of pointers in the object. KH
- */
+ ASSERT(sanityChk_StkO(Scan));
+
return(FIXED_HS + size);
}
DEBUG_SCAN_MOVE("STKO", size);
SLIDE_FIXED_HDR;
-#ifdef DO_REDN_COUNTING
+#ifdef TICKY_TICKY
SLIDE_WORD(STKO_ADEP_LOCN);
SLIDE_WORD(STKO_BDEP_LOCN);
#endif
StorageMgrInfo.OldMutables = (P_) New;
#endif
+ /* ToDo: ASSERT(sanityChk_StkO(Scan or New)); ??? */
+
return(FIXED_HS + size);
}
\end{code}
\begin{code}
-#if defined(GCgn)
-I_
-_ScanMove_OldRoot(STG_NO_ARGS) {
- DEBUG_SCAN_MOVE("OLDR", 2);
- SLIDE_FIXED_HDR;
- IND_CLOSURE_PTR(New) = IND_CLOSURE_PTR(Scan);
- IND_CLOSURE_LINK(New) = (W_) genInfo.OldInNew;
- genInfo.OldInNew = New;
- genInfo.OldInNewno++;
- return(IND_HS + MIN_UPD_SIZE); /* this looks wrong (WDP 95/07) */
-}
-#endif /* GCgn */
-
/*** Dummy Entries -- Should not be entered ***/
/* Should not be in a .lc file either... --JSM */
}
#endif /* _INFO_COMPACTING */
-
\end{code}
/*** DEBUGGING MACROS ***/
-#if defined(_GC_DEBUG)
+#if defined(DEBUG)
#define DEBUG_SCAV(s,p) \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Scav: 0x%lx, info 0x%lx, size %ld, ptrs %ld\n", \
Scav, INFO_PTR(Scav), s, p)
#define DEBUG_SCAV_GEN(s,p) \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Scav: 0x%lx, Gen info 0x%lx, size %ld, ptrs %ld\n", \
Scav, INFO_PTR(Scav), s, p)
#define DEBUG_SCAV_DYN \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Scav: 0x%lx, Dyn info 0x%lx, size %ld, ptrs %ld\n", \
Scav, INFO_PTR(Scav), DYN_CLOSURE_SIZE(Scav), DYN_CLOSURE_NoPTRS(Scav))
#define DEBUG_SCAV_TUPLE \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Scav: 0x%lx, Tuple info 0x%lx, size %ld, ptrs %ld\n", \
Scav, INFO_PTR(Scav), TUPLE_CLOSURE_SIZE(Scav), TUPLE_CLOSURE_NoPTRS(Scav))
#define DEBUG_SCAV_MUTUPLE \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Scav: 0x%lx, MuTuple info 0x%lx, size %ld, ptrs %ld\n", \
Scav, INFO_PTR(Scav), MUTUPLE_CLOSURE_SIZE(Scav), MUTUPLE_CLOSURE_NoPTRS(Scav))
#define DEBUG_SCAV_DATA \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Scav: 0x%lx, Data info 0x%lx, size %ld\n", \
Scav, INFO_PTR(Scav), DATA_CLOSURE_SIZE(Scav))
#define DEBUG_SCAV_BH(s) \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Scav: 0x%lx, BH info 0x%lx, size %ld\n", \
Scav, INFO_PTR(Scav), s)
#define DEBUG_SCAV_IND \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Scav: 0x%lx, IND info 0x%lx, size %ld\n", \
Scav, INFO_PTR(Scav), IND_CLOSURE_SIZE(Scav))
#define DEBUG_SCAV_PERM_IND \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Scav: 0x%lx, PI info 0x%lx, size %ld\n", \
Scav, INFO_PTR(Scav), IND_CLOSURE_SIZE(Scav))
#define DEBUG_SCAV_OLDROOT(s) \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_MINOR_GC) \
fprintf(stderr, "Scav: OLDROOT 0x%lx, info 0x%lx, size %ld\n", \
Scav, INFO_PTR(Scav), s)
#ifdef CONCURRENT
#define DEBUG_SCAV_BQ \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
fprintf(stderr, "Scav: 0x%lx, BQ info 0x%lx, size %ld, ptrs %ld\n", \
Scav, INFO_PTR(Scav), BQ_CLOSURE_SIZE(Scav), BQ_CLOSURE_NoPTRS(Scav))
#define DEBUG_SCAV_TSO \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
fprintf(stderr, "Scav TSO: 0x%lx\n", \
Scav)
#define DEBUG_SCAV_STKO \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
fprintf(stderr, "Scav StkO: 0x%lx\n", \
Scav)
# ifdef PAR
+# define DEBUG_SCAV_RBH(s,p) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
+ fprintf(stderr, "Scav RBH: 0x%lx, info 0x%lx, size %ld, ptrs %ld\n", \
+ Scav, INFO_PTR(Scav), s, p)
+
# define DEBUG_SCAV_BF \
- if (SM_trace & 2) \
+ if (RTSflags.GcFlags.trace & DEBUG_TRACE_CONCURRENT) \
fprintf(stderr, "Scav: 0x%lx, BF info 0x%lx, size %ld, ptrs %ld\n", \
Scav, INFO_PTR(Scav), BF_CLOSURE_SIZE(dummy), 0)
# endif
# define DEBUG_SCAV_TSO
# define DEBUG_SCAV_STKO
# ifdef PAR
+# define DEBUG_SCAV_RBH(s,p)
# define DEBUG_SCAV_BF
# endif
#endif
#endif
#define PROFILE_CLOSURE(closure,size) \
- HEAP_PROFILE_CLOSURE(closure,size); \
- LIFE_PROFILE_CLOSURE(closure,size)
+ HEAP_PROFILE_CLOSURE(closure,size)
/*** SPECIALISED CODE ***/
+#ifdef TICKY_TICKY
void
-_Scavenge_1_0(STG_NO_ARGS)
+_Scavenge_0_0(STG_NO_ARGS)
{
- DEBUG_SCAV(1,0);
- PROFILE_CLOSURE(Scav,1);
- NEXT_Scav(1); /* because "size" is defined to be 1 (size SPEC_VHS == 0) */
- return;
-}
-void
-_Scavenge_2_0(STG_NO_ARGS)
-{
- DEBUG_SCAV(2,0);
- PROFILE_CLOSURE(Scav,2);
- NEXT_Scav(2);
+ DEBUG_SCAV(0,0);
+ PROFILE_CLOSURE(Scav,0);
+ NEXT_Scav(0); /* because "size" is defined to be 0 (size SPEC_VHS == 0) */
return;
}
+#endif
+
void
-_Scavenge_3_0(STG_NO_ARGS)
+_Scavenge_1_0(STG_NO_ARGS)
{
- DEBUG_SCAV(3,0);
- PROFILE_CLOSURE(Scav,3);
- NEXT_Scav(3);
+ DEBUG_SCAV(1,0);
+ PROFILE_CLOSURE(Scav,1);
+ NEXT_Scav(1); /* because "size" is defined to be 1 (size SPEC_VHS == 0) */
return;
}
void
-_Scavenge_4_0(STG_NO_ARGS)
+_Scavenge_1_1(STG_NO_ARGS)
{
- DEBUG_SCAV(4,0);
- PROFILE_CLOSURE(Scav,4);
- NEXT_Scav(4);
+ DEBUG_SCAV(1,1);
+ PROFILE_CLOSURE(Scav,1);
+ SPEC_DO_EVACUATE(1);
+ NEXT_Scav(1);
return;
}
void
-_Scavenge_5_0(STG_NO_ARGS)
+_Scavenge_2_0(STG_NO_ARGS)
{
- DEBUG_SCAV(5,0);
- PROFILE_CLOSURE(Scav,5);
- NEXT_Scav(5);
+ DEBUG_SCAV(2,0);
+ PROFILE_CLOSURE(Scav,2);
+ NEXT_Scav(2);
return;
}
-
void
_Scavenge_2_1(STG_NO_ARGS)
{
NEXT_Scav(2);
return;
}
-
void
-_Scavenge_3_1(STG_NO_ARGS)
+_Scavenge_2_2(STG_NO_ARGS)
{
- DEBUG_SCAV(3,1);
- PROFILE_CLOSURE(Scav,3);
+ DEBUG_SCAV(2,2);
+ PROFILE_CLOSURE(Scav,2);
SPEC_DO_EVACUATE(1);
- NEXT_Scav(3);
+ SPEC_DO_EVACUATE(2);
+ NEXT_Scav(2);
return;
}
void
-_Scavenge_3_2(STG_NO_ARGS)
+_Scavenge_3_0(STG_NO_ARGS)
{
- DEBUG_SCAV(3,2);
+ DEBUG_SCAV(3,0);
PROFILE_CLOSURE(Scav,3);
- SPEC_DO_EVACUATE(1);
- SPEC_DO_EVACUATE(2);
NEXT_Scav(3);
return;
}
-
void
-_Scavenge_1_1(STG_NO_ARGS)
+_Scavenge_3_1(STG_NO_ARGS)
{
- DEBUG_SCAV(1,1);
- PROFILE_CLOSURE(Scav,1);
+ DEBUG_SCAV(3,1);
+ PROFILE_CLOSURE(Scav,3);
SPEC_DO_EVACUATE(1);
- NEXT_Scav(1);
+ NEXT_Scav(3);
return;
}
void
-_Scavenge_2_2(STG_NO_ARGS)
+_Scavenge_3_2(STG_NO_ARGS)
{
- DEBUG_SCAV(2,2);
- PROFILE_CLOSURE(Scav,2);
+ DEBUG_SCAV(3,2);
+ PROFILE_CLOSURE(Scav,3);
SPEC_DO_EVACUATE(1);
SPEC_DO_EVACUATE(2);
- NEXT_Scav(2);
+ NEXT_Scav(3);
return;
}
void
return;
}
void
+_Scavenge_4_0(STG_NO_ARGS)
+{
+ DEBUG_SCAV(4,0);
+ PROFILE_CLOSURE(Scav,4);
+ NEXT_Scav(4);
+ return;
+}
+void
_Scavenge_4_4(STG_NO_ARGS)
{
DEBUG_SCAV(4,4);
return;
}
void
+_Scavenge_5_0(STG_NO_ARGS)
+{
+ DEBUG_SCAV(5,0);
+ PROFILE_CLOSURE(Scav,5);
+ NEXT_Scav(5);
+ return;
+}
+void
_Scavenge_5_5(STG_NO_ARGS)
{
DEBUG_SCAV(5,5);
void \
CAT3(_Scavenge_RBH_,n,_1)(STG_NO_ARGS) \
{ \
+ I_ size = n + SPEC_RBH_VHS; \
P_ save_Scav; \
- DEBUG_SCAV(n,1); \
+ DEBUG_SCAV_RBH(size,1); \
save_Scav = Scav; \
Scav = OldGen + 1; \
DO_EVACUATE(save_Scav, SPEC_RBH_BQ_LOCN); \
Scav = save_Scav; \
- PROFILE_CLOSURE(Scav,n); \
- NEXT_Scav(n); /* ToDo: dodgy size WDP 95/07 */ \
+ PROFILE_CLOSURE(Scav,size); \
+ NEXT_Scav(size); \
}
# define SCAVENGE_SPEC_RBH_N_N(n) \
void \
CAT4(_Scavenge_RBH_,n,_,n)(STG_NO_ARGS) \
{ \
+ I_ size = n + SPEC_RBH_VHS; \
int i; \
P_ save_Scav; \
- DEBUG_SCAV(n,n-1); \
+ DEBUG_SCAV_RBH(size,size-1); \
save_Scav = Scav; \
Scav = OldGen + 1; \
for(i = 0; i < n - 1; i++) { \
DO_EVACUATE(save_Scav, SPEC_RBH_BQ_LOCN + i); \
} \
Scav = save_Scav; \
- PROFILE_CLOSURE(Scav,n); \
- NEXT_Scav(n); \
+ PROFILE_CLOSURE(Scav,size); \
+ NEXT_Scav(size); \
}
# else
void \
CAT3(_Scavenge_RBH_,n,_1)(STG_NO_ARGS) \
{ \
- DEBUG_SCAV(n,1); \
+ I_ size = n + SPEC_RBH_VHS; \
+ DEBUG_SCAV_RBH(size,1); \
DO_EVACUATE(Scav, SPEC_RBH_BQ_LOCN);\
- PROFILE_CLOSURE(Scav,n); \
- NEXT_Scav(n); \
+ PROFILE_CLOSURE(Scav,size); \
+ NEXT_Scav(size); \
}
# define SCAVENGE_SPEC_RBH_N_N(n) \
void \
CAT4(_Scavenge_RBH_,n,_,n)(STG_NO_ARGS) \
{ \
+ I_ size = n + SPEC_RBH_VHS; \
int i; \
- DEBUG_SCAV(n,n-1); \
+ DEBUG_SCAV_RBH(size,size-1); \
for(i = 0; i < n - 1; i++) { \
DO_EVACUATE(Scav, SPEC_RBH_BQ_LOCN + i); \
} \
- PROFILE_CLOSURE(Scav,n); \
- NEXT_Scav(n); \
+ PROFILE_CLOSURE(Scav,size); \
+ NEXT_Scav(size); \
}
# endif
void
_Scavenge_MallocPtr(STG_NO_ARGS)
{
- DEBUG_SCAV(MallocPtr_SIZE,0);
- PROFILE_CLOSURE(Scav,MallocPtr_SIZE);
- NEXT_Scav(MallocPtr_SIZE);
+ I_ size = MallocPtr_SIZE;
+ DEBUG_SCAV(size,0);
+ PROFILE_CLOSURE(Scav,size);
+ NEXT_Scav(size);
return;
}
#endif /* !PAR */
void
_Scavenge_BH_U(STG_NO_ARGS)
{
- DEBUG_SCAV_BH(BH_U_SIZE);
- PROFILE_CLOSURE(Scav,BH_U_SIZE);
- NEXT_Scav(BH_U_SIZE);
+ I_ size = BH_U_SIZE;
+ DEBUG_SCAV_BH(size);
+ PROFILE_CLOSURE(Scav,size);
+ NEXT_Scav(size);
return;
}
void
_Scavenge_BH_N(STG_NO_ARGS)
{
- DEBUG_SCAV_BH(BH_N_SIZE);
- PROFILE_CLOSURE(Scav,BH_N_SIZE);
- NEXT_Scav(BH_N_SIZE);
+ I_ size = BH_N_SIZE;
+ DEBUG_SCAV_BH(size);
+ PROFILE_CLOSURE(Scav,size);
+ NEXT_Scav(size);
return;
}
-/* This is needed for scavenging the indirections on the OldMutables list */
-
+/* This is needed for scavenging indirections that "hang around";
+ e.g., because they are on the OldMutables list, or
+ because we have "turned off" shorting-out of indirections
+ (in SMevac.lc).
+*/
void
_Scavenge_Ind(STG_NO_ARGS)
{
+ I_ size = IND_CLOSURE_SIZE(dummy);
DEBUG_SCAV_IND;
- PROFILE_CLOSURE(Scav,IND_CLOSURE_SIZE(dummy));
+ PROFILE_CLOSURE(Scav,size);
DO_EVACUATE(Scav, IND_HS);
- NEXT_Scav(IND_CLOSURE_SIZE(dummy));
+ NEXT_Scav(size);
return;
}
void
_Scavenge_Caf(STG_NO_ARGS)
{
+ I_ size = IND_CLOSURE_SIZE(dummy);
DEBUG_SCAV_IND;
- PROFILE_CLOSURE(Scav,IND_CLOSURE_SIZE(dummy));
+ PROFILE_CLOSURE(Scav,size);
DO_EVACUATE(Scav, IND_HS);
- NEXT_Scav(IND_CLOSURE_SIZE(dummy));
+ NEXT_Scav(size);
return;
}
-#if defined(USE_COST_CENTRES)
+#if defined(PROFILING) || defined(TICKY_TICKY)
/* Special permanent indirection for lexical scoping.
As for _Scavenge_Ind but no PROFILE_CLOSURE.
void
_Scavenge_PI(STG_NO_ARGS)
{
+ I_ size = IND_CLOSURE_SIZE(dummy);
DEBUG_SCAV_PERM_IND;
- /* PROFILE_CLOSURE(Scav,IND_CLOSURE_SIZE(dummy)); */
+ /* PROFILE_CLOSURE(Scav,size); */
DO_EVACUATE(Scav, IND_HS);
- NEXT_Scav(IND_CLOSURE_SIZE(dummy));
+ NEXT_Scav(size);
return;
}
-#endif /* USE_COST_CENTRES */
+#endif /* PROFILING or TICKY */
#ifdef CONCURRENT
void
_Scavenge_BQ(STG_NO_ARGS)
{
+ I_ size = BQ_CLOSURE_SIZE(dummy);
#if defined(GCgn)
P_ save_Scav;
#endif
DO_EVACUATE(Scav, BQ_HS);
#endif /* GCgn */
- PROFILE_CLOSURE(Scav,BQ_CLOSURE_SIZE(dummy));
- NEXT_Scav(BQ_CLOSURE_SIZE(dummy));
+ PROFILE_CLOSURE(Scav,size);
+ NEXT_Scav(size);
return;
}
void
_Scavenge_TSO(STG_NO_ARGS)
{
+ I_ size = TSO_VHS + TSO_CTS_SIZE;
#if defined(GCgn)
P_ save_Scav;
#endif
DEBUG_SCAV_TSO;
#if defined(GCgn)
- /* No old generation roots should be created for mutable */
- /* pointer fields as they will be explicitly collected */
- /* Ensure this by pointing Scav at the new generation */
- save_Scav = Scav;
- Scav = OldGen + 1;
-
- DO_EVACUATE(save_Scav, TSO_LINK_LOCN);
- DO_EVACUATE(save_Scav, ((P_) &r->rStkO) - save_Scav);
- for(i = 0; liveness != 0; liveness >>= 1, i++) {
- if (liveness & 1) {
- DO_EVACUATE(save_Scav, ((P_) &r->rR[i].p) - save_Scav)
- }
- }
- Scav = save_Scav;
+ /* old and probably wrong -- deleted (WDP 95/12) */
#else
DO_EVACUATE(Scav, TSO_LINK_LOCN);
+
DO_EVACUATE(Scav, ((P_) &r->rStkO) - Scav);
- for(i = 0; liveness != 0; liveness >>= 1, i++) {
+
+ for (i = 0; liveness != 0; liveness >>= 1, i++) {
if (liveness & 1) {
DO_EVACUATE(Scav, ((P_) &r->rR[i].p) - Scav)
- }
+ }
}
#endif
- PROFILE_CLOSURE(Scav, TSO_VHS + TSO_CTS_SIZE)
- NEXT_Scav(TSO_VHS + TSO_CTS_SIZE);
+ PROFILE_CLOSURE(Scav, size);
+ NEXT_Scav(size);
return;
}
+int /* ToDo: move? */
+sanityChk_StkO(P_ stko)
+{
+ I_ size = STKO_CLOSURE_SIZE(stko);
+ I_ cts_size = STKO_CLOSURE_CTS_SIZE(stko);
+ I_ count;
+ I_ sub = STKO_SuB_OFFSET(stko); /* Offset of first update frame in B stack */
+ I_ prev_sub;
+ P_ begin_stko = STKO_CLOSURE_ADDR(stko, 0);
+ P_ beyond_stko = STKO_CLOSURE_ADDR(stko, cts_size+1);
+
+ /*fprintf(stderr, "stko=%lx; SpA offset=%ld; first SuB=%ld, size=%ld; next=%lx\n",stko,STKO_SpA_OFFSET(stko),sub,STKO_CLOSURE_CTS_SIZE(stko),STKO_LINK(stko));*/
+
+ /* Evacuate the locations in the A stack */
+ for (count = STKO_SpA_OFFSET(stko); count <= cts_size; count++) {
+ ASSERT(count >= 0);
+ }
+
+ while(sub > 0) {
+ P_ subptr;
+ P_ suaptr;
+ P_ updptr;
+ P_ retptr;
+
+ ASSERT(sub >= 1);
+ ASSERT(sub <= cts_size);
+
+ retptr = GRAB_RET(STKO_CLOSURE_ADDR(stko,sub));
+ subptr = GRAB_SuB(STKO_CLOSURE_ADDR(stko,sub));
+ suaptr = GRAB_SuA(STKO_CLOSURE_ADDR(stko,sub));
+ updptr = GRAB_UPDATEE(STKO_CLOSURE_ADDR(stko,sub));
+
+ ASSERT(subptr >= begin_stko);
+ ASSERT(subptr < beyond_stko);
+
+ ASSERT(suaptr >= begin_stko);
+ ASSERT(suaptr <= beyond_stko);
+
+ /* ToDo: would be nice to chk that retptr is in text space */
+
+ sub = STKO_CLOSURE_OFFSET(stko, subptr);
+ }
+
+ return 1;
+}
+
void
_Scavenge_StkO(STG_NO_ARGS)
{
+ I_ size = STKO_CLOSURE_SIZE(Scav);
#if defined(GCgn)
P_ save_Scav;
#endif
DEBUG_SCAV_STKO;
#if defined(GCgn)
- /* No old generation roots should be created for mutable */
- /* pointer fields as they will be explicitly collected */
- /* Ensure this by pointing Scav at the new generation */
- save_Scav = Scav;
- Scav = OldGen + 1;
-
- /* Evacuate the link */
- DO_EVACUATE(save_Scav, STKO_LINK_LOCN);
-
- /* Evacuate the locations in the A stack */
- for (count = STKO_SpA_OFFSET(save_Scav);
- count <= STKO_CLOSURE_CTS_SIZE(save_Scav); count++) {
- STKO_DO_EVACUATE(count);
- }
-
- /* Now evacuate the updatees in the update stack */
- while(sub > 0) {
- P_ subptr;
-
- STKO_DO_EVACUATE(sub + BREL(UF_UPDATEE));
- subptr = GRAB_SuB(STKO_CLOSURE_ADDR(save_Scav,sub));
- sub = STKO_CLOSURE_OFFSET(save_Scav, subptr);
- }
- Scav = save_Scav;
+ /* deleted; probably wrong */
#else
+ ASSERT(sanityChk_StkO(Scav));
+
/* Evacuate the link */
DO_EVACUATE(Scav, STKO_LINK_LOCN);
STKO_DO_EVACUATE(sub + BREL(UF_UPDATEE));
subptr = GRAB_SuB(STKO_CLOSURE_ADDR(Scav,sub));
+
sub = STKO_CLOSURE_OFFSET(Scav, subptr);
}
+
#endif
- PROFILE_CLOSURE(Scav, STKO_CLOSURE_SIZE(Scav))
- NEXT_Scav(STKO_CLOSURE_SIZE(Scav));
+ PROFILE_CLOSURE(Scav, size);
+ NEXT_Scav(size);
return;
}
void
_Scavenge_FetchMe(STG_NO_ARGS)
{
- DEBUG_SCAV(2,0);
- PROFILE_CLOSURE(Scav,2);
- NEXT_Scav(2);
+ I_ size = FETCHME_CLOSURE_SIZE(dummy);
+ DEBUG_SCAV(size,0);
+ PROFILE_CLOSURE(Scav,size);
+ NEXT_Scav(size);
return;
}
void
_Scavenge_BF(STG_NO_ARGS)
{
+ I_ size = BF_CLOSURE_SIZE(dummy);
#if defined(GCgn)
P_ save_Scav;
#endif
DO_EVACUATE(Scav, BF_NODE_LOCN);
#endif
- PROFILE_CLOSURE(Scav, BF_CLOSURE_SIZE(dummy))
- NEXT_Scav(BF_CLOSURE_SIZE(dummy));
+ PROFILE_CLOSURE(Scav, size);
+ NEXT_Scav(size);
return;
}
void
_Scavenge_OldRoot(STG_NO_ARGS)
{
- DEBUG_SCAV_OLDROOT(MIN_UPD_SIZE); /* dodgy size (WDP 95/07) */
- NEXT_Scav(MIN_UPD_SIZE);
+ I_ size = ?????
+ DEBUG_SCAV_OLDROOT(size);
+ NEXT_Scav(size);
return;
}
P_ MainStkO;
#endif
-I_
-initStacks(sm)
-smInfo *sm;
+rtsBool
+initStacks(smInfo *sm)
{
/*
* Allocate them if they don't exist. One space does for both stacks, since they
* grow towards each other
*/
if (stks_space == 0) {
-#ifdef CONCURRENT
- MainStkO = (P_) xmalloc((STKO_HS + SM_word_stk_size) * sizeof(W_));
+#ifndef CONCURRENT
+ stks_space = (P_) stgMallocWords(RTSflags.GcFlags.stksSize, "initStacks");
+#else
+ MainStkO = (P_) stgMallocWords(STKO_HS + RTSflags.GcFlags.stksSize, "initStacks");
stks_space = MainStkO + STKO_HS;
SET_STKO_HDR(MainStkO, StkO_static_info, CC_SUBSUMED);
- STKO_SIZE(MainStkO) = SM_word_stk_size + STKO_VHS;
+ STKO_SIZE(MainStkO) = RTSflags.GcFlags.stksSize + STKO_VHS;
+ STKO_SpB(MainStkO) = STKO_SuB(MainStkO) = STKO_BSTK_BOT(MainStkO) + BREL(1);
+ STKO_SpA(MainStkO) = STKO_SuA(MainStkO) = STKO_ASTK_BOT(MainStkO) + AREL(1);
STKO_LINK(MainStkO) = Nil_closure;
STKO_RETURN(MainStkO) = NULL;
-#else
- stks_space = (P_) xmalloc(SM_word_stk_size * sizeof(W_));
+
+ ASSERT(sanityChk_StkO(MainStkO));
#endif
}
+
# if STACK_CHECK_BY_PAGE_FAULT
- unmapMiddleStackPage((char *) stks_space, SM_word_stk_size * sizeof(W_));
+ unmapMiddleStackPage((char *) stks_space, RTSflags.GcFlags.stksSize * sizeof(W_));
# endif
/* Initialise Stack Info and pointers */
- stackInfo.botA = STK_A_FRAME_BASE(stks_space, SM_word_stk_size);
- stackInfo.botB = STK_B_FRAME_BASE(stks_space, SM_word_stk_size);
+ stackInfo.botA = STK_A_FRAME_BASE(stks_space, RTSflags.GcFlags.stksSize);
+ stackInfo.botB = STK_B_FRAME_BASE(stks_space, RTSflags.GcFlags.stksSize);
MAIN_SuA = MAIN_SpA = stackInfo.botA + AREL(1);
MAIN_SuB = MAIN_SpB = stackInfo.botB + BREL(1);
- if (SM_trace)
+ if (RTSflags.GcFlags.trace)
fprintf(stderr, "STACK init: botA, spa: 0x%lx, 0x%lx\n botB, spb: 0x%lx, 0x%lx\n",
(W_) stackInfo.botA, (W_) MAIN_SpA, (W_) stackInfo.botB, (W_) MAIN_SpB);
- return 0;
+ return rtsTrue;
}
+
#endif /* not parallel */
\end{code}
INTLIKE_HDR(16) /* MAX_INTLIKE == 16 */
};
-P_ INTLIKE_closures = (P_) __INTLIKE_CLOSURE(0);
+const P_ INTLIKE_closures = (const P_) __INTLIKE_CLOSURE(0);
\end{code}
#define NULL_REG_MAP
#include "SMinternal.h"
-#include "RednCounts.h"
+#include "Ticky.h"
#ifdef HAVE_SYS_TYPES_H
#include <sys/types.h>
static I_ GC_start_faults = 0, GC_end_faults = 0;
char *
-#ifdef __STDC__
ullong_format_string(ullong x, char *s, rtsBool with_commas)
-#else
-ullong_format_string(x, s, with_commas)
- ullong x;
- char *s;
- rtsBool with_commas;
-#endif
{
if (x < (ullong)1000)
sprintf(s, "%ld", (I_)x);
/* Called at the beginning of execution of the program */
/* Writes the command line and inits stats header */
-void stat_init(collector, comment1, comment2)
-char *collector, *comment1, *comment2;
+void
+stat_init(char *collector, char *comment1, char *comment2)
{
- if (SM_statsfile != NULL) {
+ FILE *sf = RTSflags.GcFlags.statsFile;
+
+ if (sf != NULL) {
char temp[BIG_STRING_LEN];
- ullong_format_string( (ullong)SM_word_heap_size*sizeof(W_), temp, rtsTrue/*commas*/);
- fprintf(SM_statsfile, "\nCollector: %s HeapSize: %s (bytes)\n\n", collector, temp);
- if (SM_stats_verbose) {
+ ullong_format_string( (ullong)RTSflags.GcFlags.heapSize*sizeof(W_), temp, rtsTrue/*commas*/);
+ fprintf(sf, "\nCollector: %s HeapSize: %s (bytes)\n\n", collector, temp);
+ if (RTSflags.GcFlags.giveStats) {
#if !defined(HAVE_GETRUSAGE) || irix_TARGET_OS
- fprintf(SM_statsfile, "NOTE: `pagefaults' does nothing!\n");
+ fprintf(sf, "NOTE: `pagefaults' does nothing!\n");
#endif
- fprintf(SM_statsfile,
+ fprintf(sf,
/*######## ####### ####### ##.# ##.## ##.## ####.## ####.## #### ####*/
" Alloc Collect Live Resid GC GC TOT TOT Page Flts %s\n",
comment1);
- fprintf(SM_statsfile,
+ fprintf(sf,
" bytes bytes bytes ency user elap user elap GC MUT %s\n",
comment2);
}
#if defined(GCap) || defined(GCgn)
else {
- fprintf(SM_statsfile,
+ fprintf(sf,
/*######## ####### ##.# ####### ##.# ### ##.## ##.## ##.## ##.## ####.## ####.## #### ####*/
" Alloc Promote Promo Live Resid Minor Minor Minor Major Major TOT TOT Page Flts\n");
- fprintf(SM_statsfile,
+ fprintf(sf,
" bytes bytes ted bytes ency No user elap user elap user elap MUT Major\n");
}
#endif /* generational */
- fflush(SM_statsfile);
+ fflush(sf);
}
}
-
/* Called at the beginning of each GC */
static I_ rub_bell = 0;
void
-stat_startGC(alloc)
- I_ alloc;
+stat_startGC(I_ alloc)
{
+ FILE *sf = RTSflags.GcFlags.statsFile;
+
#if defined(GCap) || defined(GCgn)
- I_ bell = alloc == 0 ? SM_ring_bell : 0;
+ I_ bell = alloc == 0 ? RTSflags.GcFlags.ringBell : 0;
#else /* ! generational */
- I_ bell = SM_ring_bell;
+ I_ bell = RTSflags.GcFlags.ringBell;
#endif /* ! generational */
if (bell) {
}
}
- if (SM_statsfile != NULL) {
+ if (sf != NULL) {
GC_start_time = usertime();
GCe_start_time = elapsedtime();
#if defined(GCap) || defined(GCgn)
- if (SM_stats_verbose || alloc == 0) {
+ if (RTSflags.GcFlags.giveStats || alloc == 0) {
GC_start_faults = pagefaults();
}
#else /* ! generational */
- if (SM_stats_verbose) {
+ if (RTSflags.GcFlags.giveStats) {
GC_start_faults = pagefaults();
}
#endif /* ! generational */
}
}
-
/* Called at the end of each GC */
void
-stat_endGC(alloc, collect, live, comment)
- I_ alloc, collect, live;
- char *comment;
+stat_endGC(I_ alloc, I_ collect, I_ live, char *comment)
{
- if (SM_statsfile != NULL) {
+ FILE *sf = RTSflags.GcFlags.statsFile;
+
+ if (sf != NULL) {
StgDouble time = usertime();
StgDouble etime = elapsedtime();
- if (SM_stats_verbose){
+ if (RTSflags.GcFlags.giveStats) {
I_ faults = pagefaults();
- fprintf(SM_statsfile, "%8ld %7ld %7ld %5.1f%%",
- alloc*sizeof(W_), collect*sizeof(W_), live*sizeof(W_), collect == 0 ? 0.0 : (live / (StgFloat) collect * 100));
- fprintf(SM_statsfile, " %5.2f %5.2f %7.2f %7.2f %4ld %4ld %s\n",
+ fprintf(sf, "%8ld %7ld %7ld %5.1f%%",
+ alloc*sizeof(W_), collect*sizeof(W_), live*sizeof(W_), collect == 0 ? 0.0 : (live / (StgDouble) collect * 100));
+ fprintf(sf, " %5.2f %5.2f %7.2f %7.2f %4ld %4ld %s\n",
(time-GC_start_time),
(etime-GCe_start_time),
time,
comment);
GC_end_faults = faults;
- fflush(SM_statsfile);
+ fflush(sf);
}
#if defined(GCap) || defined(GCgn)
else if(alloc == 0 && collect != 0) {
I_ faults = pagefaults();
- fprintf(SM_statsfile, "%8ld %7ld %5.1f%% %7ld %5.1f%%",
+ fprintf(sf, "%8ld %7ld %5.1f%% %7ld %5.1f%%",
GC_alloc_since_maj*sizeof(W_), (collect - GC_live_maj)*sizeof(W_),
- (collect - GC_live_maj) / (StgFloat) GC_alloc_since_maj * 100,
- live*sizeof(W_), live / (StgFloat) SM_word_heap_size * 100);
- fprintf(SM_statsfile, " %3ld %5.2f %5.2f %5.2f %5.2f %7.2f %7.2f %4ld %4ld\n",
+ (collect - GC_live_maj) / (StgDouble) GC_alloc_since_maj * 100,
+ live*sizeof(W_), live / (StgDouble) RTSflags.GcFlags.heapSize * 100);
+ fprintf(sf, " %3ld %5.2f %5.2f %5.2f %5.2f %7.2f %7.2f %4ld %4ld\n",
GC_min_since_maj, GC_min_time, GCe_min_time,
(time-GC_start_time),
(etime-GCe_start_time),
);
GC_end_faults = faults;
- fflush(SM_statsfile);
+ fflush(sf);
}
#endif /* generational */
}
}
-
/* Called at the end of execution -- to print a summary of statistics */
void
-stat_exit(alloc)
- I_ alloc;
+stat_exit(I_ alloc)
{
- if (SM_statsfile != NULL){
+ FILE *sf = RTSflags.GcFlags.statsFile;
+
+ if (sf != NULL){
char temp[BIG_STRING_LEN];
StgDouble time = usertime();
StgDouble etime = elapsedtime();
- if (SM_stats_verbose) {
- fprintf(SM_statsfile, "%8ld\n\n", alloc*sizeof(W_));
+ if (RTSflags.GcFlags.giveStats) {
+ fprintf(sf, "%8ld\n\n", alloc*sizeof(W_));
}
#if defined(GCap) || defined (GCgn)
else {
- fprintf(SM_statsfile, "%8ld %7.7s %6.6s %7.7s %6.6s",
+ fprintf(sf, "%8ld %7.7s %6.6s %7.7s %6.6s",
(GC_alloc_since_maj + alloc)*sizeof(W_), "", "", "", "");
- fprintf(SM_statsfile, " %3ld %5.2f %5.2f\n\n",
+ fprintf(sf, " %3ld %5.2f %5.2f\n\n",
GC_min_since_maj, GC_min_time, GCe_min_time);
}
GC_min_no += GC_min_since_maj;
GCe_tot_time += GCe_min_time;
GC_tot_alloc += (ullong) (GC_alloc_since_maj + alloc);
ullong_format_string(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/);
- fprintf(SM_statsfile, "%11s bytes allocated in the heap\n", temp);
+ fprintf(sf, "%11s bytes allocated in the heap\n", temp);
if ( ResidencySamples > 0 ) {
ullong_format_string(MaxResidency*sizeof(W_), temp, rtsTrue/*commas*/);
- fprintf(SM_statsfile, "%11s bytes maximum residency (%.1f%%, %ld sample(s))\n",
+ fprintf(sf, "%11s bytes maximum residency (%.1f%%, %ld sample(s))\n",
temp,
- MaxResidency / (StgFloat) SM_word_heap_size * 100,
+ MaxResidency / (StgDouble) RTSflags.GcFlags.heapSize * 100,
ResidencySamples);
}
- fprintf(SM_statsfile, "%11ld garbage collections performed (%ld major, %ld minor)\n\n",
+ fprintf(sf, "%11ld garbage collections performed (%ld major, %ld minor)\n\n",
GC_maj_no + GC_min_no, GC_maj_no, GC_min_no);
#else /* ! generational */
GC_tot_alloc += (ullong) alloc;
ullong_format_string(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/);
- fprintf(SM_statsfile, "%11s bytes allocated in the heap\n", temp);
+ fprintf(sf, "%11s bytes allocated in the heap\n", temp);
if ( ResidencySamples > 0 ) {
ullong_format_string(MaxResidency*sizeof(W_), temp, rtsTrue/*commas*/);
- fprintf(SM_statsfile, "%11s bytes maximum residency (%.1f%%, %ld sample(s))\n",
+ fprintf(sf, "%11s bytes maximum residency (%.1f%%, %ld sample(s))\n",
temp,
- MaxResidency / (StgFloat) SM_word_heap_size * 100,
+ MaxResidency / (StgDouble) RTSflags.GcFlags.heapSize * 100,
ResidencySamples);
}
- fprintf(SM_statsfile, "%11ld garbage collections performed\n\n", GC_maj_no);
+ fprintf(sf, "%11ld garbage collections performed\n\n", GC_maj_no);
#endif /* ! generational */
- fprintf(SM_statsfile, " INIT time %6.2fs (%6.2fs elapsed)\n",
+ fprintf(sf, " INIT time %6.2fs (%6.2fs elapsed)\n",
InitUserTime, InitElapsedTime);
- fprintf(SM_statsfile, " MUT time %6.2fs (%6.2fs elapsed)\n",
+ fprintf(sf, " MUT time %6.2fs (%6.2fs elapsed)\n",
time - GC_tot_time - InitUserTime,
etime - GCe_tot_time - InitElapsedTime);
- fprintf(SM_statsfile, " GC time %6.2fs (%6.2fs elapsed)\n",
+ fprintf(sf, " GC time %6.2fs (%6.2fs elapsed)\n",
GC_tot_time, GCe_tot_time);
- fprintf(SM_statsfile, " Total time %6.2fs (%6.2fs elapsed)\n\n",
+ fprintf(sf, " Total time %6.2fs (%6.2fs elapsed)\n\n",
time, etime);
- fprintf(SM_statsfile, " %%GC time %5.1f%% (%.1f%% elapsed)\n\n",
+ fprintf(sf, " %%GC time %5.1f%% (%.1f%% elapsed)\n\n",
GC_tot_time*100./time, GCe_tot_time*100./etime);
ullong_format_string((ullong)(GC_tot_alloc*sizeof(W_)/(time - GC_tot_time)), temp, rtsTrue/*commas*/);
- fprintf(SM_statsfile, " Alloc rate %s bytes per MUT second\n\n", temp);
+ fprintf(sf, " Alloc rate %s bytes per MUT second\n\n", temp);
- fprintf(SM_statsfile, " Productivity %5.1f%% of total user, %.1f%% of total elapsed\n\n",
+ fprintf(sf, " Productivity %5.1f%% of total user, %.1f%% of total elapsed\n\n",
(time - GC_tot_time - InitUserTime) * 100. / time,
(time - GC_tot_time - InitUserTime) * 100. / etime);
- fflush(SM_statsfile);
- fclose(SM_statsfile);
+ fflush(sf);
+ fclose(sf);
}
}
-
\end{code}
}
if (mprotect(middle, pagesize, PROT_NONE) == -1) {
perror("mprotect");
- exit(1);
+ EXIT(EXIT_FAILURE);
}
if (install_segv_handler()) {
fprintf(stderr, "Can't install SIGSEGV handler for stack overflow check.\n");
#define IHaveSubdirs
-SUBDIRS = hp2ps \
- hscpp \
- unlit \
- hstags \
- mkdependHS \
- parallel \
- ugen \
- stat2resid
+SUBDIRS = heap-view \
+ hp2ps \
+ hscpp \
+ hstags \
+ mkdependHS \
+ parallel \
+ stat2resid \
+ ugen \
+ unlit
--- /dev/null
+Started 29/11/93:
+
+> module Main where
+> import PreludeGlaST
+> import LibSystem
+
+Program to draw a graph of last @n@ pieces of data from standard input
+continuously.
+
+> n :: Int
+> n = 40
+
+> max_sample :: Int
+> max_sample = 100
+
+> screen_size :: Int
+> screen_size = 200
+
+Version of grapher that can handle the output of ghc's @+RTS -Sstderr@
+option.
+
+Nice variant would be to take a list of numbers from the commandline
+and display several graphs at once.
+
+> main :: IO ()
+> main =
+> getArgs >>= \ r ->
+> case r of
+> [select] ->
+> let selection = read select
+> in
+> xInitialise [] screen_size screen_size >>
+> hGetContents stdin >>= \ input ->
+> graphloop2 (parseGCData selection input) []
+> _ ->
+> error "usage: graph <number in range 0..17>\n"
+
+The format of glhc18's stderr stuff is:
+
+-- start of example (view in 120 column window)
+graph +RTS -Sstderr -H500
+
+Collector: APPEL HeapSize: 500 (bytes)
+
+ Alloc Collect Live Resid GC GC TOT TOT Page Flts No of Roots Caf Mut- Old Collec Resid
+ bytes bytes bytes ency user elap user elap GC MUT Astk Bstk Reg No able Gen tion %heap
+ 248 248 60 24.2% 0.00 0.04 0.05 0.23 1 1 1 0 0 1 0 0 Minor
+-- end of example
+ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
+
+That is: 6 header lines followed by 17-18 columns of integers,
+percentages, floats and text.
+
+The scaling in the following is largely based on guesses about likely
+values - needs tuned.
+
+@gcParsers@ is a list of functions which parse the corresponding
+column and attempts to scale the numbers into the range $0.0 .. 1.0$.
+(But may return a number avove $1.0$ which graphing part will scale to
+fit screen...)
+
+(Obvious optimisation - replace by list of scaling information!)
+
+(Obvious improvement - return (x,y) pair based on elapsed (or user) time.)
+
+> gcParsers :: [ String -> Float ]
+> gcParsers = [ heap, heap, heap, percent, time, time, time, time, flts, flts, stk, stk, reg, caf, caf, heap, text, percent ]
+> where
+> heap = scale 100000.0 . fromInt . check 0 . readDec
+> stk = scale 25000.0 . fromInt . check 0 . readDec
+> int = scale 1000.0 . fromInt . check 0 . readDec
+> reg = scale 10.0 . fromInt . check 0 . readDec
+> caf = scale 100.0 . fromInt . check 0 . readDec
+> flts = scale 100.0 . fromInt . check 0 . readDec
+> percent = scale 100.0 . check 0.0 . readFloat
+> time = scale 20.0 . check 0.0 . readFloat
+> text s = 0.0
+
+> check :: a -> [(a,String)] -> a
+> check error_value parses =
+> case parses of
+> [] -> error_value
+> ((a,s):_) -> a
+
+> scale :: Float -> Float -> Float
+> scale max n = n / max
+
+> parseGCData :: Int -> String -> [Float]
+> parseGCData column input =
+> map ((gcParsers !! column) . (!! column) . words) (drop 6 (lines input))
+
+Hmmm, how to add logarithmic scaling neatly? Do I still need to?
+
+Note: unpleasant as it is, the code cannot be simplified to something
+like the following. The problem is that the graph won't start to be
+drawn until the first @n@ values are available. (Is there also a
+danger of clearing the screen while waiting for the next input value?)
+A possible alternative solution is to keep count of how many values
+have actually been received.
+
+< graphloop2 :: [Float] -> [Float] -> IO ()
+< graphloop2 [] =
+< return ()
+< graphloop2 ys =
+< let ys' = take n ys
+< m = maximum ys'
+< y_scale = (floor m) + 1
+< y_scale' = fromInt y_scale
+< in
+< xCls >>
+< drawScales y_scale >>
+< draw x_coords [ x / y_scale' | x <- ys' ] >>
+< xHandleEvent >>
+< graphloop2 (tail ys)
+
+
+> graphloop2 :: [Float] -> [Float] -> IO ()
+> graphloop2 (y:ys) xs =
+> let xs' = take n (y:xs)
+> m = maximum xs'
+> y_scale = (floor m) + 1
+> y_scale' = fromInt y_scale
+> in
+> xCls >>
+> drawScales y_scale >>
+> draw x_coords [ x / y_scale' | x <- xs' ] >>
+> xHandleEvent >>
+> graphloop2 ys xs'
+> graphloop2 [] xs =
+> return ()
+
+> x_coords :: [Float]
+> x_coords = [ 0.0, 1 / (fromInt n) .. ]
+
+Draw lines specified by coordinates in range (0.0 .. 1.0) onto screen.
+
+> draw :: [Float] -> [Float] -> IO ()
+> draw xs ys = drawPoly (zip xs' (reverse ys'))
+> where
+> xs' = [ floor (x * sz) | x <- xs ]
+> ys' = [ floor ((1.0 - y) * sz) | y <- ys ]
+> sz = fromInt screen_size
+
+> drawPoly :: [(Int, Int)] -> IO ()
+> drawPoly ((x1,y1):(x2,y2):poly) =
+> xDrawLine x1 y1 x2 y2 >>
+> drawPoly ((x2,y2):poly)
+> drawPoly _ = return ()
+
+Draw horizontal line at major points on y-axis.
+
+> drawScales :: Int -> IO ()
+> drawScales y_scale =
+> sequence (map drawScale ys) >>
+> return ()
+> where
+> ys = [ (fromInt i) / (fromInt y_scale) | i <- [1 .. y_scale - 1] ]
+
+> drawScale :: Float -> IO ()
+> drawScale y =
+> let y' = floor ((1.0 - y) * (fromInt screen_size))
+> in
+> xDrawLine 0 y' screen_size y'
+
+>#include "common-bits"
--- /dev/null
+/*----------------------------------------------------------------------*
+ * X from Haskell (PicoX)
+ *
+ * (c) 1993 Andy Gill
+ *
+ *----------------------------------------------------------------------*/
+
+#include <X11/Xlib.h>
+#include <X11/Xutil.h>
+#include <X11/Xatom.h>
+#include <stdio.h>
+#include <strings.h>
+
+/*----------------------------------------------------------------------*/
+
+/* First the X Globals */
+
+Display *MyDisplay;
+int MyScreen;
+Window MyWindow;
+XEvent MyWinEvent;
+GC DrawGC;
+GC UnDrawGC;
+
+/* and the Haskell globals */
+
+typedef struct {
+ int HaskButtons[5];
+ int HaskPointerX,HaskPointerY;
+ int PointMoved;
+} HaskGlobType;
+
+HaskGlobType HaskGlob;
+
+/*----------------------------------------------------------------------*/
+
+/*
+ * Now the access functions into the haskell globals
+ */
+
+int haskGetButtons(int n)
+{
+ return(HaskGlob.HaskButtons[n]);
+}
+
+int haskGetPointerX(void)
+{
+ return(HaskGlob.HaskPointerX);
+}
+
+int haskGetPointerY(void)
+{
+ return(HaskGlob.HaskPointerY);
+}
+
+/*----------------------------------------------------------------------*/
+
+/*
+ *The (rather messy) initiualisation
+ */
+
+haskXBegin(int x,int y,int sty)
+{
+ /*
+ * later include these via interface hacks
+ */
+
+ /* (int argc, char **argv) */
+ int argc = 0;
+ char **argv = 0;
+
+ XSizeHints XHints;
+ int MyWinFG, MyWinBG,tmp;
+
+ if ((MyDisplay = XOpenDisplay("")) == NULL) {
+ fprintf(stderr, "Cannot connect to X server '%s'\n", XDisplayName(""));
+ exit(1);
+ }
+
+ MyScreen = DefaultScreen(MyDisplay);
+
+ MyWinBG = WhitePixel(MyDisplay, MyScreen);
+ MyWinFG = BlackPixel(MyDisplay, MyScreen);
+
+ XHints.x = x;
+ XHints.y = y;
+ XHints.width = x;
+ XHints.height = y;
+ XHints.flags = PPosition | PSize;
+
+ MyWindow =
+ XCreateSimpleWindow(
+ MyDisplay,
+ DefaultRootWindow(MyDisplay),
+ x,y, x, y,
+ 5,
+ MyWinFG,
+ MyWinBG
+ );
+
+ XSetStandardProperties(
+ MyDisplay,
+ MyWindow,
+ "XLib for Glasgow Haskell",
+ "XLib for Glasgow Haskell",
+ None,
+ argv,
+ argc,
+ &XHints
+ );
+
+ /* Create drawing and erasing GC */
+
+ DrawGC = XCreateGC(MyDisplay,MyWindow,0, 0);
+ XSetBackground(MyDisplay,DrawGC,MyWinBG);
+ XSetForeground(MyDisplay,DrawGC,MyWinFG);
+
+ UnDrawGC = XCreateGC(MyDisplay,MyWindow,0, 0);
+ XSetBackground(MyDisplay,UnDrawGC,MyWinFG);
+ XSetForeground(MyDisplay,UnDrawGC,MyWinBG);
+
+ XSetGraphicsExposures(MyDisplay,DrawGC,False);
+ XSetGraphicsExposures(MyDisplay,UnDrawGC,False);
+ XMapRaised(MyDisplay,MyWindow);
+
+ /* the user should be able to choose which are tested for
+ */
+
+ XSelectInput(
+ MyDisplay,
+ MyWindow,
+ ButtonPressMask | ButtonReleaseMask | PointerMotionMask
+ );
+
+ /* later have more drawing styles
+ */
+
+ switch (sty)
+ {
+ case 0:
+ /* Andy, this used to be GXor not much use for Undrawing so I
+ changed it. (Not much use for colour either - see next
+ comment */
+ XSetFunction(MyDisplay,DrawGC,GXcopy);
+ XSetFunction(MyDisplay,UnDrawGC,GXcopy);
+ break;
+ case 1:
+ /* Andy, this can have totally bogus results on a colour screen */
+ XSetFunction(MyDisplay,DrawGC,GXxor);
+ XSetFunction(MyDisplay,UnDrawGC,GXxor);
+ break;
+ default:
+ /* Andy, is this really a good error message? */
+ printf(stderr,"Wrong Argument to XSet function\n");
+ }
+ /*
+ * reset the (Haskell) globals
+ */
+
+ for(tmp=0;tmp<5;tmp++)
+ {
+ HaskGlob.HaskButtons[tmp] = 0;
+ }
+ HaskGlob.HaskPointerX = 0;
+ HaskGlob.HaskPointerY = 0;
+ HaskGlob.PointMoved = 0;
+
+ XFlush(MyDisplay);
+
+}
+
+/*----------------------------------------------------------------------*/
+
+/* Boring X ``Do Something'' functions
+ */
+
+haskXClose(void)
+{
+ XFreeGC( MyDisplay, DrawGC);
+ XFreeGC( MyDisplay, UnDrawGC);
+ XDestroyWindow( MyDisplay, MyWindow);
+ XCloseDisplay( MyDisplay);
+ return(0);
+}
+
+haskXDraw(x,y,x1,y1)
+int x,y,x1,y1;
+{
+ XDrawLine(MyDisplay,
+ MyWindow,
+ DrawGC,
+ x,y,x1,y1);
+ return(0);
+}
+
+
+haskXPlot(c,x,y)
+int c;
+int x,y;
+{
+ XDrawPoint(MyDisplay,
+ MyWindow,
+ (c?DrawGC:UnDrawGC),
+ x,y);
+ return(0);
+}
+
+haskXFill(c,x,y,w,h)
+int c;
+int x, y;
+int w, h;
+{
+ XFillRectangle(MyDisplay,
+ MyWindow,
+ (c?DrawGC:UnDrawGC),
+ x, y, w, h);
+ return(0);
+}
+
+/*----------------------------------------------------------------------*/
+
+ /* This has to be called every time round the loop,
+ * it flushed the buffer and handles input from the user
+ */
+
+haskHandleEvent()
+{
+ XFlush( MyDisplay);
+ while (XEventsQueued( MyDisplay, QueuedAfterReading) != 0) {
+ XNextEvent( MyDisplay, &MyWinEvent);
+ switch (MyWinEvent.type) {
+ case ButtonPress:
+ switch (MyWinEvent.xbutton.button)
+ {
+ case Button1: HaskGlob.HaskButtons[0] = 1; break;
+ case Button2: HaskGlob.HaskButtons[1] = 1; break;
+ case Button3: HaskGlob.HaskButtons[2] = 1; break;
+ case Button4: HaskGlob.HaskButtons[3] = 1; break;
+ case Button5: HaskGlob.HaskButtons[4] = 1; break;
+ }
+ break;
+ case ButtonRelease:
+ switch (MyWinEvent.xbutton.button)
+ {
+ case Button1: HaskGlob.HaskButtons[0] = 0; break;
+ case Button2: HaskGlob.HaskButtons[1] = 0; break;
+ case Button3: HaskGlob.HaskButtons[2] = 0; break;
+ case Button4: HaskGlob.HaskButtons[3] = 0; break;
+ case Button5: HaskGlob.HaskButtons[4] = 0; break;
+ }
+ break;
+ case MotionNotify:
+ HaskGlob.HaskPointerX = MyWinEvent.xmotion.x;
+ HaskGlob.HaskPointerY = MyWinEvent.xmotion.y;
+ HaskGlob.PointMoved = 1;
+ break;
+ default:
+ printf("UNKNOWN INTERUPT ???? (%d) \n",MyWinEvent.type);
+ break;
+ } /*switch*/
+ } /*if*/
+ return(0);
+}
+
+
+/*----------------------------------------------------------------------*/
+
+ /* A function to clear the screen
+ */
+
+haskXCls(void)
+{
+ XClearWindow(MyDisplay,MyWindow);
+}
+
+/*----------------------------------------------------------------------*/
+
+ /* A function to write a string
+ */
+
+haskXDrawString(int x,int y,char *str)
+{
+ return(0);
+/* printf("GOT HERE %s %d %d",str,x,y);
+ XDrawString(MyDisplay,MyWindow,DrawGC,x,y,str,strlen(str));
+*/
+}
+
+/*----------------------------------------------------------------------*/
+
+extern int prog_argc;
+extern char **prog_argv;
+
+haskArgs()
+{
+ return(prog_argc > 1 ? atoi(prog_argv[1]) : 0);
+}
--- /dev/null
+> module Main where
+> import PreludeGlaST
+> import LibSystem
+
+> import Parse
+
+Program to interpret a heap profile.
+
+Started 28/11/93: parsing of profile
+Tweaked 28/11/93: parsing fiddled till it worked and graphical backend added
+
+To be done:
+
+0) think about where I want to go with this
+1) further processing... sorting, filtering, ...
+2) get dynamic display
+3) maybe use widgets
+
+Here's an example heap profile
+
+ JOB "a.out -p"
+ DATE "Fri Apr 17 11:43:45 1992"
+ SAMPLE_UNIT "seconds"
+ VALUE_UNIT "bytes"
+ BEGIN_SAMPLE 0.00
+ SYSTEM 24
+ END_SAMPLE 0.00
+ BEGIN_SAMPLE 1.00
+ elim 180
+ insert 24
+ intersect 12
+ disin 60
+ main 12
+ reduce 20
+ SYSTEM 12
+ END_SAMPLE 1.00
+ MARK 1.50
+ MARK 1.75
+ MARK 1.80
+ BEGIN_SAMPLE 2.00
+ elim 192
+ insert 24
+ intersect 12
+ disin 84
+ main 12
+ SYSTEM 24
+ END_SAMPLE 2.00
+ BEGIN_SAMPLE 2.82
+ END_SAMPLE 2.82
+
+By inspection, the format seems to be:
+
+profile :== header { sample }
+header :== job date { unit }
+job :== "JOB" command
+date :== "DATE" dte
+unit :== "SAMPLE_UNIT" string | "VALUE_UNIT" string
+
+sample :== samp | mark
+samp :== "BEGIN_SAMPLE" time {pairs} "END_SAMPLE" time
+pairs :== identifer count
+mark :== "MARK" time
+
+command :== string
+dte :== string
+time :== float
+count :== integer
+
+But, this doesn't indicate the line structure. The simplest way to do
+this is to treat each line as a single token --- for which the
+following parser is useful:
+
+Special purpose parser that recognises a string if it matches a given
+prefix and returns the remainder.
+
+> prefixP :: String -> P String String
+> prefixP p =
+> itemP `thenP` \ a ->
+> let (p',a') = splitAt (length p) a
+> in if p == p'
+> then unitP a'
+> else zeroP
+
+
+To begin with I want to parse a profile into a list of readings for
+each identifier at each time.
+
+> type Sample = (Float, [(String, Int)])
+
+> type Line = String
+
+
+> profile :: P Line [Sample]
+> profile =
+> header `thenP_`
+> zeroOrMoreP sample
+
+> header :: P Line ()
+> header =
+> job `thenP_`
+> date `thenP_`
+> zeroOrMoreP unit `thenP_`
+> unitP ()
+
+> job :: P Line String
+> job = prefixP "JOB "
+
+> date :: P Line String
+> date = prefixP "DATE "
+
+> unit :: P Line String
+> unit =
+> ( prefixP "SAMPLE_UNIT " )
+> `plusP`
+> ( prefixP "VALUE_UNIT " )
+
+> sample :: P Line Sample
+> sample =
+> samp `plusP` mark
+
+> mark :: P Line Sample
+> mark =
+> prefixP "MARK " `thenP` \ time ->
+> unitP (read time, [])
+
+ToDo: check that @time1 == time2@
+
+> samp :: P Line Sample
+> samp =
+> prefixP "BEGIN_SAMPLE " `thenP` \ time1 ->
+> zeroOrMoreP pair `thenP` \ pairs ->
+> prefixP "END_SAMPLE " `thenP` \ time2 ->
+> unitP (read time1, pairs)
+
+> pair :: P Line (String, Int)
+> pair =
+> prefixP " " `thenP` \ sample_line ->
+> let [identifier,count] = words sample_line
+> in unitP (identifier, read count)
+
+This test works fine
+
+> {-
+> test :: String -> String
+> test str = ppSamples (theP profile (lines str))
+
+> test1 = test example
+
+> test2 :: String -> Dialogue
+> test2 file =
+> readFile file exit
+> (\ hp -> appendChan stdout (test hp) exit
+> done)
+> -}
+
+Inefficient pretty-printer (uses ++ excessively)
+
+> ppSamples :: [ Sample ] -> String
+> ppSamples = unlines . map ppSample
+
+> ppSample :: Sample -> String
+> ppSample (time, samps) =
+> (show time) ++ unwords (map ppSamp samps)
+
+> ppSamp :: (String, Int) -> String
+> ppSamp (identifier, count) = identifier ++ ":" ++ show count
+
+To get the test1 to work in gofer, you need to fiddle with the input
+a bit to get over Gofer's lack of string-parsing code.
+
+> example =
+> "JOB \"a.out -p\"\n" ++
+> "DATE \"Fri Apr 17 11:43:45 1992\"\n" ++
+> "SAMPLE_UNIT \"seconds\"\n" ++
+> "VALUE_UNIT \"bytes\"\n" ++
+> "BEGIN_SAMPLE 0.00\n" ++
+> " SYSTEM 24\n" ++
+> "END_SAMPLE 0.00\n" ++
+> "BEGIN_SAMPLE 1.00\n" ++
+> " elim 180\n" ++
+> " insert 24\n" ++
+> " intersect 12\n" ++
+> " disin 60\n" ++
+> " main 12\n" ++
+> " reduce 20\n" ++
+> " SYSTEM 12\n" ++
+> "END_SAMPLE 1.00\n" ++
+> "MARK 1.50\n" ++
+> "MARK 1.75\n" ++
+> "MARK 1.80\n" ++
+> "BEGIN_SAMPLE 2.00\n" ++
+> " elim 192\n" ++
+> " insert 24\n" ++
+> " intersect 12\n" ++
+> " disin 84\n" ++
+> " main 12\n" ++
+> " SYSTEM 24\n" ++
+> "END_SAMPLE 2.00\n" ++
+> "BEGIN_SAMPLE 2.82\n" ++
+> "END_SAMPLE 2.82"
+
+
+
+
+Hack to let me test this code... Gofer doesn't have integer parsing built in.
+
+> {-
+> read :: String -> Int
+> read s = 0
+> -}
+
+> screen_size = 200
+
+ToDo:
+
+1) the efficiency of finding slices can probably be dramatically
+ improved... if it matters.
+
+2) the scaling should probably depend on the slices used
+
+3) labelling graphs, colour, ...
+
+4) responding to resize events
+
+> main :: IO ()
+> main =
+> getArgs >>= \ r ->
+> case r of
+> filename:idents ->
+> readFile filename >>= \ hp ->
+> let samples = theP profile (lines hp)
+>
+> times = [ t | (t,ss) <- samples ]
+> names = [ n | (t,ss) <- samples, (n,c) <- ss ]
+> counts = [ c | (t,ss) <- samples, (n,c) <- ss ]
+>
+> time = maximum times
+> x_scale = (fromInt screen_size) / time
+>
+> max_count = maximum counts
+> y_scale = (fromInt screen_size) / (fromInt max_count)
+>
+> slices = map (slice samples) idents
+> in
+> xInitialise [] screen_size screen_size >>
+> -- drawHeap x_scale y_scale samples >>
+> sequence (map (drawSlice x_scale y_scale) slices) >>
+> freeze
+> _ -> error "usage: hpView filename identifiers\n"
+
+> freeze :: IO ()
+> freeze =
+> xHandleEvent >>
+> usleep 100 >>
+> freeze
+
+
+Slice drawing stuff... shows profile for each identifier
+
+> slice :: [Sample] -> String -> [(Float,Int)]
+> slice samples ident =
+> [ (t,c) | (t,ss) <- samples, c <- [lookupPairs ss ident 0] ]
+
+> lookupPairs :: Eq a => [(a, b)] -> a -> b -> b
+> lookupPairs ((a', b') : hs) a b =
+> if a == a' then b' else lookupPairs hs a b
+> lookupPairs [] a b = b
+
+> drawSlice :: Float -> Float -> [(Float,Int)] -> IO ()
+> drawSlice x_scale y_scale slc =
+> drawPoly
+> [ (round (x*x_scale), screen_size - (round ((fromInt y)*y_scale))) | (x,y) <- slc ]
+
+> drawPoly :: [(Int, Int)] -> IO ()
+> drawPoly ((x1,y1):(x2,y2):poly) =
+> xDrawLine x1 y1 x2 y2 >>
+> drawPoly ((x2,y2):poly)
+> drawPoly _ = return ()
+
+
+Very simple heap profiler... doesn't do a proper job at all. Good for
+testing.
+
+> drawHeap :: Float -> Float -> [Sample] -> IO ()
+> drawHeap x_scale y_scale samples =
+> sequence (map xBar
+> [ (t*x_scale, (fromInt c)*y_scale)
+> | (t,ss) <- samples, (n,c) <- ss ]) >>
+> return ()
+
+> xBar :: (Float, Float) -> IO ()
+> xBar (x, y) =
+> let {x' = round x; y' = round y}
+> in xDrawLine x' screen_size x' (screen_size - y')
+
+>#include "common-bits"
--- /dev/null
+> module Main where
+> import PreludeGlaST
+> import LibSystem
+
+> import Parse
+
+Program to do continuous heap profile.
+
+Bad News:
+
+ The ghc runtime system writes its heap profile information to a
+ named file (<progname>.hp). The program merrily reads its input
+ from a named file but has no way of synchronising with the program
+ generating the file.
+
+Good News 0:
+
+ You can save the heap profile to a file:
+
+ <progname> <parameters> +RTS -h -i0.1 -RTS
+
+ and then run:
+
+ hpView2 <progname>.hp Main:<functionname>
+
+ This is very like using hp2ps but much more exciting because you
+ never know what's going to happen next :-)
+
+
+Good News 1:
+
+ The prophet Stallman has blessed us with the shell command @mkfifo@
+ (is there a standard Unix version?) which creates a named pipe. If we
+ instead run:
+
+ mkfifo <progname>.hp
+ hpView2 <progname>.hp Main:<functionname> &
+ <progname> <parameters> +RTS -h -i0.1 -RTS
+ rm <progname>.hp
+
+ Good Things happen.
+
+ NB If you don't delete the pipe, Bad Things happen: the program
+ writes profiling info to the pipe until the pipe fills up then it
+ blocks...
+
+
+Right, on with the program:
+
+Here's an example heap profile
+
+ JOB "a.out -p"
+ DATE "Fri Apr 17 11:43:45 1992"
+ SAMPLE_UNIT "seconds"
+ VALUE_UNIT "bytes"
+ BEGIN_SAMPLE 0.00
+ SYSTEM 24
+ END_SAMPLE 0.00
+ BEGIN_SAMPLE 1.00
+ elim 180
+ insert 24
+ intersect 12
+ disin 60
+ main 12
+ reduce 20
+ SYSTEM 12
+ END_SAMPLE 1.00
+ MARK 1.50
+ MARK 1.75
+ MARK 1.80
+ BEGIN_SAMPLE 2.00
+ elim 192
+ insert 24
+ intersect 12
+ disin 84
+ main 12
+ SYSTEM 24
+ END_SAMPLE 2.00
+ BEGIN_SAMPLE 2.82
+ END_SAMPLE 2.82
+
+In HpView.lhs, I had a fancy parser to handle all this - but it was
+immensely inefficient. We can produce something a lot more efficient
+and robust very easily by noting that the only lines we care about
+have precisely two entries on them.
+
+> type Line = String
+> type Word = String
+> type Sample = (Float, [(String, Int)])
+
+> parseProfile :: [[Word]] -> [Sample]
+> parseProfile [] = []
+> parseProfile ([keyword, time]:lines) | keyword == "BEGIN_SAMPLE" =
+> let (sample,rest) = parseSample lines
+> in
+> (read time, sample) : parseProfile rest
+> parseProfile (_:xs) = parseProfile xs
+
+> parseSample :: [[Word]] -> ([(String,Int)],[[Word]])
+> parseSample ([word, count]:lines) =
+> if word == "END_SAMPLE"
+> then ([], lines)
+> else let (samples, rest) = parseSample lines
+> in ( (word, read count):samples, rest )
+> parseSample duff_lines = ([],duff_lines)
+
+> screen_size = 200
+
+> main :: IO ()
+> main =
+> getArgs >>= \ r ->
+> case r of
+> [filename, ident] ->
+> xInitialise [] screen_size screen_size >>
+> readFile filename >>= \ hp ->
+> let samples = parseProfile (map words (lines hp))
+> totals = [ sum [ s | (_,s) <- ss ] | (t,ss) <- samples ]
+>
+> ts = map scale totals
+> is = map scale (slice samples ident)
+> in
+> graphloop2 (is, []) (ts, [])
+> _ -> error "usage: hpView2 file identifier\n"
+
+For the example I'm running this on, the following scale does nicely.
+
+> scale :: Int -> Float
+> scale n = (fromInt n) / 10000.0
+
+Slice drawing stuff... shows profile for each identifier (Ignores time
+info in this version...)
+
+> slice :: [Sample] -> String -> [Int]
+> slice samples ident =
+> [ c | (t,ss) <- samples, c <- [lookupPairs ss ident 0] ]
+
+> lookupPairs :: Eq a => [(a, b)] -> a -> b -> b
+> lookupPairs ((a', b') : hs) a b =
+> if a == a' then b' else lookupPairs hs a b
+> lookupPairs [] a b = b
+
+Number of samples to display on screen
+
+> n :: Int
+> n = 40
+
+Graph-drawing loop. Get's the data for the particular identifier and
+the total usage, scales to get total to fit screen and draws them.
+
+> graphloop2 :: ([Float], [Float]) -> ([Float], [Float]) -> IO ()
+> graphloop2 (i:is,is') (t:ts, ts') =
+> let is'' = take n (i:is')
+> ts'' = take n (t:ts')
+>
+> -- scaling information:
+> m = maximum ts''
+> y_scale = (floor m) + 1
+> y_scale' = fromInt y_scale
+> in
+> xCls >>
+> drawScales y_scale >>
+> draw x_coords [ x / y_scale' | x <- is'' ] >>
+> draw x_coords [ x / y_scale' | x <- ts'' ] >>
+> xHandleEvent >>
+> graphloop2 (is,is'') (ts, ts'')
+> graphloop2 _ _ =
+> return ()
+
+> x_coords :: [Float]
+> x_coords = [ 0.0, 1 / (fromInt n) .. ]
+
+Note: unpleasant as it is, the code cannot be simplified to something
+like the following (which has scope for changing draw to take a list
+of pairs). The problem is that the graph won't start to be drawn
+until the first @n@ values are available. (Is there also a danger of
+clearing the screen while waiting for the next input value?) A
+possible alternative solution is to keep count of how many values have
+actually been received.
+
+< graphloop2 :: [Float] -> [Float] -> IO ()
+< graphloop2 [] =
+< return ()
+< graphloop2 ys =
+< let ys' = take n ys
+< m = maximum ys'
+< y_scale = (floor m) + 1
+< y_scale' = fromInt y_scale
+< in
+< xCls >>
+< drawScales y_scale >>
+< draw x_coords [ x / y_scale' | x <- ys' ] >>
+< xHandleEvent >>
+< graphloop2 (tail ys)
+
+Draw lines specified by coordinates in range (0.0 .. 1.0) onto screen.
+
+> draw :: [Float] -> [Float] -> IO ()
+> draw xs ys = drawPoly (zip xs' (reverse ys'))
+> where
+> xs' = [ floor (x * sz) | x <- xs ]
+> ys' = [ floor ((1.0 - y) * sz) | y <- ys ]
+> sz = fromInt screen_size
+
+> drawPoly :: [(Int, Int)] -> IO ()
+> drawPoly ((x1,y1):(x2,y2):poly) =
+> xDrawLine x1 y1 x2 y2 >>
+> drawPoly ((x2,y2):poly)
+> drawPoly _ = return ()
+
+Draw horizontal line at major points on y-axis.
+
+> drawScales :: Int -> IO ()
+> drawScales y_scale =
+> sequence (map drawScale ys) >>
+> return ()
+> where
+> ys = [ (fromInt i) / (fromInt y_scale) | i <- [1 .. y_scale - 1] ]
+
+> drawScale :: Float -> IO ()
+> drawScale y =
+> let y' = floor ((1.0 - y) * (fromInt screen_size))
+> in
+> xDrawLine 0 y' screen_size y'
+
+>#include "common-bits"
--- /dev/null
+PROGRAMS = graph hpView hpView2
+
+OBJS_graph = Graph.o HaskXLib.o
+OBJS_hpView = HpView.o Parse.o HaskXLib.o
+OBJS_hpView2 = HpView2.o Parse.o HaskXLib.o
+
+HC_OPTS = -hi-diffs -fglasgow-exts -fhaskell-1.3 -O -L/usr/X11/lib -cpp
+CC_OPTS = -ansi -I/usr/X11/include
+
+HaskellSuffixRules()
+
+all :: $(PROGRAMS)
+
+BuildPgmFromHaskellModules(graph, $(OBJS_graph), -lX11,)
+BuildPgmFromHaskellModules(hpView, $(OBJS_hpView), -lX11,)
+BuildPgmFromHaskellModules(hpView2,$(OBJS_hpView2),-lX11,)
+
+HaskXLib.o : HaskXLib.c
+ $(CC) -c $(CFLAGS) HaskXLib.c
+
+HaskellDependTarget(Graph.lhs HpView.lhs HpView2.lhs Parse.lhs)
--- /dev/null
+To: partain@dcs.gla.ac.uk
+cc: areid@dcs.gla.ac.uk, andy@dcs.gla.ac.uk
+Subject: Heap profiling programs
+Date: Thu, 09 Dec 93 17:33:09 +0000
+From: Alastair Reid <areid@dcs.gla.ac.uk>
+
+
+I've hacked up a couple of programs which it might be worth putting in
+the next ghc distribution. They are:
+
+graph:
+
+ Draws a continuous graph of any one column of the statistics
+ produced using the "+RTS -Sstderr" option.
+
+ I'm not convinced this is astonishingly useful since I'm yet to
+ learn anything useful from (manually) examining these statistics.
+ (Although I do vaguely remember asking Patrick if the heap profiler
+ could do stack profiles too.)
+
+ A typical usage is:
+
+ slife 2 Unis/gardenofeden +RTS -Sstderr -H1M -RTS |& graph 2
+
+ which draws a graph of the third column (ie column 2!) of the
+ stats.
+
+ (btw is there a neater way of connecting stderr to graph's stdin?)
+
+hpView2:
+
+ Draws a continuous graph of the statistics reported by the "+RTS -h"
+ option.
+
+ Since I understand what the figures mean, this seems to be the more
+ useful program.
+
+ A typical usage is:
+
+ mkfifo slife.hp
+ hpView2 slife.hp Main:mkQuad &
+ slife 2 Unis/gardenofeden +RTS -h -i0.1 -RTS
+ rm slife.hp
+
+ which draws a graph of the total heap usage and the usage for Main:mkQuad.
+
+
+Minor problems:
+
+The code is a gross hack... but it works. (Maybe distribute in rot13
+format so that you don't get accidentally get exposed to obscene code
+:-))
+
+The code uses a variant of Andy's picoXlibrary (which he was talking
+about releasing but maybe isn't ready to do yet.)
+
+Also, there are lots of obvious extensions etc which could be made but
+haven't yet... (The major one is being able to set the initial
+scale-factor for displaying the graphs or being able to graph several
+stats at once without having to tee.)
+
+
+Hope you find them interesting.
+
+Alastair
+
+ps Code is in ~areid/hask/Life and should be readable/executable.
--- /dev/null
+CC=gcc
+GLHC18 = glhc18
+GLHC19 = /users/fp/partain/bin/sun4/glhc
+HC= ghc -hi-diffs -fglasgow-exts -fhaskell-1.3
+HC_FLAGS = -O -prof -auto-all
+#HC_FLAGS = -O
+LIBS=-lX11
+FILES2 = Life2.o HaskXLib.o
+FILESS = LifeWithStability.o HaskXLib.o
+FILES = Life.o HaskXLib.o
+
+all : hpView hpView2
+
+# ADR's heap profile viewer
+hpView: HpView.o Parse.o HaskXLib.o
+ $(HC) -o hpView $(HC_FLAGS) HpView.o Parse.o HaskXLib.o $(LIBS) -L/usr/X11/lib
+clean::
+ rm -f hpView
+
+# ADR's continuous heap profile viewer (handles output of -p)
+hpView2: HpView2.o Parse.o HaskXLib.o
+ $(HC) -o hpView2 $(HC_FLAGS) HpView2.o Parse.o HaskXLib.o $(LIBS) -L/usr/X11/lib
+clean::
+ rm -f hpView2
+
+
+# ADR's continuous graph program (handles output of -Sstderr)
+graph: Graph.o HaskXLib.o
+ $(HC) -o graph $(HC_FLAGS) Graph.o HaskXLib.o $(LIBS) -L/usr/X11/lib
+clean::
+ rm -f graph
+
+# ADR's continuous graph program (part of heap profile viewer) that
+# crashes the compiler
+bugGraph: bugGraph.o HaskXLib.o
+ $(HC) -o bugGraph $(HC_FLAGS) bugGraph.o HaskXLib.o $(LIBS) -L/usr/X11/lib
+clean::
+ rm -f bugGraph
+
+%.o:%.c
+ $(CC) -c -ansi -traditional -g -I/usr/X11/include/ $< $(INC)
+
+%.o:%.lhs
+ $(HC) $(HC_FLAGS) -c $< $(INC)
+
+clean::
+ rm -f core *.o *% #*
+ rm -f *.hc
--- /dev/null
+> module Parse where
+
+The Parser monad in "Comprehending Monads"
+
+> infixr 9 `thenP`
+> infixr 9 `thenP_`
+> infixr 9 `plusP`
+
+> type P t a = [t] -> [(a,[t])]
+
+> unitP :: a -> P t a
+> unitP a = \i -> [(a,i)]
+
+> thenP :: P t a -> (a -> P t b) -> P t b
+> m `thenP` k = \i0 -> [(b,i2) | (a,i1) <- m i0, (b,i2) <- k a i1]
+
+> thenP_ :: P t a -> P t b -> P t b
+> m `thenP_` k = \i0 -> [(b,i2) | (a,i1) <- m i0, (b,i2) <- k i1]
+
+zeroP is the parser that always fails to parse its input
+
+> zeroP :: P t a
+> zeroP = \i -> []
+
+plusP combines two parsers in parallel
+(called "alt" in "Comprehending Monads")
+
+> plusP :: P t a -> P t a -> P t a
+> a1 `plusP` a2 = \i -> (a1 i) ++ (a2 i)
+
+itemP is the parser that parses a single token
+(called "next" in "Comprehending Monads")
+
+> itemP :: P t t
+> itemP = \i -> [(head i, tail i) | not (null i)]
+
+force successful parse
+
+> cutP :: P t a -> P t a
+> cutP p = \u -> let l = p u in if null l then [] else [head l]
+
+find all complete parses of a given string
+
+> useP :: P t a -> [t] -> [a]
+> useP m = \x -> [ a | (a,[]) <- m x ]
+
+find first complete parse
+
+> theP :: P t a -> [t] -> a
+> theP m = head . (useP m)
+
+
+Some standard parser definitions
+
+mapP applies f to all current parse trees
+
+> mapP :: (a -> b) -> P t a -> P t b
+> f `mapP` m = m `thenP` (\a -> unitP (f a))
+
+filter is the parser that parses a single token if it satisfies a
+predicate and fails otherwise.
+
+> filterP :: (a -> Bool) -> P t a -> P t a
+> p `filterP` m = m `thenP` (\a -> (if p a then unitP a else zeroP))
+
+lit recognises literals
+
+> litP :: Eq t => t -> P t ()
+> litP t = ((==t) `filterP` itemP) `thenP` (\c -> unitP () )
+
+> showP :: (Text a) => P t a -> [t] -> String
+> showP m xs = show (theP m xs)
+
+
+Simon Peyton Jones adds some useful operations:
+
+> zeroOrMoreP :: P t a -> P t [a]
+> zeroOrMoreP p = oneOrMoreP p `plusP` unitP []
+
+> oneOrMoreP :: P t a -> P t [a]
+> oneOrMoreP p = seq p
+> where seq p = p `thenP` (\a ->
+> (seq p `thenP` (\as -> unitP (a:as)))
+> `plusP`
+> unitP [a] )
+
+> oneOrMoreWithSepP :: P t a -> P t b -> P t [a]
+> oneOrMoreWithSepP p1 p2 = seq1 p1 p2
+> where seq1 p1 p2 = p1 `thenP` (\a -> seq2 p1 p2 a `plusP` unitP [a])
+> seq2 p1 p2 a = p2 `thenP` (\_ ->
+> seq1 p1 p2 `thenP` (\as -> unitP (a:as) ))
+
--- /dev/null
+@HpView.lhs@ is a very primitive heap profile viewer written in
+Haskell. It feeds off the same files as hp2ps. It needs a lot of
+tidying up and would be far more useful as a continuous display.
+(It's in this directory `cos there happens to be a heap profile here
+and I couldn't be bothered setting up a new directory, Makefile, etc.)
+
+@Graph.lhs@ is a continuous heap viewer that "parses" the output of
+the +RTS -Sstderr option. Typical usage:
+
+ slife 1 r4 +RTS -Sstderr |& graph 2
+
+(You might also try
+
+ cat data | graph 2
+
+ to see it in action on some sample data.
+)
+
+Things to watch:
+
+ 1) Scaling varies from column to column - consult the source.
+
+ 2) The horizontal scale is not time - it is garbage collections.
+
+ 3) The graph is of the (n+1)st column of the -Sstderr output.
+
+ The data is not always incredibly useful: For example, when using
+ the (default) Appel 2-space garbage collector, the 3rd column
+ displays the amount of "live" data in the minor space. A program
+ with a constant data usage will appear to have a sawtooth usage
+ as minor data gradually transfers to the major space and then,
+ suddenly, all gets transferred back at major collections.
+ Decreasing heap size decreases the size of the minor collections
+ and increases major collections exaggerating the sawtooth.
+
+ 4) The program is not as robust as it might be.
+
+
+@HpView2.lhs@ is the result of a casual coupling of @Graph.lhs@ and
+@HpView.lhs@ which draws continuous graphs of the heap consisting of:
+total usage and usage by one particular cost centre. For example:
+
+ mkfifo slife.hp
+ hpView2 slife.hp Main:mkQuad &
+ slife 2 Unis/gardenofeden +RTS -h -i0.1 -RTS
+ rm slife.hp
+
+draws a graph of total usage and usage by the function @mkQuad@.
+
+(You might also try
+
+ hpView2 slife.old-hp Main:mkQuad
+
+ to see it in action on some older data)
+
+The business with named pipes (mkfifo) is a little unfortunate - it
+would be nicer if the Haskell runtime system could output to stderr
+(say) which I could pipe into hpView which could just graph it's stdin
+(like graph does). It's probably worth wrapping the whole thing up in
+a little shell-script.
+
+
--- /dev/null
+ -----------------------------------------------------------------------------
+
+ xInitialise :: [String] -> Int -> Int -> IO ()
+ xInitialise str x y =
+ _ccall_ haskXBegin x y (0::Int) `seqPrimIO`
+ return ()
+
+ xHandleEvent :: IO ()
+ xHandleEvent =
+ _ccall_ haskHandleEvent `thenPrimIO` \ n ->
+ case (n::Int) of
+ 0 -> return ()
+ _ -> error "Unknown Message back from Handle Event"
+
+ xClose :: IO ()
+ xClose =
+ _ccall_ haskXClose `seqPrimIO`
+ return ()
+
+ xCls :: IO ()
+ xCls =
+ _ccall_ haskXCls `seqPrimIO`
+ return ()
+
+ xDrawLine :: Int -> Int -> Int -> Int -> IO ()
+ xDrawLine x1 y1 x2 y2 =
+ _ccall_ haskXDraw x1 y1 x2 y2 `seqPrimIO`
+ return ()
+
+ ----------------------------------------------------------------
+
+ usleep :: Int -> IO ()
+ usleep t =
+ _ccall_ usleep t `seqPrimIO`
+ return ()
# a de-commenter (not implemented);
# builds up @Depend_lines
print STDERR "Here we go for source file: $sf\n" if $Verbose;
- ($of = $sf) =~ s/\.l?hs$/$Obj_suffix/;
- push(@Depend_lines, "$of : $sf\n");
+ ($bf = $sf) =~ s/\.l?hs$//;
+ push(@Depend_lines, "$bf$Obj_suffix : $sf\n");
+ foreach $suff (@File_suffix) {
+ push(@Depend_lines, "$bf$suff$Obj_suffix : $sf\n");
+ }
# if it's a literate file, .lhs, then we de-literatize it:
if ( $sf !~ /\.lhs$/ ) {
$Makefile = &grab_arg_arg('-f',$1);
} elsif ( /^-o(.*)/ ) {
$Obj_suffix = &grab_arg_arg('-o',$1);
+ } elsif ( /^-s(.*)/ ) {
+ local($suff) = &grab_arg_arg('-s',$1);
+ $File_suffix{$suff} = $suff;
} elsif ( /^-bs(.*)/ ) {
$Begin_magic_str = &grab_arg_arg('-bs',$1) . "\n";
} elsif ( /^-es(.*)/ ) {
push(@Src_files,$_) if ! /^-/;
}
}
+ @File_suffix = sort (keys %File_suffix);
}
sub grab_arg_arg {
# we mangle #include's so they will also leave something
# behind to indicate the dependency on _them_
- print STDERR "sed -e '/^# *include/{p;s/^# *include/!include/;};s/'\\''//g;s/\"//g' $file_to_read | $Cpp $Include_dirs -I$last_seen_dir @Defines |\n" if $Verbose;
+ print STDERR "/usr/bin/sed -e '/^# *include/{p;s/^# *include/!include/;};s/'\\''//g;s/\"//g' $file_to_read | $Cpp $Include_dirs -I$last_seen_dir @Defines |\n" if $Verbose;
- open(SRCFILE, "sed -e '/^# *include/{p;s/^# *include/!include/;};s/'\\''//g;s/\"//g' $file_to_read | $Cpp $Include_dirs -I$last_seen_dir @Defines |")
+ open(SRCFILE, "/usr/bin/sed -e '/^# *include/{p;s/^# *include/!include/;};s/'\\''//g;s/\"//g' $file_to_read | $Cpp $Include_dirs -I$last_seen_dir @Defines |")
|| die "$Pgm: Can't open $file_to_read: $!\n";
while (<SRCFILE>) {
if ($follow_file ne '__syslib__') {
local($int_file);
- ($int_file = $follow_file) =~ s/\.l?hs$/\.hi/;
-
- push(@Depend_lines, "$of : $int_file\n");
+ $int_file = $follow_file;
+ if ( $int_file !~ /\.(l?hs|hi)$/ ) {
+ push(@Depend_lines, "$bf$Obj_suffix : $int_file\n");
+ foreach $suff (@File_suffix) {
+ push(@Depend_lines, "$bf$suff$Obj_suffix : $int_file\n");
+ }
+
+ } else {
+ $int_file =~ s/\.l?hs$//;
+ $int_file =~ s/\.hi$//;
+
+ push(@Depend_lines, "$bf$Obj_suffix : $int_file.hi\n");
+ foreach $suff (@File_suffix) {
+ push(@Depend_lines, "$bf$suff$Obj_suffix : $int_file$suff.hi\n");
+ }
+ }
}
} else {
die "$orig_src_file: Couldn't handle: $_\n";
{
fprintf(fh, "#ifdef __GNUC__\n");
+ /* to satisfy GCC when in really-picky mode: */
+ fprintf(fh, "T%s t%s(%s t);\n", typid, typid, typid);
+ /* the real thing: */
fprintf(fh, "extern __inline__ T%s t%s(%s t)\n{\n\treturn(t -> tag);\n}\n",
typid, typid, typid);
id typid;
tree t; /* of kind 'def'. */
{
+ tree itemlist = gditemlist(t);
+
fprintf(fh, "extern %s mk%s PROTO((", typid, gdid(t));
- genmkprotodekl(gditemlist(t));
+ switch (ttree(itemlist)) {
+ case emitemlist: /* empty list */
+ fprintf(fh, "void");
+ break;
+ default:
+ genmkprotodekl(itemlist);
+ break;
+ }
fprintf(fh, "));\n");
fprintf(fc, "%s mk%s(", typid, gdid(t));
- genmkparamlist(gditemlist(t));
+ switch (ttree(itemlist)) {
+ case emitemlist: /* empty list */
+ fprintf(fc, "void");
+ break;
+ default:
+ genmkparamlist(itemlist);
+ break;
+ }
fprintf(fc, ")\n");
- genmkparamdekl(gditemlist(t));
+
+ genmkparamdekl(itemlist);
+
fprintf(fc, "{\n\tregister struct S%s *pp =\n", gdid(t));
fprintf(fc, "\t\t(struct S%s *) malloc(sizeof(struct S%s));\n",
gdid(t), gdid(t));
fprintf(fc, "\tpp -> tag = %s;\n", gdid(t));
- genmkfillin(gditemlist(t));
+ genmkfillin(itemlist);
fprintf(fc, "\treturn((%s)pp);\n", typid);
fprintf(fc, "}\n");
}
case item:
fprintf(fh, "#ifdef __GNUC__\n");
+ /* to satisfy GCC when in extremely-picky mode: */
+ fprintf(fh, "\n%s *R%s PROTO((struct S%s *));\n",
+ gitemtypid(t), gitemfunid(t), variantid);
+ /* the real thing: */
fprintf(fh, "\nextern __inline__ %s *R%s(struct S%s *t)\n{\n",
gitemtypid(t), gitemfunid(t), variantid);
fprintf(fh, "#ifdef UGEN_DEBUG\n");
$DefaultStderrFile = "$TmpPrefix/no_stderr$$";
@PgmStdoutFile = ();
@PgmStderrFile = ();
-$AltScript = '';
+$PreScript = '';
+$PostScript = '';
$TimeCmd = '';
$StatsFile = "$TmpPrefix/stats$$";
$SysSpecificTiming = '';
/^-o2(.*)/ && do { $out_file = &grab_arg_arg('-o2',$1);
push(@PgmStderrFile, $out_file);
next arg; };
- /^-script(.*)/ && do { $AltScript = &grab_arg_arg('-script',$1);
- @PgmStdoutFile = (); # re-init
- @PgmStderrFile = (); # ditto
- next arg; };
+ /^-prescript(.*)/ && do { $PreScript = &grab_arg_arg('-prescript',$1);
+ next arg; };
+ /^-postscript(.*)/ && do { $PostScript = &grab_arg_arg('-postscript',$1);
+ next arg; };
/^-(ghc|hbc)-timing$/ && do { $SysSpecificTiming = $1;
next arg; };
/^-spix-timing$/ && do { $SysSpecificTiming = 'ghcspix';
$TimingMagic = "-S$StatsFile";
}
-if ($AltScript ne '') {
- local($to_do);
- $to_do = `cat $AltScript`;
- # glue in pgm to run...
- $* = 1;
- $to_do =~ s/^\$1 /$ToRun /;
- &run_something($to_do);
- exit 0;
-# exec "$AltScript $ToRun";
-# print STDERR "Failed to exec!!! $AltScript $ToRun\n";
-# exit 1;
-}
-
$ToRunOrig = $ToRun;
if ( $SpixTiming eq 'yes' ) {
$ToRun .= '.spix';
}
close(SPIXNM); # || die "nm -n $ToRunOrig close failed!\n";
- $SpixifyLine = "spix -o $ToRun -t$FirstSpix,$LastSpix $ToRunOrig";
- $SpixstatsLine = "spixstats -b $TmpPrefix/runtest$$.3 $ToRunOrig > $ToRunOrig.spixstats";
+ $SpixifyLine1 = "spix -o $ToRun -t$FirstSpix,$LastSpix $ToRunOrig";
+ $SpixstatsLine1 = "spixstats -b $TmpPrefix/runtest$$.3 $ToRunOrig > $ToRunOrig.spixstats1";
+ $SpixifyLine2 = "spix -o $ToRun +t$FirstSpix,$LastSpix $ToRunOrig";
+ $SpixstatsLine2 = "spixstats -b $TmpPrefix/runtest$$.3 $ToRunOrig > $ToRunOrig.spixstats2";
+} else {
+ $SpixifyLine1 = '';
+ $SpixstatsLine1 = '';
+ $SpixifyLine2 = '';
+ $SpixstatsLine2 = '';
+}
+
+if ($PreScript ne '') {
+ local($to_do);
+ $PreScriptLines = `cat $PreScript`;
+} else {
+ $PreScriptLines = '';
+}
+
+if ($PostScript ne '') {
+ local($to_do);
+ $PostScriptLines = `cat $PostScript`;
+ $* = 1;
+ $PostScriptLines =~ s#\$o1#$TmpPrefix/runtest$$.1#g;
+ $PostScriptLines =~ s#\$o2#$TmpPrefix/runtest$$.2#g;
} else {
- $SpixifyLine = '';
- $SpixstatsLine = '';
+ $PostScriptLines = '';
}
# OK, so we're gonna do the normal thing...
rm -f $DefaultStdoutFile $DefaultStderrFile
cat /dev/null > $DefaultStdoutFile
cat /dev/null > $DefaultStderrFile
-$SpixifyLine
+$PreScriptLines
+$SpixifyLine1
$TimeCmd /bin/sh -c \'$ToRun $TimingMagic @PgmArgs < $PgmStdinFile 1> $TmpPrefix/runtest$$.1 2> $TmpPrefix/runtest$$.2 3> $TmpPrefix/runtest$$.3\'
progexit=\$?
if [ \$progexit -ne $PgmExitStatus ]; then
echo expected exit status $PgmExitStatus not seen \\; got \$progexit
myexit=1
else
+ $PostScriptLines
hit='NO'
for out_file in @PgmStdoutFile ; do
if cmp -s \$out_file $TmpPrefix/runtest$$.1 ; then
myexit=1
diffsShown=1
fi
-$SpixstatsLine
+$SpixstatsLine1
+
+if [ $SpixTiming = 'yes' -a \$myexit = 0 ] ; then
+ $SpixifyLine2
+ $TimeCmd /bin/sh -c \'$ToRun $TimingMagic @PgmArgs < $PgmStdinFile 1> /dev/null 2> /dev/null 3> $TmpPrefix/runtest$$.3\'
+ $SpixstatsLine2
+fi
+
$(RM) core $ToRunOrig.spix $DefaultStdoutFile $DefaultStderrFile $TmpPrefix/runtest$$.1 $TmpPrefix/runtest$$.2 $TmpPrefix/runtest$$.3
exit \$myexit
EOSCRIPT
}
&process_stats_file();
-&process_spixstats_file() if $SpixTiming eq 'yes';
+&process_spixstats_files() if $SpixTiming eq 'yes';
# print out what we found
if ( $SpixTiming ne 'yes' ) {
print STDERR "<<$SysSpecificTiming: ",
- "$BytesAlloc bytes, $GCs GCs, $MaxResidency bytes residency ($ResidencySamples samples), $InitTime INIT ($InitElapsed elapsed), $MutTime MUT ($MutElapsed elapsed), $GcTime GC ($GcElapsed elapsed)",
+ "$BytesAlloc bytes, $GCs GCs, $AvgResidency/$MaxResidency avg/max bytes residency ($ResidencySamples samples), $InitTime INIT ($InitElapsed elapsed), $MutTime MUT ($MutElapsed elapsed), $GcTime GC ($GcElapsed elapsed)",
" :$SysSpecificTiming>>\n";
} else {
print STDERR "<<$SysSpecificTiming: ",
- "$BytesAlloc bytes, $GCs GCs, $MaxResidency bytes residency ($ResidencySamples samples), $TotalInsns instructions, $LoadInsns loads, $StoreInsns stores, $BranchInsns branches, $OtherInsns others",
+ "$BytesAlloc bytes, $GCs GCs, $AvgResidency/$MaxResidency avg/max bytes residency ($ResidencySamples samples), $TotalInsns[1]/$TotalInsns[2] instructions, $LoadInsns[1]/$LoadInsns[2] loads, $StoreInsns[1]/$StoreInsns[2] stores, $BranchInsns[1]/$BranchInsns[2] branches, $OtherInsns[1]/$OtherInsns[2] others",
" :$SysSpecificTiming>>\n";
}
#NB: nearly the same as in GHC driver's -ghc-timing stuff
open(STATS, $StatsFile) || die "Failed when opening $StatsFile\n";
+ local($tot_live) = 0; # for calculating avg residency
+
while (<STATS>) {
+ $tot_live += $1 if /^\s*\d+\s+\d+\s+\d+\.\d+\%\s+(\d+)\s+\d+\.\d+\%/;
+
$BytesAlloc = $1 if /^\s*([0-9,]+) bytes allocated in the heap/;
if ( /^\s*([0-9,]+) bytes maximum residency .* (\d+) sample/ ) {
}
}
close(STATS) || die "Failed when closing $StatsFile\n";
+ if ( defined($ResidencySamples) && $ResidencySamples > 0 ) {
+ $AvgResidency = int ($tot_live / $ResidencySamples) ;
+ }
} elsif ( $SysSpecificTiming eq 'hbc' ) {
# things we didn't necessarily expect to find
$MaxResidency = 0 unless defined($MaxResidency);
+ $AvgResidency = 0 unless defined($AvgResidency);
$ResidencySamples = 0 unless defined($ResidencySamples);
# a bit of tidying
$GcElapsed =~ s/,//g;
}
-sub process_spixstats_file {
+sub process_spixstats_files { # 2 of them; one for mutator, one for GC
- $TotalInsns = 0;
- $LoadInsns = 0;
- $StoreInsns = 0;
- $BranchInsns= 0;
- $OtherInsns = 0;
+ @TotalInsns = ();
+ @LoadInsns = ();
+ @StoreInsns = ();
+ @BranchInsns= ();
+ @OtherInsns = ();
- open(STATS, "< $ToRunOrig.spixstats") || die "Failed when opening $ToRunOrig.spixstats\n";
- while (<STATS>) {
- last if /^OPCODES \(STATIC\):/; # party over
+ foreach $f (1, 2) {
- next if /^OPCODES \(DYNAMIC\):/;
- next if /^$/;
- next if /^opcode\s+#executed/;
- next if /^SUBTOTAL/;
+ open(STATS, "< $ToRunOrig.spixstats$f") || die "Failed when opening $ToRunOrig.spixstats$f\n";
+ while (<STATS>) {
+ last if /^OPCODES \(STATIC\):/; # party over
- if ( /^ld\S*\s+(\d+)/ ) {
- $LoadInsns += $1;
+ next if /^OPCODES \(DYNAMIC\):/;
+ next if /^$/;
+ next if /^opcode\s+#executed/;
+ next if /^SUBTOTAL/;
- } elsif ( /^st\S*\s+(\d+)/ ) {
- $StoreInsns += $1;
+ if ( /^ld\S*\s+(\d+)/ ) {
+ $LoadInsns[$f] += $1;
- } elsif ( /^(jmpl|call|b\S*)\s+(\d+)/ ) {
- $BranchInsns += $2;
+ } elsif ( /^st\S*\s+(\d+)/ ) {
+ $StoreInsns[$f] += $1;
- } elsif ( /^TOTAL\s+(\d+)/ ) {
- $TotalInsns = $1;
- print STDERR "TotalInsns doesn't match categories total!\n"
- if $TotalInsns !=
- ($LoadInsns + $StoreInsns + $BranchInsns + $OtherInsns);
+ } elsif ( /^(jmpl|call|b\S*)\s+(\d+)/ ) {
+ $BranchInsns[$f] += $2;
- } elsif ( /^\S+\s+(\d+)/ ) {
- $OtherInsns += $1;
+ } elsif ( /^TOTAL\s+(\d+)/ ) {
+ $TotalInsns[$f] = $1;
+ print STDERR "TotalInsns doesn't match categories total!\n"
+ if $TotalInsns[$f] !=
+ ($LoadInsns[$f] + $StoreInsns[$f] + $BranchInsns[$f] + $OtherInsns[$f]);
- } else {
- die "Funny line?? $_";
- }
+ } elsif ( /^\S+\s+(\d+)/ ) {
+ $OtherInsns[$f] += $1;
+
+ } else {
+ die "Funny line?? $_";
+ }
+ }
+ close(STATS) || die "Failed when closing $ToRunOrig.spixstats\n";
}
- close(STATS) || die "Failed when closing $ToRunOrig.spixstats\n";
}