├── .gitignore ├── .travis.yml ├── LICENSE ├── LICENSE_INFO.txt ├── Makefile.in ├── README.md ├── bin └── make-version.sh ├── bootstrap.sh ├── compiler ├── anorm-lazy │ ├── abs-core.sml │ ├── abs-eval.sml │ ├── anorm-lazy-analyze.sml │ ├── anorm-lazy.mlb │ ├── anorm-lazy.sml │ ├── domain.sml │ ├── stats.sml │ ├── strictness.sml │ └── to-abs-core.sml ├── anorm-strict │ ├── anorm-strict-analyze.sml │ ├── anorm-strict-clone.sml │ ├── anorm-strict-closure-convert.sml │ ├── anorm-strict-free-vars.sml │ ├── anorm-strict-layout.sml │ ├── anorm-strict-optimize.sml │ ├── anorm-strict-rewrite.sml │ ├── anorm-strict-utils.sml │ ├── anorm-strict.mlb │ ├── anorm-strict.sml │ └── stats.sml ├── as-to-mil │ ├── as-to-mil.mlb │ ├── ghc-prim.sml │ ├── to-mil.sml │ └── utils.sml ├── back-end │ ├── back-end.mlb │ ├── back-end.sml │ ├── mil-to-pil.sml │ ├── outputter.sml │ ├── pil.sml │ └── runtime.sml ├── ch-to-as │ ├── ch-to-as.mlb │ ├── to-lazy.sml │ └── to-strict.sml ├── common │ ├── chat.sml │ ├── common.mlb │ ├── compare.sml │ ├── config.sml │ ├── dataflow.sml │ ├── dominance.sml │ ├── effect.sml │ ├── fail.sml │ ├── globals.sml │ ├── graph.sml │ ├── identifier.sml │ ├── int-arb.sml │ ├── intr.sml │ ├── locus.sml │ ├── lub.sml │ ├── pass.sml │ ├── path.sml │ ├── rat.sml │ ├── rename.sml │ ├── topo-sort.sml │ ├── try.sml │ ├── tuple.sml │ ├── type-rep.sml │ ├── utils.sml │ ├── vector-instruction.sml │ └── z-coding.sml ├── core-hs │ ├── core-hs.grm │ ├── core-hs.lex │ ├── core-hs.mlb │ ├── core-hs.sml │ ├── ghc-prim-op.sml │ ├── ghc-prim-type.sml │ ├── layout.sml │ ├── link-option.sml │ ├── normalize.sml │ └── parse.sml ├── driver.sml ├── haskell.sml ├── hrc.mlb ├── hrc.sml └── mil │ ├── analyse.sml │ ├── bound-vars.sml │ ├── call-graph.sml │ ├── cfg.sml │ ├── check.sml │ ├── code-copy.sml │ ├── compile.mlb │ ├── compile.sml │ ├── dataflow-analysis.sml │ ├── dependence-analysis.sml │ ├── extended-layout.sml │ ├── fmil.sml │ ├── free-vars.sml │ ├── imil │ ├── block.sml │ ├── both-mil.sml │ ├── common.sml │ ├── def.sml │ ├── enumerate.sml │ ├── func.sml │ ├── global.sml │ ├── imil.mlb │ ├── imil.sml │ ├── instr.sml │ ├── item.sml │ ├── layout.sml │ ├── t.sml │ ├── types.sml │ ├── use.sml │ ├── var.sml │ └── workset.sml │ ├── layout.sml │ ├── loop.sml │ ├── lower │ ├── lower.mlb │ ├── mil-to-core-mil.sml │ └── vector.sml │ ├── mil.mlb │ ├── mil.sml │ ├── name-small-values.sml │ ├── number-instructions.sml │ ├── optimise │ ├── annotated-cg-printer.sml │ ├── branch-remove.sml │ ├── cfg-simplify.sml │ ├── contify.sml │ ├── cse.sml │ ├── double-diamond.sml │ ├── fun-known.sml │ ├── fx-analysis.sml │ ├── inline-aggressive.sml │ ├── inline-leaves.sml │ ├── inline-profile.sml │ ├── inline-rewrite.sml │ ├── inline-small.sml │ ├── iv-cse.sml │ ├── licm.sml │ ├── loop-invert.sml │ ├── optimise.mlb │ ├── rep │ │ ├── analyze.sml │ │ ├── base.sml │ │ ├── dead-code.sml │ │ ├── driver.sml │ │ ├── flatten.sml │ │ ├── flowgraph.sml │ │ ├── node.sml │ │ ├── object.sml │ │ ├── optimize.sml │ │ ├── prep.sml │ │ ├── reconstruct.sml │ │ ├── rep.mlb │ │ ├── rep.sml │ │ ├── seq.sml │ │ ├── show.sml │ │ └── summary.sml │ ├── simple-escape.sml │ ├── simplify.sml │ ├── thunks.sml │ └── vectorize.sml │ ├── p-object-model.sml │ ├── parse.sml │ ├── prims-utils.sml │ ├── prims.sml │ ├── profile.sml │ ├── rename.sml │ ├── rewrite.sml │ ├── shape-analysis.sml │ ├── stats.sml │ ├── stream.sml │ ├── stream2.sml │ ├── transform.sml │ ├── type.sml │ ├── utils.sml │ └── utils2.sml ├── configure.ac ├── doc ├── building-ghc.md └── flrc-pipeline.png ├── hrc-makefile.inc ├── patches ├── ghc-7.6-hrc.patch ├── ghc-Cabal-7.6-hrc.patch ├── ghc-base-7.6-hrc.patch ├── ghc-integer-simple-7.6-hrc.patch ├── ghc-primitive-7.6-hrc.patch ├── ghc-repa-3.2.2.2-hrc.patch └── ghc-vector-7.6-hrc.patch ├── runtime ├── ghc │ ├── Globals.c │ ├── TTY.c │ ├── float.c │ ├── plsr-util.c │ └── thread.c └── include │ └── hrc │ ├── ghc │ ├── Globals.h │ ├── TTY.h │ ├── float.h │ └── thread.h │ ├── pil.h │ ├── plsr-ap-integer.h │ ├── plsr-ap-rational.h │ ├── plsr-finalizer.h │ ├── plsr-flrc-integer.h │ ├── plsr-gc.h │ ├── plsr-gmp-integer-gallocate.h │ ├── plsr-gmp-integer.h │ ├── plsr-integer.h │ ├── plsr-lightweight-thunk.h │ ├── plsr-main.h │ ├── plsr-numeric.h │ ├── plsr-objects.h │ ├── plsr-params.h │ ├── plsr-prims-ghc-longlong.h │ ├── plsr-prims-ghc.h │ ├── plsr-prims-prims.h │ ├── plsr-prims-runtime.h │ ├── plsr-prims-vector-avx.h │ ├── plsr-prims-vector-mic.h │ ├── plsr-prims-vector-sse.h │ ├── plsr-prims-vector.h │ ├── plsr-prims.h │ ├── plsr-ptk-thunk.h │ ├── plsr-rational.h │ ├── plsr-synchronization.h │ ├── plsr-tagged-int32.h │ ├── plsr-thunk.h │ ├── plsr-util.h │ ├── plsr-value.h │ ├── plsr-wpo.h │ └── plsr.h └── sml-lib └── Makefile /.gitignore: -------------------------------------------------------------------------------- 1 | # ignore object files and other c/pillar build related things 2 | *.o 3 | *.obj 4 | *.exp 5 | *.lib 6 | *.pdb 7 | *.suo 8 | root_map.txt 9 | 10 | # ignore emacs save files 11 | *~ 12 | 13 | # ignore executables 14 | *.exe 15 | 16 | # ignore core p files 17 | *.cp 18 | 19 | # ignore .c files unless they are in the runtime directory 20 | *.c 21 | !runtime/ghc/*.c 22 | 23 | #ignore .hi (haskell interface) files 24 | *.hi 25 | 26 | # ignore the frontend build files 27 | build/vc60/frontend-old/Debug/ 28 | build/vc60/frontend-old/frontend-old.plg 29 | 30 | # ignore the regression log and tmp directory 31 | regressions.log 32 | tests/tmp 33 | 34 | runtime/hil.mil 35 | 36 | # Autotools 37 | *.deps 38 | .dirstamp 39 | aclocal.m4 40 | autom4te.cache 41 | config.guess 42 | config.log 43 | config.status 44 | config.sub 45 | configure 46 | depcomp 47 | install-sh 48 | ltmain.sh 49 | missing 50 | stamp-h 51 | stamp-h1 52 | ylwrap 53 | 54 | # / 55 | /Makefile 56 | 57 | # / 58 | /bin/frontend-new 59 | /bin/hrc 60 | 61 | # /compiler 62 | compiler/core-hs/core-hs.grm.desc 63 | compiler/core-hs/core-hs.grm.sig 64 | compiler/core-hs/core-hs.grm.sml 65 | compiler/core-hs/core-hs.lex.sml 66 | compiler/version.sml 67 | 68 | # /runtime 69 | /runtime/Makefile 70 | /runtime/Makefile.in 71 | /runtime/ghc/*.a 72 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | dist: trusty 2 | sudo: required 3 | addons: 4 | apt: 5 | packages: 6 | - mlton-compiler 7 | - mlton-tools 8 | - nasm 9 | before_install: 10 | - date 11 | # Show environment 12 | - lsb_release -a 13 | - ulimit -a 14 | - cat /proc/cpuinfo 15 | - cat /proc/meminfo 16 | - g++ --version 17 | # Download flrc-lib 18 | - cd ${HOME} 19 | - git clone https://github.com/IntelLabs/flrc-lib.git 20 | script: 21 | # Build flrc-lib 22 | - cd ${HOME}/flrc-lib 23 | - sh bootstrap.sh 24 | - ./configure 25 | - make |& grep '^g++' 26 | - sudo make install 27 | # Building flrc 28 | - cd ${TRAVIS_BUILD_DIR} 29 | - sh bootstrap.sh 30 | - ./configure 31 | - make 32 | - sudo make install 33 | after_script: 34 | - date 35 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Redistribution and use in source and binary forms, with or without modification, are permitted 2 | provided that the following conditions are met: 3 | 1. Redistributions of source code must retain the above copyright notice, this list of 4 | conditions and the following disclaimer. 5 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of 6 | conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 7 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 8 | BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 9 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 10 | EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 11 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 12 | OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 13 | IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 14 | 15 | -------------------------------------------------------------------------------- /Makefile.in: -------------------------------------------------------------------------------- 1 | include hrc-makefile.inc 2 | 3 | HRC_PREFIX=@prefix@ 4 | PLATFORM_CPPFLAGS=@PLATFORM_CPPFLAGS@ 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | > :warning: **DISCONTINUATION OF PROJECT** - 2 | > *This project will no longer be maintained by Intel. 3 | > Intel has ceased development and contributions including, but not limited to, maintenance, bug fixes, new releases, or updates, to this project.* 4 | > **Intel no longer accepts patches to this project.** 5 | > *If you have an ongoing need to use this project, are interested in independently developing it, or would like to maintain patches for the open source software community, please create your own fork of this project.* 6 | 7 | 8 | # The Functional Language Research Compiler [![Build Status](https://travis-ci.org/IntelLabs/flrc.svg)](https://travis-ci.org/IntelLabs/flrc) 9 | 10 | The Functional Language Research Compiler (FLRC) was designed to be a general 11 | compiler framework for functional languages. The only supported compiler that 12 | is being released is a Haskell Research Compiler (HRC). The overall compilation 13 | pipeline is pictured in the following diagram: 14 | 15 | ![HRC and FLRC Compilation Pipeline](doc/flrc-pipeline.png) 16 | 17 | ## Installation 18 | 19 | FLRC requires [FLRC-LIB] to be installed prior to its installation. 20 | Other software required are autoconf/automake, pkg-config, [the MLton 21 | compiler][mlton], and a C/C++ compiler. 22 | 23 | All released code has only been tested to work on x86 64-bit Linux distros, 24 | although they were originally written for x86 32-bit Windows. At least 4GB 25 | of free memory is advised for compiling FLRC. 26 | 27 | To install: 28 | 29 | ``` 30 | sh bootstrap.sh 31 | ./configure --prefix=${PREFIX} 32 | make && make install 33 | ``` 34 | 35 | If you had `flrc-lib` installed at a non-standard location, there may be 36 | a pkgconfig error. This can be easily fixed by setting the correct 37 | `PKG_CONFIG_PATH` as follows (before running the `bootstrap.sh` and 38 | `configure` commands again): 39 | 40 | ``` 41 | # With PREFIX already set to where flrc-lib is installed, do: 42 | export PKG_CONFIG_PATH=${PREFIX}/lib/pkgconfig:$PKG_CONFIG_PATH 43 | ``` 44 | 45 | In the process, it will also automatically download a version of MLton 46 | compiler's source to extract some SML libraries. Once the installation 47 | is finished, a binary command `hrc` and some runtime headers and 48 | libraries can be found under the given `${PREFIX}` path. 49 | 50 | ## Usage 51 | 52 | To actually compile a Haskell program, we'll also need a patched version of 53 | GHC. See [Building and Using GHC with HRC](doc/building-ghc.md) for more 54 | information, including how to compile and run [flrc-benchmarks]. 55 | 56 | To get a list of compiler options, call the compiler with any invalid 57 | option (e.g. `-help`). 58 | 59 | For example, to list the flrc options: 60 | 61 | ``` 62 | hrc -help 63 | ``` 64 | 65 | To list the flrc expert options: 66 | 67 | ``` 68 | hrc -expert -help 69 | ``` 70 | 71 | One can also pass runtime options to the executable compiled by HRC. Options 72 | are passed in the form: 73 | 74 | ``` 75 | ./[executable] @PPiler [opts]* -- [normal arguments] 76 | ``` 77 | 78 | These options must come before any program options, and only one `@PPiler` 79 | section is supported. A list of options can be obtained by passing any invalid 80 | option (e.g. -help). Currently, there are options for the number of threads to 81 | run in the futures back end, and to set the initial and max heap size for the 82 | conservative GC. 83 | 84 | ## Questions 85 | 86 | FLRC is open sourced as is. We at Intel Labs are no longer actively working on 87 | this compiler. Please use the issue tracker if you have questions. 88 | 89 | ## Related Publication 90 | 91 | Neal Glew, Tim Sweeney, and Leaf Petersen. 2013. [A multivalued language with a dependent type system](http://dl.acm.org/citation.cfm?doid=2502409.2502412). In Proceedings of the 2013 ACM SIGPLAN workshop on Dependently-typed programming (DTP '13). ACM, New York, NY, USA, 25-36. 92 | 93 | Hai Liu, Neal Glew, Leaf Petersen, and Todd A. Anderson. 2013. [The Intel labs Haskell research compiler](https://dl.acm.org/citation.cfm?id=2503779). In Proceedings of the 2013 ACM SIGPLAN symposium on Haskell (Haskell '13). ACM, New York, NY, USA, 105-116. 94 | 95 | Leaf Petersen, Todd A. Anderson, Hai Liu, and Neal Glew. 2013. [Measuring the Haskell Gap](http://dl.acm.org/citation.cfm?doid=2620678.2620685). In Proceedings of the 25th symposium on Implementation and Application of Functional Languages (IFL '13). ACM, New York, NY, USA, , Pages 61 , 12 pages. 96 | 97 | Leaf Petersen, Dominic Orchard, and Neal Glew. 2013. [Automatic SIMD vectorization for Haskell](http://dl.acm.org/citation.cfm?doid=2500365.2500605). In Proceedings of the 18th ACM SIGPLAN international conference on Functional programming (ICFP '13). ACM, New York, NY, USA, 25-36. 98 | 99 | Neal Glew and Leaf Petersen. 2012. [Type-Preserving Flow Analysis and Interprocedural Unboxing (Extended Version)](https://arxiv.org/abs/1203.1986). Tech Report. 100 | 101 | Leaf Petersen and Neal Glew. 2012. [GC-Safe interprocedural unboxing](http://dl.acm.org/citation.cfm?id=2259242). In Proceedings of the 21st international conference on Compiler Construction (CC'12), Michael O'Boyle (Ed.). Springer-Verlag, Berlin, Heidelberg, 165-184. 102 | 103 | ## License 104 | 105 | This software carries a BSD style license. See [LICENSE_INFO](LICENSE_INFO.txt) for more information. 106 | 107 | 108 | [flrc-benchmarks]: https://github.com/IntelLabs/flrc-benchmarks 109 | [flrc-lib]: https://github.com/IntelLabs/flrc-lib 110 | [mlton]: http://mlton.org 111 | 112 | -------------------------------------------------------------------------------- /bin/make-version.sh: -------------------------------------------------------------------------------- 1 | # Redistribution and use in source and binary forms, with or without modification, are permitted 2 | # provided that the following conditions are met: 3 | # 1. Redistributions of source code must retain the above copyright notice, this list of 4 | # conditions and the following disclaimer. 5 | # 2. Redistributions in binary form must reproduce the above copyright notice, this list of 6 | # conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 7 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 8 | # BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 9 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 10 | # EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 11 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 12 | # OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 13 | # IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 14 | 15 | # Make a version.sml file with brief version and build information for the flrc. 16 | # usage: make-version.sh version outfile 17 | # where: 18 | # version is the flrc version string 19 | # outfile is the filename to put the output into 20 | 21 | version=$1 22 | out=$2 23 | prefix=$3 24 | # Windows hostname outputs a final carriage return 25 | build="`date '+%F %R'` on `hostname | tr -d '\r'`" 26 | 27 | rm -f $out 28 | 29 | echo "structure Version =" >> $out 30 | echo "struct" >> $out 31 | echo " val flrcVersion = \"$version\"" >> $out 32 | echo " val build = \"$build\"" >> $out 33 | echo " val prefix = Path.fromString \"$prefix\"" >> $out 34 | echo "end" >> $out 35 | -------------------------------------------------------------------------------- /bootstrap.sh: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | 3 | aclocal \ 4 | && libtoolize -i \ 5 | && autoconf 6 | -------------------------------------------------------------------------------- /compiler/anorm-lazy/anorm-lazy.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* Copyright (C) Intel Corporation, October 2006 *) 3 | 4 | local 5 | $(SML_LIB)/mlton/sources.mlb 6 | ../common/common.mlb 7 | ../core-hs/core-hs.mlb 8 | anorm-lazy.sml 9 | anorm-lazy-analyze.sml 10 | stats.sml 11 | domain.sml 12 | abs-core.sml 13 | to-abs-core.sml 14 | abs-eval.sml 15 | strictness.sml 16 | in 17 | structure ANormLazy 18 | structure ANormLazyLayout 19 | functor ANormLazyAnalyzeF 20 | structure ANormLazyStats 21 | signature ABS_DOMAIN 22 | structure Pointed 23 | functor AbsCoreF 24 | functor AbsCoreLayoutF 25 | functor ANormLazyToAbsCoreF 26 | functor AbsCoreEvalF 27 | structure ANormLazyStrictness 28 | end 29 | -------------------------------------------------------------------------------- /compiler/anorm-lazy/domain.sml: -------------------------------------------------------------------------------- 1 | (* 2 | * Redistribution and use in source and binary forms, with or without modification, are permitted 3 | * provided that the following conditions are met: 4 | * 1. Redistributions of source code must retain the above copyright notice, this list of 5 | * conditions and the following disclaimer. 6 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 7 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 9 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 10 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 11 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 12 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 13 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 14 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 15 | *) 16 | 17 | (* 18 | * Abstract Domain with bottom, top, function, and tuples. 19 | *) 20 | signature ABS_DOMAIN = 21 | sig 22 | type t 23 | val layout : t -> Layout.t 24 | val top : t 25 | val bottom : t 26 | val tuple : t list -> t 27 | val func : (t -> t) -> t 28 | val isBottom : t -> bool 29 | val isTop : t -> bool 30 | val isTuple : t -> (t list) option 31 | val isFunc : t -> (t -> t) option 32 | val glb : t list -> t 33 | val lub : t list -> t 34 | end 35 | 36 | structure Pointed : ABS_DOMAIN = 37 | struct 38 | datatype t = Bottom | Top | Func of t -> t | Tuple of t list 39 | 40 | val top = Top 41 | val bottom = Bottom 42 | val tuple = fn xs => Tuple xs 43 | val func = fn f => Func f 44 | 45 | fun isBottom Bottom = true 46 | | isBottom _ = false 47 | 48 | fun isTop Top = true 49 | | isTop _ = false 50 | 51 | fun isTuple (Tuple xs) = SOME xs 52 | | isTuple _ = NONE 53 | 54 | fun isFunc (Func f) = SOME f 55 | | isFunc _ = NONE 56 | 57 | val zip = List.zip 58 | 59 | fun lower (Top, x) = x 60 | | lower (x, Top) = x 61 | | lower (Bottom, x) = Bottom 62 | | lower (x, Bottom) = Bottom 63 | | lower (Tuple xs, Tuple ys) = Tuple (List.map (zip (xs, ys), lower)) 64 | | lower (Func f, Func g) = Func (fn x => lower (f x, g x)) 65 | | lower _ = Bottom 66 | 67 | fun upper (Top, x) = Top 68 | | upper (x, Top) = Top 69 | | upper (Bottom, x) = x 70 | | upper (x, Bottom) = x 71 | | upper (Tuple xs, Tuple ys) = Tuple (List.map (zip (xs, ys), upper)) 72 | | upper (Func f, Func g) = Func (fn x => upper (f x, g x)) 73 | | upper _ = Top 74 | 75 | fun glb [] = Fail.fail ("Pointed", "glb", "argument is empty list") 76 | | glb (x::xs) = List.fold (xs, x, lower) 77 | 78 | fun lub [] = Fail.fail ( "Pointed", "lub", "argument is empty list") 79 | | lub (x::xs) = List.fold (xs, x, upper) 80 | 81 | fun layout Top = Layout.str "%top" 82 | | layout Bottom = Layout.str "%bot" 83 | | layout (Func f) = Layout.str "%func" 84 | | layout (Tuple l) = LayoutUtils.sequence ("<", ">", ",") (List.map (l, layout)) 85 | 86 | end 87 | 88 | -------------------------------------------------------------------------------- /compiler/anorm-lazy/stats.sml: -------------------------------------------------------------------------------- 1 | (* HRC *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | signature ANORM_STRICT_STATS = 19 | sig 20 | datatype options = O of {id: string option} 21 | val layout : options -> ANormLazy.t * Config.t -> Layout.t 22 | (* val module : Config.t * ANormLazy.tm * options * ANormLazy.module * Out.t -> unit *) 23 | val program : Config.t * options * ANormLazy.t * Out.t -> unit 24 | end; 25 | 26 | structure ANormLazyStats :> ANORM_STRICT_STATS = 27 | struct 28 | 29 | val passname = "ANormLazyStats" 30 | 31 | structure AL = ANormLazy 32 | structure WS = WordSet 33 | structure I = Identifier 34 | structure L = Layout 35 | 36 | datatype options = O of {id: string option} 37 | 38 | datatype env = E of {config: Config.t, tm : AL.typeManager, options: options} 39 | 40 | val envMk = fn (c, tm, opts) => E {config = c, tm = tm, options = opts} 41 | 42 | val getTM = fn (E { tm = tm, ... }) => tm 43 | 44 | datatype state = S of { 45 | tySet : WS.t ref, 46 | expNodes : int ref, 47 | tyNodes : int ref, 48 | varUses : int ref, 49 | vDefs : int ref 50 | } 51 | 52 | val stateMk = 53 | fn () => 54 | S {tySet = ref WS.empty, expNodes = ref 0, tyNodes = ref 0, varUses = ref 0, vDefs = ref 0} 55 | 56 | val incr = fn r => r := (!r) + 1 57 | 58 | val incrF = fn sel => fn (S r) => incr (sel r) 59 | val incrExpNodes = incrF #expNodes 60 | val incrTyNodes = incrF #tyNodes 61 | val incrVarUses = incrF #varUses 62 | val incrVDefs = incrF #vDefs 63 | val insertTyNode = 64 | fn (S { tySet = tySet, ... }, env, ty) => 65 | tySet := WS.insert (!tySet, TypeRep.hashRepWithManager (getTM env, ty)) 66 | 67 | val variableUse = fn (s, e, _) => incrVarUses s 68 | val analyzeExp = fn (s, e, _) => incrExpNodes s 69 | val analyzeTy = fn (s, e, t) => incrTyNodes s before insertTyNode (s, e, t) 70 | val analyzeVDef = fn (s, e, vd) => incrVDefs s 71 | 72 | structure A = ANormLazyAnalyzeF(type state = state 73 | type env = env 74 | val config = fn (E {config, ...}) => config 75 | val variableBind = NONE 76 | val variableUse = SOME variableUse 77 | val analyzeTy = SOME analyzeTy 78 | val analyzeExp = SOME analyzeExp 79 | val analyzeAlt = NONE 80 | val analyzeVDef = SOME analyzeVDef) 81 | val layoutStats = 82 | fn (s, e, O {id, ...}) => 83 | let 84 | val S {tySet, expNodes, tyNodes, varUses, vDefs} = s 85 | val doOne = fn (s, r) => L.seq [L.str (" Number of " ^ s), Int.layout r] 86 | val l = L.align [doOne ("exp nodes: ", !expNodes), 87 | doOne ("ty nodes: ", !tyNodes), 88 | doOne ("ty nodes (unique): ", WS.size (!tySet)), 89 | doOne ("ty nodes (managed): ", TypeRep.size (getTM e)), 90 | doOne ("var uses: ", !varUses), 91 | doOne ("def bindings: ", !vDefs)] 92 | val l = 93 | case id 94 | of NONE => l 95 | | SOME id => 96 | L.align [L.str ("---------- Stats for: " ^ id), 97 | l, 98 | L.str ("---------- End stats for: " ^ id ^ "\n")] 99 | in l 100 | end 101 | 102 | val layoutMk = 103 | fn doIt => 104 | fn opts => fn (p as (_, _, tm), config) => 105 | let 106 | val s = stateMk () 107 | val e = envMk (config, tm, opts) 108 | val () = doIt (s, e, p) 109 | val l = layoutStats (s, e, opts) 110 | in l 111 | end 112 | 113 | (* 114 | val module = 115 | fn (config, opts, m, out) => 116 | Layout.outputWidth (layoutMk A.module opts (m, config), 78, out) 117 | *) 118 | 119 | val layout = layoutMk A.program 120 | 121 | val program = 122 | fn (config, opts, p, out) => 123 | Layout.outputWidth (layout opts (p, config), 78, out) 124 | 125 | end; 126 | -------------------------------------------------------------------------------- /compiler/anorm-lazy/to-abs-core.sml: -------------------------------------------------------------------------------- 1 | (* 2 | * Redistribution and use in source and binary forms, with or without modification, are permitted 3 | * provided that the following conditions are met: 4 | * 1. Redistributions of source code must retain the above copyright notice, this list of 5 | * conditions and the following disclaimer. 6 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 7 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 9 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 10 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 11 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 12 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 13 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 14 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 15 | *) 16 | 17 | (* 18 | * Translation from ANormLazy.t to AbsCore.t. 19 | *) 20 | (* FIXME: TypeRef.new_ *) 21 | signature ANORM_LAZY_TO_ABS_CORE = 22 | sig 23 | type t 24 | val doModule : ANormLazy.t -> t 25 | end 26 | 27 | functor ANormLazyToAbsCoreF (structure AbsCore : ABS_CORE) :> ANORM_LAZY_TO_ABS_CORE 28 | where type t = AbsCore.t = 29 | struct 30 | structure CH = CoreHs 31 | structure CU = CoreHsUtils 32 | structure CL = CoreHsLayout 33 | structure GP = GHCPrimType 34 | structure AL = ANormLazy 35 | structure AC = AbsCore 36 | structure Dom = AC.Dom 37 | structure ACL = AbsCoreLayoutF (struct structure AbsCore = AC 38 | type ty = ANormLazy.ty 39 | val layoutTy = ANormLazyLayout.layoutTy 40 | end) 41 | structure VD = Identifier.VariableDict 42 | structure IM = Identifier.Manager 43 | 44 | type t = AC.t 45 | 46 | val passname = "ANormLazyToAbsCore" 47 | 48 | val fail = fn (f, msg) => Fail.fail (passname, f, msg) 49 | 50 | val resultTy = 51 | fn ty => 52 | (case TypeRep.repToBase ty 53 | of AL.Arr (t1, t2, _) => t2 54 | | _ => TypeRep.newRep_ AL.Data) 55 | 56 | val rec doExp = 57 | fn (im, e, ty) => 58 | (case e 59 | of AL.Var v => AC.Var v 60 | | AL.PrimApp (f, vs) => 61 | let 62 | val vs = GHCPrimOp.keepStrictArgs (f, vs) 63 | in 64 | if List.isEmpty vs then AC.Const Dom.top else AC.GLB vs 65 | end 66 | | AL.ConApp ((c, _), vs) => 67 | (case TypeRep.repToBase ty 68 | of AL.Sum [(_, _)] => AC.Con (c, vs) (* preserve only sum type with single constructors *) 69 | | _ => AC.Const Dom.top) 70 | | AL.Multi vs => AC.Multi vs 71 | | AL.ExtApp (p, cc, f, ty, vs) => if List.isEmpty vs then AC.Const Dom.top else AC.GLB vs 72 | | AL.App (e, v) => AC.App (doExp (im, e, TypeRep.newRep_ (AL.Arr (IM.variableInfo (im, v), ty, NONE))), v) 73 | | AL.Lam ((v, vty, strictness), e) => AC.Lam (v, doExp (im, e, resultTy ty)) (* ignore existing strictness for the moment *) 74 | | AL.Let (vdefg, e) => AC.Let (doVDefg (im, vdefg), doExp (im, e, ty)) 75 | | AL.Case (e, (v, vty), ty, alts) => 76 | let 77 | val e = doExp (im, e, vty) 78 | fun doAlts () = 79 | case alts 80 | of [AL.Acon (con, vs, e1)] => 81 | AC.Let (AC.Nonrec (AC.Vdef (AC.VbMulti (List.map (vs, #1), false), e)), 82 | doExp (im, e1, ty)) 83 | | _ => 84 | let 85 | val vs = List.map (alts, fn _ => IM.variableFresh (im, "alt", vty)) 86 | val getAltE = fn AL.Acon (_, _, e) => e 87 | | AL.Alit (_, _, e) => e 88 | | AL.Adefault e => e 89 | val es = List.zip (List.map (alts, getAltE), vs) 90 | in 91 | case vs 92 | of [] => AC.Const Dom.bottom 93 | | _ => List.foldr (es, AC.LUB vs, fn ((e1, v), e) => 94 | AC.Let (AC.Nonrec (AC.Vdef (AC.VbSingle v, doExp (im, e1, ty))), e)) 95 | end 96 | in 97 | AC.Cond (e, doAlts ()) 98 | end 99 | | AL.Lit (l, ty) => AC.Const Dom.top 100 | | AL.Cast (e, t1, t2) => doExp (im, e, t1) 101 | ) 102 | 103 | and rec doVDef = 104 | fn (im, vd) => 105 | (case vd 106 | of (AL.Vdef (AL.VbSingle (v, vty, strict), e)) => AC.Vdef (AC.VbSingle v, doExp (im, e, vty)) 107 | | (AL.Vdef (AL.VbMulti (vtys, effectful), e)) => 108 | let 109 | val (vs, ts) = List.unzip vtys 110 | val ty = TypeRep.newRep_ (AL.Prim (GHCPrimType.Tuple ts)) 111 | in 112 | AC.Vdef (AC.VbMulti (vs, effectful), doExp (im, e, ty)) 113 | end) 114 | 115 | and rec doVDefg = 116 | fn (im, vdg) => 117 | (case vdg 118 | of AL.Rec vdefs => AC.Rec (List.map(vdefs, fn def => doVDef (im, def))) 119 | | AL.Nonrec vdef => AC.Nonrec (doVDef (im, vdef))) 120 | 121 | fun doModule (AL.Module (main, vdefgs), im, tm) = 122 | let 123 | val im = IM.fromExistingAll im 124 | val vdefgs = List.map (vdefgs, fn vdefg => doVDefg (im, vdefg)) 125 | in 126 | (AC.Module (main, vdefgs), IM.finish im) 127 | end 128 | 129 | end 130 | -------------------------------------------------------------------------------- /compiler/anorm-strict/anorm-strict-clone.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | (* Rename all bound variables *) 19 | signature ANORM_STRICT_CLONE = 20 | sig 21 | type 'a t = ANormStrict.symbolTableManager * Config.t * 'a -> 'a 22 | 23 | 24 | val exp : ANormStrict.exp t 25 | val alt : ANormStrict.alt t 26 | val vDef : ANormStrict.vDef t 27 | val vDefg : ANormStrict.vDefg t 28 | val module : ANormStrict.module t 29 | end (* signature ANORM_STRICT_CLONE *) 30 | 31 | structure ANormStrictClone :> ANORM_STRICT_CLONE = 32 | struct 33 | 34 | structure AS = ANormStrict 35 | structure IM = Identifier.Manager 36 | structure VD = Identifier.VariableDict 37 | structure RC = ANormStrictRewriterClient 38 | 39 | type 'a t = ANormStrict.symbolTableManager * Config.t * 'a -> 'a 40 | 41 | structure Rewrite = 42 | ANormStrictRewriterF(struct 43 | type state = AS.symbolTableManager 44 | type env = Config.t * AS.var VD.t 45 | val config : env -> Config.t = 46 | fn (c, vd) => c 47 | val bind : (state, env, Identifier.variable) RC.binder = 48 | fn (im, (c, map), v) => 49 | let 50 | val v2 = IM.variableClone (im, v) 51 | val map = VD.insert (map, v, v2) 52 | in ((c, map), SOME v2) 53 | end 54 | val variable : (state, env, Identifier.variable) RC.rewriter = 55 | fn (im, (c, map), v) => 56 | (case VD.lookup (map, v) 57 | of SOME v2 => RC.StopWith ((c, map), v2) 58 | | NONE => RC.Stop) 59 | val exp : (state, env, AS.exp) RC.rewriter = 60 | fn _ => RC.Continue 61 | val alt : (state, env, AS.alt) RC.rewriter = 62 | fn _ => RC.Continue 63 | val vDef : (state, env, AS.vDef) RC.rewriter = 64 | fn _ => RC.Continue 65 | val vDefg : (state, env, AS.vDefg) RC.rewriter = 66 | fn _ => RC.Continue 67 | val module : (state, env, AS.module) RC.rewriter = 68 | fn _ => RC.Continue 69 | end) 70 | 71 | val lift = 72 | fn f => fn (im, c, e) => f (im, (c, VD.empty), e) 73 | val exp = lift Rewrite.exp 74 | val alt = lift Rewrite.alt 75 | val vDef = lift Rewrite.vDef 76 | val vDefg = 77 | fn args => 78 | let 79 | val (_, vDefg) = lift Rewrite.vDefg args 80 | in vDefg 81 | end 82 | val module = lift Rewrite.module 83 | end (* structure ANormStrictClone *) 84 | -------------------------------------------------------------------------------- /compiler/anorm-strict/anorm-strict-free-vars.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | (* Collect free variables *) 19 | signature ANORM_STRICT_FREE_VARS = 20 | sig 21 | type 'a t = Config.t * 'a -> Identifier.VariableSet.t 22 | val exp : ANormStrict.exp t 23 | val alt : ANormStrict.alt t 24 | (* vDef will include the bound variable in the free set *) 25 | val vDef : ANormStrict.vDef t 26 | (* vDefg will not include the bound variables in the free set *) 27 | val vDefg : ANormStrict.vDefg t 28 | val module : ANormStrict.module t 29 | end (* signature ANORM_STRICT_FREE_VARS *) 30 | 31 | structure ANormStrictFreeVars :> ANORM_STRICT_FREE_VARS = 32 | struct 33 | 34 | structure AS = ANormStrict 35 | structure IM = Identifier.Manager 36 | structure VD = Identifier.VariableDict 37 | structure RC = ANormStrictRewriterClient 38 | 39 | structure VS = Identifier.VariableSet 40 | 41 | type 'a t = Config.t * 'a -> Identifier.VariableSet.t 42 | 43 | datatype state = S of {frees : VS.t ref, bound : VS.t ref} 44 | 45 | val mkState = 46 | fn () => S {frees = ref VS.empty, bound = ref VS.empty} 47 | 48 | val finish = 49 | fn (S {frees, bound, ...}) => VS.difference (!frees, !bound) 50 | 51 | val varUse = 52 | fn (s as S {frees, ...}, e, v) => 53 | let 54 | val () = frees := VS.insert (!frees, v) 55 | in () 56 | end 57 | 58 | val varBind = 59 | fn (s as S {bound, ...}, e, v) => 60 | let 61 | val () = bound := VS.insert (!bound, v) 62 | in e 63 | end 64 | 65 | 66 | structure Analyze = 67 | ANormStrictAnalyzeF(struct 68 | type state = state 69 | type env = Config.t 70 | val config = fn c => c 71 | val variableBind = SOME varBind 72 | val variableUse = SOME varUse 73 | val analyzeTy = NONE 74 | val analyzeExp = NONE 75 | val analyzeAlt = NONE 76 | val analyzeVDef = NONE 77 | val analyzeVDefg = NONE 78 | end) 79 | val lift = 80 | fn f => 81 | fn (c, e) => 82 | let 83 | val state = mkState () 84 | val _ = f (state, c, e) 85 | in finish state 86 | end 87 | 88 | val exp = lift Analyze.exp 89 | val alt = lift Analyze.alt 90 | val vDef = lift Analyze.vDef 91 | val vDefg = lift Analyze.vDefg 92 | val module = lift Analyze.module 93 | end (* structure ANormStrictFreeVars *) 94 | -------------------------------------------------------------------------------- /compiler/anorm-strict/anorm-strict-utils.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | signature ANORM_STRICT_UTILS = 19 | sig 20 | structure VDef : 21 | sig 22 | val binder : ANormStrict.vDef -> ANormStrict.var * ANormStrict.ty 23 | val binders : ANormStrict.vDef List.t -> (ANormStrict.var * ANormStrict.ty) List.t 24 | val variableDefd : ANormStrict.vDef -> ANormStrict.var 25 | val variablesDefd : ANormStrict.vDef List.t -> ANormStrict.var List.t 26 | end (* structure VDef *) 27 | 28 | structure VDefg : 29 | sig 30 | val binder : ANormStrict.vDefg -> (ANormStrict.var * ANormStrict.ty) List.t 31 | val binders : ANormStrict.vDefg List.t -> (ANormStrict.var * ANormStrict.ty) List.t 32 | val variableDefd : ANormStrict.vDefg -> ANormStrict.var List.t 33 | val variablesDefd : ANormStrict.vDefg List.t -> ANormStrict.var List.t 34 | end (* structure VDef *) 35 | end (* signature ANORM_STRICT_UTILS *) 36 | 37 | structure ANormStrictUtils :> ANORM_STRICT_UTILS = 38 | struct 39 | structure AS = ANormStrict 40 | structure VDef = 41 | struct 42 | val binder : ANormStrict.vDef -> ANormStrict.var * ANormStrict.ty = 43 | fn vd => 44 | (case vd 45 | of AS.Vfun {name, ty, ...} => (name, ty) 46 | | AS.Vthk {name, ty, ...} => (name, ty)) 47 | 48 | val binders : ANormStrict.vDef List.t -> (ANormStrict.var * ANormStrict.ty) List.t = 49 | fn vds => List.map (vds, binder) 50 | 51 | val variableDefd : ANormStrict.vDef -> ANormStrict.var = #1 o binder 52 | 53 | val variablesDefd : ANormStrict.vDef List.t -> ANormStrict.var List.t = 54 | fn vds => List.map (vds, variableDefd) 55 | 56 | end (* structure VDef *) 57 | 58 | structure VDefg = 59 | struct 60 | val binder : ANormStrict.vDefg -> (ANormStrict.var * ANormStrict.ty) List.t = 61 | fn vdg => 62 | (case vdg 63 | of AS.Vdef (vts, e) => vts 64 | | AS.Nonrec vd => VDef.binders [vd] 65 | | AS.Rec vds => VDef.binders vds) 66 | 67 | val binders : ANormStrict.vDefg List.t -> (ANormStrict.var * ANormStrict.ty) List.t = 68 | fn vds => List.concatMap (vds, binder) 69 | 70 | val variableDefd : ANormStrict.vDefg -> ANormStrict.var List.t = 71 | fn vd => List.map (binder vd, #1) 72 | 73 | val variablesDefd : ANormStrict.vDefg List.t -> ANormStrict.var List.t = 74 | fn vds => List.concatMap (vds, variableDefd) 75 | 76 | end (* structure VDef *) 77 | end (* structure ANormStrictUtils *) 78 | -------------------------------------------------------------------------------- /compiler/anorm-strict/anorm-strict.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* Copyright (C) Intel Corporation, October 2006 *) 3 | 4 | local 5 | $(SML_LIB)/mlton/sources.mlb 6 | ../common/common.mlb 7 | ../core-hs/core-hs.mlb 8 | anorm-strict.sml 9 | anorm-strict-layout.sml 10 | anorm-strict-utils.sml 11 | anorm-strict-rewrite.sml 12 | anorm-strict-analyze.sml 13 | stats.sml 14 | anorm-strict-free-vars.sml 15 | anorm-strict-clone.sml 16 | anorm-strict-closure-convert.sml 17 | anorm-strict-optimize.sml 18 | in 19 | structure ANormStrict 20 | structure ANormStrictClosureConvert 21 | structure ANormStrictLayout 22 | structure ANormStrictOptimize 23 | structure ANormStrictStats 24 | end 25 | -------------------------------------------------------------------------------- /compiler/as-to-mil/as-to-mil.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* Copyright (C) Intel Corporation, October 2006 *) 3 | 4 | local 5 | $(SML_LIB)/mlton/sources.mlb 6 | ../common/common.mlb 7 | ../core-hs/core-hs.mlb 8 | ../anorm-strict/anorm-strict.mlb 9 | ../mil/mil.mlb 10 | utils.sml 11 | ghc-prim.sml 12 | to-mil.sml 13 | in 14 | structure HsToMilUtils 15 | structure GHCPrim 16 | structure ANormStrictToMil 17 | end 18 | -------------------------------------------------------------------------------- /compiler/back-end/back-end.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | local 19 | $(SML_LIB)/mlton/sources.mlb 20 | ../common/common.mlb 21 | ../mil/mil.mlb 22 | pil.sml 23 | runtime.sml 24 | mil-to-pil.sml 25 | outputter.sml 26 | ../version.sml 27 | back-end.sml 28 | in 29 | structure Outputter 30 | structure BackEnd 31 | end 32 | -------------------------------------------------------------------------------- /compiler/back-end/outputter.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | (* The C/Pillar Outputter *) 19 | 20 | signature OUTPUTTER = 21 | sig 22 | val pass : (Mil.t, unit) Pass.t 23 | end; 24 | 25 | structure Outputter :> OUTPUTTER = struct 26 | 27 | val passname = "Outputter" 28 | 29 | fun writeToFile (pd, path, mil) = 30 | let 31 | val fname = Config.pathToHostString (PassData.getConfig pd, path) 32 | val l = MilToPil.program (pd, fname, mil) 33 | val suffix = ".c" 34 | val file = fname ^ suffix 35 | val () = LayoutUtils.writeLayout (l, file) 36 | in () 37 | end 38 | 39 | fun outputPil (m, pd, basename) = writeToFile (pd, basename, m) 40 | 41 | val description = {name = passname, 42 | description = "Mil to Pil; output to file", 43 | inIr = MilUtils2.irHelpers, 44 | outIr = Pass.unitHelpers, 45 | mustBeAfter = [], 46 | stats = []} 47 | 48 | val associates = {controls = [], 49 | debugs = [], 50 | features = MilToPil.features, 51 | subPasses = []} 52 | 53 | val pass = Pass.mkFilePass (description, associates, outputPil) 54 | 55 | end; 56 | -------------------------------------------------------------------------------- /compiler/ch-to-as/ch-to-as.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* Copyright (C) Intel Corporation, October 2006 *) 3 | 4 | local 5 | $(SML_LIB)/mlton/sources.mlb 6 | ../common/common.mlb 7 | ../core-hs/core-hs.mlb 8 | ../anorm-lazy/anorm-lazy.mlb 9 | ../anorm-strict/anorm-strict.mlb 10 | to-lazy.sml 11 | to-strict.sml 12 | in 13 | structure CoreHsToANormLazy 14 | structure ANormLazyToStrict 15 | end 16 | -------------------------------------------------------------------------------- /compiler/common/chat.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | (* Talking to the user *) 20 | 21 | signature CHAT = sig 22 | 23 | type env 24 | type level = int 25 | 26 | val error : env * string -> unit 27 | 28 | (* See config.sml for documentation of the warn, log, and debug levels. *) 29 | 30 | val warn : env * level * string -> unit 31 | val log : env * level * string -> unit 32 | 33 | val warn0 : env * string -> unit 34 | val warn1 : env * string -> unit 35 | val warn2 : env * string -> unit 36 | 37 | val log0 : env * string -> unit 38 | val log1 : env * string -> unit 39 | val log2 : env * string -> unit 40 | val log3 : env * string -> unit 41 | 42 | end 43 | 44 | functor ChatF(type env 45 | val extract : env -> Config.t 46 | val name : string 47 | val indent : int) 48 | :> CHAT where type env = env = 49 | struct 50 | 51 | type env = env 52 | type level = int 53 | 54 | fun error (env, s) = 55 | Out.output (Out.error, "flrc: error: " ^ s ^ "\n") 56 | 57 | fun say (cfg, s) = 58 | let 59 | val i = StringCvt.padLeft #" " indent "" 60 | in 61 | print (i^s) 62 | end 63 | 64 | fun warn (cfg, level, msg) = 65 | let val cfg = extract cfg 66 | val warnLevel = Config.warnLevel (cfg, name) 67 | in 68 | if level <= warnLevel then 69 | say (cfg, "warning: " ^ name ^ ": " ^ msg ^ "\n") 70 | else 71 | () 72 | end 73 | 74 | fun log (cfg, level, msg) = 75 | let val cfg = extract cfg 76 | val logLevel = Config.logLevel (cfg, name) 77 | in 78 | if level <= logLevel then 79 | say (cfg, name ^ ": " ^ msg ^ "\n") 80 | else 81 | () 82 | end 83 | 84 | fun warn0 (cfg, msg) = warn (cfg, 0, msg) 85 | fun warn1 (cfg, msg) = warn (cfg, 1, msg) 86 | fun warn2 (cfg, msg) = warn (cfg, 2, msg) 87 | 88 | fun log0 (cfg, msg) = log (cfg, 0, msg) 89 | fun log1 (cfg, msg) = log (cfg, 1, msg) 90 | fun log2 (cfg, msg) = log (cfg, 2, msg) 91 | fun log3 (cfg, msg) = log (cfg, 3, msg) 92 | 93 | end; 94 | -------------------------------------------------------------------------------- /compiler/common/common.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | local 20 | 21 | (* Library stuff *) 22 | $(SML_LIB)/mlton/sources.mlb 23 | tuple.sml 24 | fail.sml 25 | try.sml 26 | lub.sml 27 | compare.sml 28 | rat.sml 29 | 30 | local 31 | local 32 | $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb 33 | in 34 | functor RedBlackSetFn 35 | functor RedBlackMapFn 36 | functor SplaySetFn 37 | functor SplayMapFn 38 | structure Queue 39 | structure BitArray 40 | end 41 | local 42 | $(SML_LIB)/basis/basis.mlb 43 | in 44 | structure Posix 45 | structure PackWord32Little 46 | structure PackWord64Little 47 | structure PackReal32Little 48 | structure PackReal64Little 49 | structure Int32 50 | structure Word32 51 | structure Word8Array 52 | end 53 | in 54 | utils.sml 55 | end 56 | path.sml 57 | graph.sml 58 | topo-sort.sml 59 | dominance.sml 60 | int-arb.sml 61 | intr.sml 62 | 63 | (* Compiler stuff *) 64 | config.sml 65 | dataflow.sml 66 | globals.sml 67 | chat.sml 68 | locus.sml 69 | z-coding.sml 70 | identifier.sml 71 | local 72 | local 73 | $(SML_LIB)/basis/basis.mlb 74 | in 75 | structure Posix 76 | structure TextIO 77 | end 78 | in 79 | pass.sml 80 | end 81 | rename.sml 82 | effect.sml 83 | local 84 | $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb 85 | in 86 | type-rep.sml 87 | end 88 | 89 | in 90 | signature CHAT 91 | signature DICT 92 | signature DICT_IMP 93 | signature DOMINANCE 94 | signature IMP_POLY_LABELED_GRAPH 95 | signature LATTICE 96 | signature ORD 97 | signature PARSER 98 | signature PARSER_UN_PARSER 99 | signature SET 100 | signature LANGUAGE_DEF 101 | 102 | functor ChatF 103 | functor DataFlowF 104 | functor DictF 105 | functor DictImpF 106 | functor DominanceF 107 | functor FlatLatticeFn 108 | functor FlatOptionLatticeFn 109 | functor LatticeFn 110 | functor LatticeVectorLatticeFn 111 | functor OptionLatticeFn 112 | functor ParserF 113 | functor ParserUnParserF 114 | functor RecLatticeFn 115 | functor SetF 116 | functor CharParserF 117 | functor TokenParserF 118 | 119 | structure BackPatch 120 | structure Bijection 121 | structure CharDict 122 | structure Compare 123 | structure Config 124 | structure DList 125 | structure DepGraph 126 | structure Effect 127 | structure EquivalenceClass 128 | structure Equality 129 | structure Fail 130 | structure FileParser 131 | structure FileParserUnParser 132 | structure FunctionalUpdate 133 | structure Globals 134 | structure Identifier 135 | structure ImpBitSet 136 | structure ImpIntDict 137 | structure ImpPolyLabeledGraph 138 | structure ImpQueue 139 | structure InStreamWithPos 140 | structure Int32 141 | structure IntFiniteOrdinal 142 | structure IntArb 143 | structure IntDict 144 | structure IntIntDict 145 | structure Intr 146 | structure IntSet 147 | structure IntFiniteOrdinal 148 | structure LayoutUtils 149 | structure Locus 150 | structure Lub 151 | structure StringParser 152 | structure Pass 153 | structure PassData 154 | structure Path 155 | structure PolyLabeledGraph 156 | structure Rat 157 | structure Rename 158 | structure Stats 159 | structure StringDict 160 | structure StringParserUnParser 161 | structure StringSet 162 | functor TopoSortF 163 | structure Try 164 | structure UnParser 165 | structure Utils 166 | structure Word32 167 | structure WordDict 168 | structure WordSet 169 | structure ZCoding 170 | signature TYPE_REP 171 | structure TypeRep 172 | 173 | end 174 | -------------------------------------------------------------------------------- /compiler/common/dominance.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | (* Dominance module: Takes a dominator tree and provides dominance 20 | * information. 21 | *) 22 | 23 | signature DOMINANCE = 24 | sig 25 | 26 | type t 27 | type node 28 | 29 | (* Note: Cfgs may contain nodes that are not in the obvious dominator 30 | * tree. 31 | *) 32 | val new : node Tree.t -> t 33 | val getTree : t -> node Tree.t 34 | val dominates: t * node * node -> bool 35 | val contains : t * node -> bool 36 | 37 | end 38 | 39 | functor DominanceF (type node 40 | val compare : node * node -> order 41 | ) :> DOMINANCE where type node = node = 42 | struct 43 | 44 | type node = node 45 | 46 | structure NodeDict = DictF (struct 47 | type t = node; 48 | val compare = compare; 49 | end); 50 | 51 | datatype t = DT of {tree : node Tree.t, 52 | ints : (int * int) NodeDict.t} 53 | 54 | val getTree : t -> node Tree.t = 55 | fn (DT {tree, ...}) => tree 56 | 57 | fun mkInts (t) = 58 | let 59 | val ints = ref NodeDict.empty 60 | fun addInt (n, (s, e)) = ints := NodeDict.insert (!ints, n, (s, e)) 61 | fun doTree (Tree.T (n, children), s) = 62 | let 63 | val e = Vector.fold (children, s + 1, doTree) 64 | val () = addInt (n, (s, e)) 65 | in e + 1 66 | end 67 | val _ = doTree (t, 0) 68 | in 69 | !ints 70 | end 71 | 72 | val new : node Tree.t -> t = 73 | fn (tree) => DT {tree = tree, ints = mkInts (tree)} 74 | 75 | val contains : t * node -> bool = 76 | fn (DT {ints, ...}, n) => NodeDict.contains (ints, n) 77 | 78 | val dominates: t * node * node -> bool = 79 | fn (DT {ints, ...}, l1, l2) => 80 | let 81 | val (s1, e1) = Option.valOf (NodeDict.lookup (ints, l1)) 82 | val (s2, e2) = Option.valOf (NodeDict.lookup (ints, l2)) 83 | in 84 | s1 <= s2 andalso e1 >= e2 85 | end 86 | 87 | end 88 | -------------------------------------------------------------------------------- /compiler/common/fail.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | (* For when things go wrong *) 20 | 21 | signature FAIL = 22 | sig 23 | val assert : string * string * string * (unit -> bool) -> unit 24 | (* struct, routine, failure msg, assert fn *) 25 | val fail : string * string * string -> 'a (* struct, routine, msg *) 26 | val unimplemented : string * string * string -> 'a 27 | (* struct, routine, what *) 28 | end; 29 | 30 | structure Fail :> FAIL = 31 | struct 32 | 33 | fun fail (s, r, m) = Assert.fail (s ^ "." ^ r ^ ": " ^ m) 34 | fun assert (s, r, m, assert) = 35 | if assert () then 36 | () 37 | else 38 | fail (s, r, m) 39 | fun unimplemented (s, r, w) = fail (s, r, w ^ " unimplemented") 40 | 41 | end; 42 | -------------------------------------------------------------------------------- /compiler/common/globals.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature GLOBALS = 20 | sig 21 | 22 | val disableOptimizedRationals : Config.t -> bool 23 | val disableOptimizedIntegers : Config.t -> bool 24 | 25 | val features : Config.Feature.feature list 26 | val debugs : Config.Debug.debug list 27 | val controls : Config.Control.control list 28 | 29 | end; 30 | 31 | structure Globals :> GLOBALS = 32 | struct 33 | 34 | val (disableOptimizedRationalsF, disableOptimizedRationals) = 35 | Config.Feature.mk ("FLRC:disable-optimized-rationals", 36 | "disable optimized rational rep") 37 | 38 | val (disableOptimizedIntegersF, disableOptimizedIntegers) = 39 | Config.Feature.mk ("FLRC:disable-optimized-integers", 40 | "disable optimized integer rep") 41 | 42 | val features = [disableOptimizedRationalsF, disableOptimizedIntegersF] 43 | val debugs = [] 44 | val controls = [] 45 | 46 | end; 47 | -------------------------------------------------------------------------------- /compiler/common/locus.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature LOCUS = 20 | sig 21 | datatype lineCol = LC of {line : int, col : int} 22 | datatype t = L of {file : string, start : lineCol, finish : lineCol} 23 | val dummy : t 24 | val toString : t -> string 25 | val compare : t * t -> order 26 | structure Dict : DICT where type key = t 27 | val layout : t -> Layout.t 28 | end; 29 | 30 | structure Locus :> LOCUS = 31 | struct 32 | 33 | datatype lineCol = LC of {line : int, col : int} 34 | 35 | datatype t = L of {file : string, start : lineCol, finish : lineCol} 36 | 37 | val dummyLineCol = LC {line = 0, col = 0} 38 | 39 | val dummy = L {file = "xxx", start = dummyLineCol, finish = dummyLineCol} 40 | 41 | fun toString (L {file, start = LC {line = sl, col = sc}, finish = LC {line = el, col = ec}}) = 42 | file ^ "(" ^ 43 | ( 44 | if sl = 0 andalso sc = 0 andalso el = 0 andalso ec = 0 then 45 | "" 46 | else if sl = el then 47 | if ec <= sc + 1 then 48 | Int.toString (sl + 1) ^ ":" ^ Int.toString (sc + 1) 49 | else 50 | Int.toString (sl + 1) ^ ":" ^ Int.toString (sc + 1) ^ ".." ^ Int.toString (ec + 1) 51 | else 52 | Int.toString (sl + 1) ^ ":" ^ Int.toString (sc + 1) ^ ".." ^ 53 | Int.toString (el + 1) ^ ":" ^ Int.toString (ec + 1) 54 | ) ^ ")" 55 | 56 | fun compareLineCol (LC x1, LC x2) = Compare.rec2 (#line, Int.compare, #col, Int.compare) (x1, x2) 57 | 58 | fun compare (L x1, L x2) = 59 | Compare.rec3 (#file, String.compare, #start, compareLineCol, #finish, compareLineCol) (x1, x2) 60 | 61 | structure Dict = DictF(struct type t = t val compare = compare end) 62 | 63 | fun layout l = Layout.str (toString l) 64 | 65 | end; 66 | -------------------------------------------------------------------------------- /compiler/common/lub.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature LUB = 20 | sig 21 | 22 | type 'a lubber = ('a * 'a) -> 'a option 23 | val option : 'a lubber -> 'a option lubber 24 | val vector : 'a lubber -> 'a Vector.t lubber 25 | val pair : ('a lubber * 'b lubber) -> ('a * 'b) lubber 26 | val triple : ('a lubber * 'b lubber * 'c lubber) -> ('a * 'b * 'c) lubber 27 | (* (equal eq) (a, b) => SOME c iff eq (a, b) 28 | * where c is one of a or b *) 29 | val equal : ('a * 'a -> bool) -> 'a lubber 30 | (* (cmp f) = (equal (fn p => (cmp p) = EQUAL)) *) 31 | val cmp : ('a * 'a -> order) -> 'a lubber 32 | 33 | val pairWise : 34 | ('dict * 'dict * (('key * 'elt option * 'elt option ) -> 'elt) -> 'dict) -> 'elt lubber -> 'dict lubber 35 | 36 | (* No widening *) 37 | val pairWiseStrict : 38 | ('dict * 'dict * (('key * 'elt option * 'elt option) -> 'elt) -> 'dict) -> 'elt lubber -> 'dict lubber 39 | 40 | end 41 | 42 | structure Lub :> LUB = 43 | struct 44 | 45 | type 'a lubber = ('a * 'a) 46 | -> 'a option 47 | 48 | val vector = 49 | fn f => 50 | fn (v1, v2) => 51 | Try.try 52 | (fn () => 53 | let 54 | val () = Try.require (Vector.length v1 = Vector.length v2) 55 | val v3 = Vector.map2 (v1, v2, Try.<- o f) 56 | in v3 57 | end) 58 | 59 | val cmp = 60 | fn cmp => 61 | fn (t1, t2) => 62 | case cmp (t1, t2) 63 | of EQUAL => SOME t1 64 | | _ => NONE 65 | 66 | val fail = 67 | fn (fname, msg) => Fail.fail ("lub.sml", fname, msg) 68 | 69 | val equal = 70 | fn eq => 71 | fn (t1, t2) => 72 | if eq (t1, t2) then 73 | SOME t1 74 | else 75 | NONE 76 | 77 | val option = 78 | fn f => 79 | fn (t1, t2) => 80 | Try.try 81 | (fn () => 82 | case (t1, t2) 83 | of (SOME a, SOME b) => SOME (Try.<- (f (a, b))) 84 | | (NONE, NONE) => NONE 85 | | _ => Try.fail ()) 86 | 87 | val triple = 88 | fn (f1, f2, f3) => 89 | fn ((a1, b1, c1), 90 | (a2, b2, c2)) => 91 | Try.try 92 | (fn () => 93 | (Try.<- (f1 (a1, a2)), 94 | Try.<- (f2 (b1, b2)), 95 | Try.<- (f3 (c1, c2)))) 96 | 97 | val pair = 98 | fn (f1, f2) => 99 | fn ((a1, b1), 100 | (a2, b2)) => 101 | Try.try 102 | (fn () => 103 | (Try.<- (f1 (a1, a2)), 104 | Try.<- (f2 (b1, b2)))) 105 | 106 | val pairWise = 107 | fn map2 => 108 | fn lub => 109 | fn (d1, d2) => 110 | Try.try 111 | (fn () => 112 | let 113 | val help = 114 | fn (k, a, b) => 115 | (case (a, b) 116 | of (SOME a, SOME b) => Try.<- (lub (a, b)) 117 | | (SOME a, NONE) => a 118 | | (NONE, SOME b) => b 119 | | (NONE, NONE) => fail ("Lub", "Bad map2")) 120 | in map2(d1, d2, help) 121 | end) 122 | 123 | val pairWiseStrict = 124 | fn map2 => 125 | fn lub => 126 | fn (d1, d2) => 127 | Try.try 128 | (fn () => 129 | let 130 | val help = 131 | fn (k, a, b) => 132 | let 133 | val a = Try.<- a 134 | val b = Try.<- b 135 | in Try.<- (lub (a, b)) 136 | end 137 | in map2(d1, d2, help) 138 | end) 139 | end 140 | -------------------------------------------------------------------------------- /compiler/common/rename.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature RENAME = 20 | sig 21 | 22 | type variable = Identifier.variable 23 | type t = variable Identifier.VariableDict.t 24 | 25 | 26 | (* No renamings *) 27 | val none : t 28 | 29 | (* Add a specified renaming *) 30 | val renameTo : t * variable * variable -> t 31 | 32 | (* If the variable is renamed, return the new variable, 33 | * otherwise return the old. 34 | *) 35 | val use : t * variable -> variable 36 | 37 | (* If the variable is renamed, return the new variable, 38 | * otherwise return NONE. 39 | *) 40 | val use' : t * variable -> variable option 41 | 42 | (* Return if variable is renamed *) 43 | val renamed : t * variable -> bool 44 | 45 | (* Compose a specified renaming before *) 46 | val renameBefore : t * variable * variable -> t 47 | 48 | (* Compose a specified renaming after *) 49 | val renameAfter : variable * variable * t -> t 50 | 51 | (* Outputs a list of pairs of the renamings *) 52 | val toList : t -> (variable * variable) list 53 | 54 | (* Reverse a renaming *) 55 | val invert : t -> t 56 | 57 | (* Compse two renamins e.g. compose (g, f) = Lookup(g, Lookup(f, x)) *) 58 | val compose : t * t -> t 59 | 60 | val layout : t -> Layout.t 61 | 62 | end 63 | 64 | structure Rename :> RENAME = 65 | struct 66 | 67 | structure VD = Identifier.VariableDict 68 | 69 | type variable = Identifier.variable 70 | 71 | type t = variable VD.t 72 | 73 | val none = VD.empty 74 | 75 | fun renamed (map, x) = VD.contains(map, x) 76 | 77 | fun renameTo (map, x, y) = 78 | if (x = y) then map 79 | else if renamed(map,x) then 80 | Fail.fail ("Rename", "renameTo", "saw repeated variable " ^ Identifier.variableString' x) 81 | else 82 | let 83 | val map = VD.insert(map,x,y) 84 | in 85 | map 86 | end 87 | 88 | fun use' (map, x) = VD.lookup(map, x) 89 | 90 | fun use (r, x) = 91 | case use'(r,x) 92 | of SOME y => y 93 | | NONE => x 94 | 95 | 96 | fun renameBefore (map, x, y) = 97 | if (x = y) then map 98 | else 99 | let 100 | val y = use(map, y) 101 | val map = renameTo(map, x, y) 102 | in 103 | map 104 | end 105 | 106 | fun renameAfter (x, y, map) = 107 | if (x = y) then map 108 | else 109 | let 110 | val map = VD.map(map, fn(x', y') => if y' = x then y else y') 111 | in 112 | if renamed(map, x) then 113 | map 114 | else 115 | renameTo(map, x, y) 116 | end 117 | 118 | fun toList (renaming) = VD.toList renaming 119 | 120 | fun invert (renaming) = 121 | let 122 | fun swap (a, b) = (b, a) 123 | in 124 | VD.fromList (map swap (VD.toList renaming)) 125 | end 126 | 127 | fun compose (map2, map1) = 128 | let 129 | fun go ([], map') = map' 130 | | go ((x, y)::rs, map') = 131 | case (use' (map2, y)) 132 | of SOME z => go (rs, renameTo(map', x, z)) 133 | | NONE => go (rs, map') 134 | in go (VD.toList map1, none) 135 | end 136 | 137 | fun fromDict d = d 138 | 139 | fun layout map = 140 | let 141 | fun layoutP(v1,v2) = Layout.seq[ 142 | Identifier.layoutVariable' v1, 143 | Layout.str"->", 144 | Identifier.layoutVariable' v2] 145 | in 146 | VD.layout (map,layoutP) 147 | end 148 | 149 | end; 150 | -------------------------------------------------------------------------------- /compiler/common/topo-sort.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | (* Topological sort of key/data pairs based on a dependency function. 20 | * TopoSort.sort (l, f) returns L, where L is a list of lists of elements 21 | * of l. Informally, f(v) returns things that v depends on, and hence that 22 | * should come before it if possible. 23 | * 24 | * More precisely, L is the topologically sorted list of strongly connected 25 | * components of the graph induced by adding edges from x to v for each x 26 | * in f(v). Consequently, if x is in f(v), then x is not after v in L. 27 | * 28 | * Note: if x is in f(v), but x is not in l, then x will be ignored. 29 | *) 30 | 31 | functor TopoSortF (structure Dict : DICT 32 | structure Set : SET 33 | sharing type Dict.key = Set.element) :> 34 | sig 35 | type key = Dict.key 36 | val sort : (key * 'a) list * (key * 'a -> Set.t) -> (key * 'a ) list list 37 | end = 38 | struct 39 | type key = Dict.key 40 | 41 | structure PLG = PolyLabeledGraph 42 | 43 | val sort = 44 | fn (nodes, df) => 45 | let 46 | val node = fn ((v, _), n, map) => Dict.insert (map, v, n) 47 | val edges = 48 | fn map => 49 | let 50 | val doNode = 51 | fn (v, x) => 52 | let 53 | val n = Option.valOf (Dict.lookup (map, v)) 54 | val deps = Set.toList (df (v, x)) 55 | val doOne = fn v => Option.map (Dict.lookup (map, v), fn n' => (n', n, ())) 56 | val es = List.keepAllMap (deps, doOne) 57 | in es 58 | end 59 | val es = List.concat (List.map (nodes, doNode)) 60 | in es 61 | end 62 | val (g, _) = PLG.new {nodes = nodes, init = Dict.empty, node = node, edges = edges} 63 | val scc = PLG.scc g 64 | val scc = List.map (scc, fn l => List.map (l, PLG.Node.getLabel)) 65 | in scc 66 | end 67 | end (* functor TopoSort *) 68 | -------------------------------------------------------------------------------- /compiler/common/type-rep.sml: -------------------------------------------------------------------------------- 1 | (* 2 | * Redistribution and use in source and binary forms, with or without modification, are permitted 3 | * provided that the following conditions are met: 4 | * 1. Redistributions of source code must retain the above copyright notice, this list of 5 | * conditions and the following disclaimer. 6 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 7 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 9 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 10 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 11 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 12 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 13 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 14 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 15 | *) 16 | 17 | (* TypeRep provides a manager to store data types using hashconsing to 18 | * save memory usage. No recursive types are allowed. 19 | *) 20 | 21 | signature TYPE_REP = 22 | sig 23 | type 'base rep (* abstract type representation *) 24 | type 'base manager (* mutable data structure that facilitates operations on base types *) 25 | type 'base baseHash = ('base rep -> word) -> 'base -> word 26 | type 'base baseEq = ('base rep * 'base rep -> bool) -> 'base * 'base -> bool 27 | (* hash function for rep *) 28 | val hashRep : ('base -> word) -> 'base rep -> word 29 | val hashRepWithManager : 'base manager * 'base rep -> word 30 | (* create an empty rep manager *) 31 | val newManager : 'base baseHash * 'base baseEq -> 'base manager 32 | (* create an empty rep manager *) 33 | val size : 'base manager -> int 34 | (* create a managed rep, store it with the manager *) 35 | val newRep : 'base manager * 'base -> 'base rep 36 | (* create an un-managed rep, which should only be used for temporary cases *) 37 | val newRep_ : 'base -> 'base rep 38 | (* unwrap the rep and return the base type *) 39 | val repToBase : 'base rep -> 'base 40 | (* helper functions to compute hash *) 41 | val hash2 : word * word -> word 42 | val hash3 : word * word * word -> word 43 | val hash4 : word * word * word * word -> word 44 | val hashList : word list -> word 45 | end 46 | 47 | structure TypeRep : TYPE_REP = 48 | struct 49 | structure H = HashTable 50 | structure UO = Utils.Option 51 | 52 | (* Exception is required by sml-nj's HashTable, though we don't use it *) 53 | exception NotFound 54 | 55 | (* The optional meta fields are to speed up hashing and comparison operations *) 56 | datatype 'base rep = Ty of { base : 'base, meta : { hash : word, uid : word } option } 57 | 58 | (* 59 | * The manager uses a stamp to generate uids for rep, and a hash table to 60 | * store reps for hash-consing. 61 | *) 62 | datatype 'base manager = Tbl of { stamp : word ref, 63 | table : ('base, 'base rep) H.hash_table, 64 | hashBase : 'base -> word } 65 | 66 | type 'base baseHash = ('base rep -> word) -> 'base -> word 67 | 68 | type 'base baseEq = ('base rep * 'base rep -> bool) -> 'base * 'base -> bool 69 | 70 | val hashRep : ('base -> word) -> 'base rep -> word 71 | = fn hashBase => fn Ty { base, meta } => 72 | UO.dispatch (meta, fn { hash, ... } => hash, fn () => hashBase base) 73 | 74 | val hashRepWithManager : 'base manager * 'base rep -> word 75 | = fn (Tbl { hashBase, ... }, x) => hashRep hashBase x 76 | 77 | val eqRep : ('base * 'base -> bool) -> 'base rep * 'base rep -> bool 78 | = fn eqBase => fn (Ty { base = x, meta = u }, Ty { base = y, meta = v}) => 79 | (case (u, v) 80 | of (SOME u, SOME v) => #uid u = #uid v 81 | | _ => eqBase (x, y)) 82 | 83 | val newManager : 'base baseHash * 'base baseEq -> 'base manager 84 | = fn (hash, eq) => 85 | let 86 | fun hashBase x = hash (hashRep hashBase) x 87 | fun eqBase x = eq (eqRep eqBase) x 88 | val table = H.mkTable (hashBase, eqBase) (32, NotFound) 89 | in 90 | Tbl { stamp = ref 0w0, table = table, hashBase = hashBase } 91 | end 92 | 93 | val size : 'base manager -> int 94 | = fn Tbl tbl => H.numItems (#table tbl) 95 | 96 | val newRep : 'base manager * 'base -> 'base rep 97 | = fn (tbl as Tbl { stamp, table, hashBase }, base) => 98 | UO.dispatch (H.find table base, fn x => x, 99 | fn () => 100 | let 101 | val () = stamp := Word.+(!stamp, 0w1) 102 | val x = Ty { base = base, meta = SOME { hash = hashBase base, uid = !stamp }} 103 | val () = H.insert table (base, x) 104 | in 105 | x 106 | end) 107 | 108 | val newRep_ : 'base -> 'base rep 109 | = fn b => Ty { base = b, meta = NONE } 110 | 111 | val repToBase : 'base rep -> 'base 112 | = fn Ty x => #base x 113 | 114 | fun hash2 (a, b) = Word.+ (Word.* (a, 0wx133), b) 115 | fun hash3 (a, b, c) = hash2 (a, hash2 (b, c)) 116 | fun hash4 (a, b, c, d) = hash2 (a, hash2 (b, hash2 (c, d))) 117 | fun hashList l = List.fold (l, 0wx0, hash2) 118 | end 119 | -------------------------------------------------------------------------------- /compiler/core-hs/core-hs.lex: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* Copyright (C) Intel Corporation, October 2006 *) 3 | 4 | structure Tokens = Tokens 5 | structure TextIO = Pervasive.TextIO 6 | 7 | type pos = int 8 | type svalue = Tokens.svalue 9 | type ('a,'b) token = ('a,'b) Tokens.token 10 | type lexresult= (svalue,pos) token 11 | 12 | val pos = ref 1 13 | fun eof () = Tokens.EOF(!pos,!pos) 14 | fun error (e,l : int,_) = TextIO.output (TextIO.stdOut, String.concat[ 15 | "line ", (Int.toString l), ": ", e, "\n" 16 | ]) 17 | 18 | (* support for incremental construction of strings *) 19 | val sbuf : string list ref = ref [] 20 | fun addStr s = sbuf := s :: !sbuf 21 | fun fromNum base (s, i, j) = 22 | let 23 | val s = String.substring2 (s, { start = i, finish = j }) 24 | val c = String.fold (s, 0, fn (c, v) => v * base + Char.toHexDigit c) 25 | in c 26 | end 27 | val fromHex = fromNum 16 28 | val fromDec = fromNum 10 29 | fun addChr s = addStr (String.fromChar (Char.fromInt (fromHex (s, 2, String.length s)))) 30 | fun finishString () = (Tokens.STRING(String.concat(List.rev(!sbuf)), !pos, !pos) before sbuf := []) 31 | fun lname s = 32 | if s = "z7eU" orelse s = "z7eUzh" then Tokens.Z7EU(s, !pos, !pos) 33 | else if s = "zt" then Tokens.ZT(s, !pos, !pos) 34 | else Tokens.LNAME(s, !pos, !pos) 35 | 36 | %% 37 | %s S; 38 | %header (functor CoreHsLexFun(structure Tokens: CoreHsYacc_TOKENS)); 39 | lower = [a-z_]; 40 | upper = [A-Z]; 41 | digit = [0-9]; 42 | xdigit = {digit}|[a-fA-F]; 43 | ws = [\ \t]; 44 | namechar = [a-zA-Z0-9_]; 45 | charlit = \'.\'; 46 | octchar = \'\\{digit}+\'; 47 | hexchar = \'\\x{xdigit}+\'; 48 | %% 49 | 50 | 51 | \n => (pos := (!pos) + 1; lex()); 52 | {ws}+ => (lex()); 53 | {digit}+ => (Tokens.NUM (valOf (IntInf.fromString yytext), !pos, !pos)); 54 | {lower}{namechar}* => (lname(yytext)); 55 | {upper}{namechar}* => (Tokens.UNAME(yytext,!pos,!pos)); 56 | 57 | "%module" => (Tokens.MODULE(!pos,!pos)); 58 | "%data" => (Tokens.DATA(!pos,!pos)); 59 | "%newtype" => (Tokens.NEWTYPE(!pos,!pos)); 60 | "%rec" => (Tokens.REC(!pos,!pos)); 61 | "%let" => (Tokens.LET(!pos,!pos)); 62 | "%in" => (Tokens.IN(!pos,!pos)); 63 | "%case" => (Tokens.CASE(!pos,!pos)); 64 | "%of" => (Tokens.OF(!pos,!pos)); 65 | "%cast" => (Tokens.CAST(!pos,!pos)); 66 | "%note" => (Tokens.NOTE(!pos,!pos)); 67 | "%external" => (Tokens.EXTERNAL(!pos,!pos)); 68 | "%dynexternal" => (Tokens.DYNEXTERNAL(!pos,!pos)); 69 | "%label" => (Tokens.LABEL(!pos,!pos)); 70 | "%_" => (Tokens.DEFAULT(!pos,!pos)); 71 | "%trans" => (Tokens.TRANS(!pos,!pos)); 72 | "%sym" => (Tokens.SYM(!pos,!pos)); 73 | "%unsafe" => (Tokens.UNSAFE(!pos,!pos)); 74 | "%left" => (Tokens.LEFT(!pos,!pos)); 75 | "%right" => (Tokens.RIGHT(!pos,!pos)); 76 | "%inst" => (Tokens.INST(!pos,!pos)); 77 | "%nth" => (Tokens.NTH(!pos,!pos)); 78 | "%forall" => (Tokens.FORALL(!pos,!pos)); 79 | ";" => (Tokens.SEMI(!pos,!pos)); 80 | "=" => (Tokens.EQ(!pos,!pos)); 81 | "{" => (Tokens.LB(!pos,!pos)); 82 | "}" => (Tokens.RB(!pos,!pos)); 83 | "(" => (Tokens.LP(!pos,!pos)); 84 | ")" => (Tokens.RP(!pos,!pos)); 85 | "@" => (Tokens.AT(!pos,!pos)); 86 | "\\" => (Tokens.SLASH(!pos,!pos)); 87 | "->" => (Tokens.TO(!pos,!pos)); 88 | "::" => (Tokens.DCOLON(!pos,!pos)); 89 | ":=:" => (Tokens.KEQ(!pos,!pos)); 90 | ":" => (Tokens.COLON(!pos,!pos)); 91 | "*" => (Tokens.TIMES(!pos,!pos)); 92 | "#" => (Tokens.HASH(!pos,!pos)); 93 | "?" => (Tokens.QMARK(!pos,!pos)); 94 | "." => (Tokens.DOT(!pos,!pos)); 95 | "!" => (Tokens.BANG(!pos,!pos)); 96 | "-" => (Tokens.MINUS(!pos,!pos)); 97 | "%" => (Tokens.PERCENT(!pos,!pos)); 98 | {charlit} => (Tokens.CHAR(Char.toInt (String.sub(yytext, 1)), !pos, !pos)); 99 | {hexchar} => (Tokens.CHAR(fromHex (yytext, 3, String.length yytext - 1), !pos, !pos)); 100 | {octchar} => (Tokens.CHAR(fromDec (yytext, 2, String.length yytext - 1), !pos, !pos)); 101 | "\"" => (YYBEGIN S; lex()); 102 | 103 | "\\x"{xdigit}{2} => ( addChr yytext; lex() ); 104 | [^\\"]+ => ( addStr yytext; lex() ); 105 | "\"" => ( YYBEGIN INITIAL; finishString() ); 106 | . => (error ("bad character in string literal " ^ yytext, !pos, !pos); lex()); 107 | . => (error ("ignoring bad character "^yytext,!pos,!pos); lex()); 108 | 109 | 110 | -------------------------------------------------------------------------------- /compiler/core-hs/core-hs.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* Copyright (C) Intel Corporation, October 2006 *) 3 | 4 | local 5 | $(SML_LIB)/mlton/sources.mlb 6 | $(SML_LIB)/mlyacc-lib/mlyacc-lib.mlb 7 | ../common/common.mlb 8 | core-hs.sml 9 | layout.sml 10 | core-hs.grm.sig 11 | core-hs.grm.sml 12 | core-hs.lex.sml 13 | parse.sml 14 | link-option.sml 15 | ghc-prim-type.sml 16 | ghc-prim-op.sml 17 | normalize.sml 18 | in 19 | structure CoreHs 20 | structure CoreHsUtils 21 | structure CoreHsPrims 22 | structure CoreHsNormalize 23 | structure CoreHsLayout 24 | structure CoreHsParse 25 | structure GHCPrimType 26 | structure GHCPrimTypeLayout 27 | structure GHCPrimOp 28 | structure CoreHsLinkOption 29 | end 30 | 31 | -------------------------------------------------------------------------------- /compiler/haskell.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature HASKELL = 20 | sig 21 | val addPasses : Pass.driverInfo -> Pass.driverInfo 22 | val controls : Config.Control.control list 23 | val debugs : Config.Debug.debug list 24 | val features : Config.Feature.feature list 25 | val exts : (string * (unit, Mil.t * Config.t) Pass.processor) list 26 | val keeps : StringSet.t 27 | val stops : StringSet.t 28 | val langVersions : string list 29 | end; 30 | 31 | structure Haskell :> HASKELL = 32 | struct 33 | 34 | val modname = "Driver/Haskell" 35 | 36 | structure Chat = ChatF(type env = Config.t 37 | fun extract x = x 38 | val name = modname 39 | val indent = 0) 40 | 41 | structure FrontEndHs = 42 | struct 43 | val description = {name = "FrontEndHs", 44 | description = "Compile HS (*.hs or *.lhs) to GHC Core (*.hcr)", 45 | inIr = Pass.unitHelpers, 46 | outIr = Pass.unitHelpers, 47 | mustBeAfter = [], 48 | stats = []} 49 | val associates = {controls = [], 50 | debugs = [], 51 | features = [], 52 | subPasses = []} 53 | fun frontEnd ext ((), pd, path) = 54 | let 55 | val config = PassData.getConfig pd 56 | val fe = Path.fromString "ghc" 57 | val path = Config.pathToHostString (config, path) ^ "." ^ ext 58 | val args = ["-D__PPILER__", "--make", "-c", "-fforce-recomp", "-fext-core"] 59 | @ List.rev (Config.ghcOpt config) @ [path] 60 | in 61 | Pass.run (config, Chat.log0, fe, args) 62 | end 63 | 64 | fun pass ext = Pass.mkFilePass (description, associates, frontEnd ext) 65 | end (* FrontEndHs *) 66 | 67 | val topLevelPassesUU = [FrontEndHs.pass "hs"] 68 | val topLevelPassesUC = [CoreHsParse.pass] 69 | val topLevelPassesCC = [CoreHsNormalize.pass] 70 | val topLevelPassesCA = [CoreHsToANormLazy.pass] 71 | val topLevelPassesAA = [ANormLazyStrictness.pass] 72 | val topLevelPassesAS = [ANormLazyToStrict.pass] 73 | val topLevelPassesSS = [ANormStrictOptimize.pass] 74 | val topLevelPassesCL = [ANormStrictClosureConvert.pass] 75 | val topLevelPassesFM = [ANormStrictToMil.pass] 76 | val topLevelPassesMM = [CoreHsLinkOption.pass] 77 | 78 | fun addPasses x = 79 | let 80 | val x = List.fold (topLevelPassesUU, x, Pass.addPassDriverInfo) 81 | val x = List.fold (topLevelPassesUC, x, Pass.addPassDriverInfo) 82 | val x = List.fold (topLevelPassesCC, x, Pass.addPassDriverInfo) 83 | val x = List.fold (topLevelPassesCA, x, Pass.addPassDriverInfo) 84 | val x = List.fold (topLevelPassesAA, x, Pass.addPassDriverInfo) 85 | val x = List.fold (topLevelPassesAS, x, Pass.addPassDriverInfo) 86 | val x = List.fold (topLevelPassesSS, x, Pass.addPassDriverInfo) 87 | val x = List.fold (topLevelPassesCL, x, Pass.addPassDriverInfo) 88 | val x = List.fold (topLevelPassesFM, x, Pass.addPassDriverInfo) 89 | val x = List.fold (topLevelPassesMM, x, Pass.addPassDriverInfo) 90 | in x 91 | end 92 | 93 | val controls = CoreHsLayout.controls @ ANormLazyLayout.controls @ 94 | ANormStrictLayout.controls 95 | 96 | val debugs = ANormStrictLayout.debugs 97 | 98 | val features = [] 99 | 100 | local 101 | 102 | val doPass = Pass.doPass 103 | val stopAt = Pass.stopAt 104 | val >> = Pass.>> 105 | infixr >> 106 | 107 | in 108 | 109 | val doGhcCore = 110 | doPass CoreHsParse.pass >> 111 | doPass CoreHsLinkOption.pass >> 112 | stopAt "hsc" >> Pass.first ( 113 | doPass CoreHsNormalize.pass >> 114 | doPass CoreHsToANormLazy.pass >> 115 | doPass ANormLazyStrictness.pass >> 116 | doPass ANormLazyToStrict.pass >> 117 | doPass ANormStrictOptimize.pass >> 118 | doPass ANormStrictClosureConvert.pass >> 119 | stopAt "ans" >> 120 | doPass ANormStrictToMil.pass) 121 | 122 | fun doGhc ext = 123 | doPass (FrontEndHs.pass ext) >> 124 | doGhcCore 125 | 126 | end 127 | 128 | val exts = 129 | [("hcr", doGhcCore), 130 | ("hs", doGhc "hs"), 131 | ("lhs", doGhc "lhs")] 132 | 133 | val keeps = StringSet.fromList ["hcr"] 134 | 135 | val stops = StringSet.fromList ["hsc", "ans"] 136 | 137 | val langVersion = "GHC 7.6.3" 138 | 139 | val langVersions = [langVersion] 140 | 141 | end; 142 | -------------------------------------------------------------------------------- /compiler/hrc.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | (* Import libraries *) 20 | $(SML_LIB)/mlton/sources.mlb 21 | 22 | (* Files for the project *) 23 | common/common.mlb 24 | core-hs/core-hs.mlb 25 | anorm-lazy/anorm-lazy.mlb 26 | anorm-strict/anorm-strict.mlb 27 | ch-to-as/ch-to-as.mlb 28 | as-to-mil/as-to-mil.mlb 29 | mil/mil.mlb 30 | mil/imil/imil.mlb 31 | mil/compile.mlb 32 | back-end/back-end.mlb 33 | version.sml 34 | driver.sml 35 | haskell.sml 36 | hrc.sml 37 | -------------------------------------------------------------------------------- /compiler/hrc.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | (* This version can compile Haskell *) 20 | 21 | local 22 | 23 | val addPasses = Haskell.addPasses 24 | val controls = Haskell.controls 25 | val debugs = Haskell.debugs 26 | val features = Haskell.features 27 | val exts = Haskell.exts 28 | val keeps = Haskell.keeps 29 | val stops = Haskell.stops 30 | val langVersions = Haskell.langVersions 31 | 32 | structure D = Driver (val addPasses = addPasses 33 | val controls = controls 34 | val debugs = debugs 35 | val features = features 36 | val exts = exts 37 | val keeps = keeps 38 | val stops = stops 39 | val langVersions = langVersions) 40 | 41 | in 42 | 43 | val () = D.main () 44 | 45 | end 46 | -------------------------------------------------------------------------------- /compiler/mil/bound-vars.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | (* Provides utilities for extracting the set of bound variables from 20 | some mil AST subtree *) 21 | 22 | signature MIL_BOUND = 23 | sig 24 | type t 25 | val rhs : Config.t * Mil.rhs -> t 26 | val instruction : Config.t * Mil.instruction -> t 27 | val call : Config.t * Mil.call -> t 28 | val eval : Config.t * Mil.eval -> t 29 | val transfer : Config.t * Mil.transfer -> t 30 | val block : Config.t * Mil.label * Mil.block -> t 31 | val blocks : Config.t * Mil.block Mil.LD.t -> t 32 | val codeBody : Config.t * Mil.codeBody -> t 33 | val code : Config.t * Mil.code -> t 34 | val global : Config.t * Mil.variable * Mil.global -> t 35 | val program : Config.t * Mil.t -> t 36 | end; 37 | 38 | structure MilBoundVarsLabels :> MIL_BOUND where type t = Mil.VS.t * Mil.LS.t = 39 | struct 40 | structure VS = Identifier.VariableSet 41 | structure LS = Identifier.LabelSet 42 | 43 | type t = VS.t * LS.t 44 | 45 | datatype state = S of (VS.t ref * LS.t ref) 46 | 47 | fun mkState () = S (ref VS.empty, ref LS.empty) 48 | fun finish (S (vr, lr)) = (!vr, !lr) 49 | 50 | fun varBind (s as S (vs, ls), e, v) = 51 | let 52 | val () = vs := VS.insert (!vs, v) 53 | in e 54 | end 55 | 56 | fun labelBind (s as S (vs, ls), e, l) = 57 | let 58 | val () = ls := LS.insert (!ls, l) 59 | in e 60 | end 61 | 62 | structure MA = MilAnalyseF ( 63 | struct 64 | type state = state 65 | type env = Config.t 66 | fun config c = c 67 | val indent = 2 68 | val externBind = SOME varBind 69 | val variableBind = SOME varBind 70 | val labelBind = SOME labelBind 71 | val variableUse = NONE 72 | val analyseJump = NONE 73 | val analyseCut = NONE 74 | val analyseConstant = NONE 75 | val analyseInstruction = NONE 76 | val analyseTransfer = NONE 77 | val analyseBlock = NONE 78 | val analyseGlobal = NONE 79 | end) 80 | 81 | fun mk1 af = 82 | fn (config, x) => 83 | let 84 | val state = mkState () 85 | val _ = af (state, config, x) 86 | in 87 | finish state 88 | end 89 | 90 | fun mk2 af = 91 | fn (config, x, y) => 92 | let 93 | val state = mkState () 94 | val _ = af (state, config, x, y) 95 | in 96 | finish state 97 | end 98 | 99 | val rhs = mk1 MA.analyseRhs 100 | val instruction = mk1 MA.analyseInstruction 101 | val call = mk1 MA.analyseCall 102 | val eval = mk1 MA.analyseEval 103 | val transfer = mk1 (fn (state, config, y) => MA.analyseTransfer (state, config, NONE, y)) 104 | val block = mk2 MA.analyseBlock 105 | val blocks = mk1 MA.analyseBlocks 106 | val codeBody = mk1 MA.analyseCodeBody 107 | val code = mk1 MA.analyseCode 108 | val global = mk2 MA.analyseGlobal 109 | val program = mk1 MA.analyseProgram 110 | 111 | end; 112 | 113 | structure MilBoundVars :> MIL_BOUND where type t = Mil.VS.t = 114 | struct 115 | type t = Mil.VS.t 116 | structure MBVL = MilBoundVarsLabels 117 | 118 | val rhs = #1 o MBVL.rhs 119 | val instruction = #1 o MBVL.instruction 120 | val call = #1 o MBVL.call 121 | val eval = #1 o MBVL.eval 122 | val transfer = #1 o MBVL.transfer 123 | val block = #1 o MBVL.block 124 | val blocks = #1 o MBVL.blocks 125 | val codeBody = #1 o MBVL.codeBody 126 | val code = #1 o MBVL.code 127 | val global = #1 o MBVL.global 128 | val program = #1 o MBVL.program 129 | 130 | end; 131 | 132 | structure MilBoundLabels :> MIL_BOUND where type t = Mil.LS.t = 133 | struct 134 | type t = Mil.LS.t 135 | structure MBVL = MilBoundVarsLabels 136 | 137 | val rhs = #2 o MBVL.rhs 138 | val instruction = #2 o MBVL.instruction 139 | val call = #2 o MBVL.call 140 | val eval = #2 o MBVL.eval 141 | val transfer = #2 o MBVL.transfer 142 | val block = #2 o MBVL.block 143 | val blocks = #2 o MBVL.blocks 144 | val codeBody = #2 o MBVL.codeBody 145 | val code = #2 o MBVL.code 146 | val global = #2 o MBVL.global 147 | val program = #2 o MBVL.program 148 | 149 | end; 150 | -------------------------------------------------------------------------------- /compiler/mil/code-copy.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature MIL_CODE_COPY = 20 | sig 21 | type 'a t = Config.t * Mil.symbolTableManager * 'a -> 'a * (Mil.variable Mil.VD.t * Mil.label Mil.LD.t) 22 | val program : Mil.t t 23 | val global : (Mil.variable * Mil.global) t 24 | val code : Mil.code t 25 | val codeBody : Mil.codeBody t 26 | val block : (Mil.label * Mil.block) t 27 | val instruction : Mil.instruction t 28 | val transfer : Mil.transfer t 29 | end; 30 | 31 | structure MilCodeCopy :> MIL_CODE_COPY = 32 | struct 33 | 34 | type 'a t = Config.t * Mil.symbolTableManager * 'a -> 'a * (Mil.variable Mil.VD.t * Mil.label Mil.LD.t) 35 | 36 | structure LD = Mil.LD 37 | structure VD = Mil.VD 38 | structure LS = Mil.LS 39 | structure VS = Mil.VS 40 | structure M = Mil 41 | structure MRC = MilRewriterClient 42 | structure MBVL = MilBoundVarsLabels 43 | structure MSTM = MilUtils.SymbolTableManager 44 | structure MR = MilRename.VarLabel 45 | 46 | fun mkRename (c, stm, vs, ls) = 47 | let 48 | val dupVar = 49 | fn (v, vd) => VD.insert (vd, v, MSTM.variableClone (stm, v)) 50 | val vd = VS.fold (vs, VD.empty, dupVar) 51 | val dupLabel = 52 | fn (l, ld) => LD.insert (ld, l, MSTM.labelFresh (stm)) 53 | val ld = LS.fold (ls, LD.empty, dupLabel) 54 | val rename = (vd, ld) 55 | in rename 56 | end 57 | 58 | fun block (c, stm, (l, b)) = 59 | let 60 | val (vs, ls) = MBVL.block (c, l, b) 61 | val r = mkRename (c, stm, vs, ls) 62 | val (l, b) = MR.block (c, r, l, b) 63 | in ((l, b), r) 64 | end 65 | 66 | fun global (c, stm, (v, g)) = 67 | let 68 | val (vs, ls) = MBVL.global (c, v, g) 69 | val r = mkRename (c, stm, vs, ls) 70 | val (v, g) = MR.global (c, r, v, g) 71 | in ((v, g), r) 72 | end 73 | 74 | fun instruction (c, stm, i) = 75 | let 76 | val (vs, ls) = MBVL.instruction (c, i) 77 | val r = mkRename (c, stm, vs, ls) 78 | val i = MR.instruction (c, r, i) 79 | in (i, r) 80 | end 81 | 82 | fun transfer (c, stm, t) = 83 | let 84 | val (vs, ls) = MBVL.transfer (c, t) 85 | val r = mkRename (c, stm, vs, ls) 86 | val t = MR.transfer (c, r, t) 87 | in (t, r) 88 | end 89 | 90 | fun codeBody (c, stm, cb) = 91 | let 92 | val (vs, ls) = MBVL.codeBody (c, cb) 93 | val r = mkRename (c, stm, vs, ls) 94 | val cb = MR.codeBody (c, r, cb) 95 | in (cb, r) 96 | end 97 | 98 | fun code (c, stm, cd) = 99 | let 100 | val (vs, ls) = MBVL.code (c, cd) 101 | val r = mkRename (c, stm, vs, ls) 102 | val cd = MR.code (c, r, cd) 103 | in (cd, r) 104 | end 105 | 106 | fun program (c, stm, p) = 107 | let 108 | val (vs, ls) = MBVL.program (c, p) 109 | val r = mkRename (c, stm, vs, ls) 110 | val p = MR.program (c, r, p) 111 | in (p, r) 112 | end 113 | 114 | end; 115 | -------------------------------------------------------------------------------- /compiler/mil/compile.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | local 20 | $(SML_LIB)/mlton/sources.mlb 21 | ../common/common.mlb 22 | mil.mlb 23 | imil/imil.mlb 24 | optimise/optimise.mlb 25 | lower/lower.mlb 26 | compile.sml 27 | in 28 | structure BothMil 29 | structure MilCompile 30 | end 31 | -------------------------------------------------------------------------------- /compiler/mil/free-vars.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature MIL_FREE_VARS = 20 | sig 21 | type t 22 | val rhs : t * Mil.rhs -> Identifier.VariableSet.t 23 | val instruction : t * Mil.instruction -> Identifier.VariableSet.t 24 | val call : t * Mil.call -> Identifier.VariableSet.t 25 | val eval : t * Mil.eval -> Identifier.VariableSet.t 26 | val transfer : t * Mil.transfer -> Identifier.VariableSet.t 27 | val block : t * Mil.label * Mil.block -> Identifier.VariableSet.t 28 | val blocks : t * Mil.block Mil.LD.t -> Identifier.VariableSet.t 29 | val codeBody : t * Mil.codeBody -> Identifier.VariableSet.t 30 | val global : t * Mil.variable * Mil.global -> Identifier.VariableSet.t 31 | val program : t * Mil.t -> Identifier.VariableSet.t 32 | end; 33 | 34 | structure MilFreeVars :> MIL_FREE_VARS where type t = Config.t = 35 | struct 36 | type t = Config.t 37 | 38 | structure VS = Identifier.VariableSet 39 | 40 | datatype state = S of {frees : VS.t ref, bound : VS.t ref} 41 | 42 | fun mkState () = S {frees = ref VS.empty, bound = ref VS.empty} 43 | fun finish (S {frees, bound, ...}) = VS.difference (!frees, !bound) 44 | 45 | fun varUse (s as S {frees, ...}, e, v) = 46 | let 47 | val () = frees := VS.insert (!frees, v) 48 | in () 49 | end 50 | 51 | fun varBind (s as S {bound, ...}, e, v) = 52 | let 53 | val () = bound := VS.insert (!bound, v) 54 | in e 55 | end 56 | 57 | structure MA = MilAnalyseF ( 58 | struct 59 | type state = state 60 | type env = Config.t 61 | fun config c = c 62 | val indent = 2 63 | val externBind = SOME varBind 64 | val variableBind = SOME varBind 65 | val labelBind = NONE 66 | val variableUse = SOME varUse 67 | val analyseJump = NONE 68 | val analyseCut = NONE 69 | val analyseConstant = NONE 70 | val analyseInstruction = NONE 71 | val analyseTransfer = NONE 72 | val analyseBlock = NONE 73 | val analyseGlobal = NONE 74 | end) 75 | 76 | fun mk1 af = 77 | fn (config, x) => 78 | let 79 | val state = mkState () 80 | val _ = af (state, config, x) 81 | in finish state 82 | end 83 | 84 | fun mk2 af = 85 | fn (config, x, y) => 86 | let 87 | val state = mkState () 88 | val _ = af (state, config, x, y) 89 | in finish state 90 | end 91 | 92 | val rhs = mk1 MA.analyseRhs 93 | val instruction = mk1 MA.analyseInstruction 94 | val call = mk1 MA.analyseCall 95 | val eval = mk1 MA.analyseEval 96 | val transfer = mk1 (fn (state, config, y) => MA.analyseTransfer (state, config, NONE, y)) 97 | val block = mk2 MA.analyseBlock 98 | val blocks = mk1 MA.analyseBlocks 99 | val codeBody = mk1 MA.analyseCodeBody 100 | val global = mk2 MA.analyseGlobal 101 | val program = mk1 MA.analyseProgram 102 | 103 | end; 104 | -------------------------------------------------------------------------------- /compiler/mil/imil/both-mil.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | signature BOTH_MIL = 19 | sig 20 | datatype t = Mil of Mil.t | IMil of IMil.t 21 | val toMil : PassData.t * t -> Mil.t 22 | val toIMil : PassData.t * t -> IMil.t 23 | val layout : t * Config.t -> Layout.t 24 | val stater : t * Config.t -> Layout.t 25 | val irHelpers : t Pass.irHelpers 26 | val mkMilPass : (Mil.t * PassData.t -> Mil.t) -> (t * PassData.t -> t) 27 | val mkIMilPass' : (IMil.t * PassData.t -> IMil.t) -> (t * PassData.t -> t) 28 | val mkIMilPass : (IMil.t * PassData.t -> unit) -> (t * PassData.t -> t) 29 | val out : t -> Mil.t 30 | end 31 | 32 | 33 | 34 | structure BothMil :> BOTH_MIL = 35 | struct 36 | datatype t = Mil of Mil.t | IMil of IMil.t 37 | fun out p = 38 | case p 39 | of Mil p => p 40 | | IMil p => IMil.T.unBuild p 41 | fun toMil (pd, p) = out p 42 | fun toIMil (pd, p) = 43 | case p 44 | of Mil p => IMil.T.build (PassData.getConfig pd, p) 45 | | IMil p => p 46 | fun layout (p, c) = 47 | case p 48 | of Mil p => MilExtendedLayout.layout (c, p) 49 | | IMil p => MilExtendedLayout.layout (c, IMil.T.unBuild p) 50 | fun stater (p, c) = 51 | case p 52 | of Mil p => MilStats.layout (MilStats.O {id = NONE}) (p, c) 53 | | IMil p => MilStats.layout (MilStats.O {id = NONE}) (IMil.T.unBuild p, c) 54 | val irHelpers = {printer = layout, stater = stater} 55 | fun mkMilPass f = fn (p, pd) => Mil (f (toMil (pd, p), pd)) 56 | fun mkIMilPass' f = fn (p, pd) => IMil (f (toIMil (pd, p), pd)) 57 | fun mkIMilPass f = 58 | mkIMilPass' 59 | (fn (p, pd) => 60 | let 61 | val () = f (p, pd) 62 | in p 63 | end) 64 | end 65 | 66 | -------------------------------------------------------------------------------- /compiler/mil/imil/common.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature IMIL_COMMON = 20 | sig 21 | val passname : string 22 | 23 | structure Chat : CHAT where type env = IMilTypes.t 24 | structure FV : MIL_FREE_VARS where type t = IMilTypes.t 25 | structure VLRN : RENAMER where type t = Rename.t * IMilTypes.label Identifier.LabelDict.t 26 | val debugPassD : Config.Debug.debug 27 | val debugPass : Config.t -> bool 28 | val debugDo : IMilTypes.t * (unit -> unit) -> unit 29 | end 30 | 31 | structure IMilCommon :> IMIL_COMMON = 32 | struct 33 | 34 | val passname = "IMil" 35 | 36 | structure IMT = IMilTypes 37 | structure Chat = ChatF (struct 38 | type env = IMilTypes.t 39 | val extract = IMilTypes.tGetConfig 40 | val name = passname 41 | val indent = 2 42 | end) 43 | 44 | structure FV = 45 | struct 46 | open MilFreeVars 47 | type t = IMT.t 48 | val lift2 = 49 | fn f => fn (t, b) => f (IMT.tGetConfig t, b) 50 | val lift3 = 51 | fn f => fn (t, l, b) => f (IMT.tGetConfig t, l, b) 52 | val rhs = lift2 rhs 53 | val instruction = lift2 instruction 54 | val call = lift2 call 55 | val eval = lift2 eval 56 | val transfer = lift2 transfer 57 | val block = lift3 block 58 | val blocks = lift2 blocks 59 | val codeBody = lift2 codeBody 60 | val global = lift3 global 61 | val program = lift2 program 62 | end 63 | 64 | structure VLRN = MilRename.VarLabel 65 | 66 | 67 | val (debugPassD, debugPass) = 68 | Config.Debug.mk (passname, "debug the IMil module") 69 | 70 | fun debugDo (p, f) = 71 | if Config.debug andalso debugPass (IMilTypes.tGetConfig p) 72 | then f () 73 | else () 74 | 75 | 76 | end 77 | -------------------------------------------------------------------------------- /compiler/mil/imil/def.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature IMIL_DEF = 20 | sig 21 | include IMIL_PUBLIC_TYPES 22 | 23 | val add : t * variable * def -> unit 24 | val get : t * variable -> def 25 | val delete : t * variable -> unit 26 | val toItem : t * def -> item option 27 | val defsToItems : t * def Vector.t -> item Vector.t 28 | 29 | val toIInstr : def -> iInstr option 30 | val toIGlobal : def -> iGlobal option 31 | 32 | val toInstruction : def -> Mil.instruction option 33 | val toRhs : def -> Mil.rhs option 34 | val toTransfer : def -> Mil.transfer option 35 | val toLabel : def -> (Mil.label * Mil.variable vector) option 36 | val toGlobal : def -> (Mil.variable * Mil.global) option 37 | val toMilDef : def -> MilUtils.Def.t option 38 | val layout : t * def -> Layout.t 39 | 40 | end 41 | structure IMilDef : 42 | sig 43 | include IMIL_DEF 44 | end 45 | = 46 | struct 47 | open IMilPublicTypes 48 | 49 | structure IMC = IMilCommon 50 | structure IMT = IMilTypes 51 | structure IVD = IMilTypes.IVD 52 | structure MU = MilUtils 53 | structure Chat = IMC.Chat 54 | 55 | val fail = 56 | fn (f, s) => Fail.fail ("def.sml", f, s) 57 | 58 | val get = 59 | fn (p, v) => 60 | let 61 | val defs = IMT.tGetDefs p 62 | val d = 63 | case IVD.lookup (defs, v) 64 | of SOME d => d 65 | | NONE => 66 | let 67 | val s = (Layout.toString o IMilLayout.var) (p, v) 68 | val () = Chat.warn1 (p, "Def.getDef: " ^ "Unknown variable: "^s) 69 | in IMT.DefUnk 70 | end 71 | in d 72 | end 73 | 74 | val add = 75 | fn (p, v, d) => 76 | let 77 | val defs = IMT.tGetDefs p 78 | val () = IVD.insert (defs, v, d) 79 | in () 80 | end 81 | 82 | val delete = 83 | fn (p, v) => 84 | let 85 | val defs = IMT.tGetDefs p 86 | val () = IVD.insert (defs, v, IMT.DefUnk) 87 | in () 88 | end 89 | 90 | val toIInstr = IMT.defToIInstr 91 | val toIGlobal = IMT.defToIGlobal 92 | val toIFunc = IMT.defToIFunc 93 | 94 | val toInstruction = Utils.Option.compose (IMT.iInstrToInstruction, toIInstr) 95 | val toRhs = Utils.Option.compose (IMT.iInstrToRhs, toIInstr) 96 | val toTransfer = Utils.Option.compose (IMT.iInstrToTransfer, toIInstr) 97 | val toLabel = Utils.Option.compose (IMT.iInstrToLabel, toIInstr) 98 | val toGlobal = Utils.Option.compose (IMT.iGlobalToGlobal, toIGlobal) 99 | 100 | val toItem = 101 | fn (p, def) => 102 | (case def 103 | of IMT.DefUnk => NONE 104 | | IMT.DefExtern => NONE 105 | | IMT.DefInstr i => SOME (IMT.ItemInstr i) 106 | | IMT.DefGlobal g => SOME (IMT.ItemGlobal g) 107 | | IMT.DefFunc c => SOME (IMT.ItemFunc c) 108 | | IMT.DefParameter c => SOME (IMT.ItemFunc c)) 109 | 110 | val defsToItems = 111 | fn (p, defs) => Vector.keepAllMap (defs, fn d => toItem (p, d)) 112 | 113 | val toMilDef = 114 | fn def => 115 | (case def 116 | of IMT.DefGlobal g => 117 | (case IMT.iGlobalGetMil g 118 | of IMT.GGlobal (v, mg) => SOME (MU.Def.DefGlobal mg) 119 | | _ => NONE) 120 | | IMT.DefInstr i => 121 | (case IMT.iInstrGetMil i 122 | of IMT.MInstr (Mil.I {dests, n, rhs}) => SOME (MU.Def.DefRhs rhs) 123 | | _ => NONE) 124 | | IMT.DefFunc c => NONE 125 | | IMT.DefParameter c => NONE 126 | | IMT.DefExtern => NONE 127 | | IMT.DefUnk => NONE) 128 | 129 | val layout = IMilLayout.def 130 | end 131 | -------------------------------------------------------------------------------- /compiler/mil/imil/imil.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | local 20 | $(SML_LIB)/mlton/sources.mlb 21 | ../../common/common.mlb 22 | ../mil.mlb 23 | types.sml 24 | enumerate.sml 25 | layout.sml 26 | common.sml 27 | use.sml 28 | def.sml 29 | var.sml 30 | instr.sml 31 | global.sml 32 | block.sml 33 | func.sml 34 | item.sml 35 | workset.sml 36 | t.sml 37 | imil.sml 38 | both-mil.sml 39 | in 40 | structure BothMil 41 | structure IMil 42 | end 43 | -------------------------------------------------------------------------------- /compiler/mil/imil/item.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature IMIL_ITEM = 20 | sig 21 | include IMIL_PUBLIC_TYPES 22 | 23 | val getUses : t * item -> use Vector.t 24 | val getUsedBy : t * item -> item Vector.t 25 | val freeVars : t * item -> Identifier.VariableSet.t 26 | val freeVars' : t * item -> Mil.variable list 27 | val delete : t * item -> unit 28 | 29 | val toIInstr : item -> iInstr option 30 | val toIGlobal : item -> iGlobal option 31 | val toIFunc : item -> iFunc option 32 | 33 | val toInstruction : item -> Mil.instruction option 34 | val toRhs : item -> Mil.rhs option 35 | val toTransfer : item -> Mil.transfer option 36 | val toLabel : item -> (Mil.label * Mil.variable vector) option 37 | val toGlobal : item -> (Mil.variable * Mil.global) option 38 | 39 | val fx : t * item -> Effect.set 40 | 41 | val splitUses' : t * item * use Vector.t -> {inits : use Vector.t, others : use Vector.t} 42 | val splitUses : t * item -> {inits : use Vector.t, others : use Vector.t} 43 | 44 | val layout : t * item -> Layout.t 45 | val print : t * item -> unit 46 | end 47 | 48 | structure IMilItem : 49 | sig 50 | include IMIL_ITEM 51 | val itemGetId : item -> int 52 | end 53 | = 54 | struct 55 | open IMilPublicTypes 56 | 57 | structure IMT = IMilTypes 58 | structure Global = IMilGlobal 59 | structure Instr = IMilInstr 60 | structure Func = IMilFunc 61 | 62 | datatype item = datatype IMT.item 63 | 64 | val itemGetId = 65 | fn i => 66 | case i 67 | of ItemInstr i => IMT.iInstrGetId i 68 | | ItemGlobal g => IMT.iGlobalGetId g 69 | | ItemFunc c => IMT.iFuncGetId c 70 | 71 | val getId = 72 | fn (p, i) => itemGetId i 73 | 74 | val getUses = 75 | fn (p, i) => 76 | case i 77 | of ItemInstr i => Instr.getUses (p, i) 78 | | ItemGlobal g => Global.getUses (p, g) 79 | | ItemFunc c => Func.getUses (p, c) 80 | 81 | val getUsedBy = 82 | fn (p, i) => 83 | let 84 | val items = 85 | case i 86 | of ItemInstr i => Instr.getUsedBy (p, i) 87 | | ItemGlobal g => Global.getUsedBy (p, g) 88 | | ItemFunc c => Func.getUsedBy (p, c) 89 | 90 | in items 91 | end 92 | 93 | local 94 | val gen = 95 | fn (fi, gi, ci) => 96 | fn (p, i) => 97 | let 98 | val items = 99 | case i 100 | of ItemInstr i => fi (p, i) 101 | | ItemGlobal g => gi (p, g) 102 | | ItemFunc c => ci (p, c) 103 | 104 | in items 105 | end 106 | in 107 | val freeVars = gen (Instr.freeVars, Global.freeVars, Func.freeVars) 108 | val freeVars' = gen (Instr.freeVars', Global.freeVars', Func.freeVars') 109 | end 110 | 111 | val delete = 112 | fn (p, i) => 113 | case i 114 | of ItemInstr i => Instr.delete (p, i) 115 | | ItemGlobal g => Global.delete (p, g) 116 | | ItemFunc c => Func.delete (p, c) 117 | 118 | val toIInstr = IMT.itemToIInstr 119 | val toIGlobal = IMT.itemToIGlobal 120 | val toIFunc = IMT.itemToIFunc 121 | 122 | val toInstruction = Utils.Option.compose (IMT.iInstrToInstruction, toIInstr) 123 | val toRhs = Utils.Option.compose (IMT.iInstrToRhs, toIInstr) 124 | val toTransfer = Utils.Option.compose (IMT.iInstrToTransfer, toIInstr) 125 | val toLabel = Utils.Option.compose (IMT.iInstrToLabel, toIInstr) 126 | val toGlobal = Utils.Option.compose (IMT.iGlobalToGlobal, toIGlobal) 127 | 128 | val fx = 129 | fn (imil, i) => 130 | (case i 131 | of IMT.ItemInstr i => Instr.fx (imil, i) 132 | | IMT.ItemGlobal g => Effect.Total 133 | | IMT.ItemFunc c => Effect.Total) 134 | 135 | val splitUses' = 136 | fn (t, i, us) => 137 | (case toIInstr i 138 | of SOME i => Instr.splitUses' (t, i, us) 139 | | NONE => {inits = Vector.new0(), others = us}) 140 | 141 | val splitUses = 142 | fn (t, i) => splitUses' (t, i, getUses (t, i)) 143 | 144 | val layout = 145 | fn (imil, i) => IMilLayout.item (imil, i) 146 | 147 | val print = LayoutUtils.printLayout o layout 148 | 149 | end 150 | -------------------------------------------------------------------------------- /compiler/mil/imil/var.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature IMIL_VAR = 20 | sig 21 | include IMIL_PUBLIC_TYPES 22 | 23 | val new : t * string * Mil.typ * Mil.variableKind -> variable 24 | val clone : t * variable -> variable 25 | val related : t * variable * string * Mil.typ * Mil.variableKind -> variable 26 | val setInfo : t * variable * Mil.typ * Mil.variableKind -> unit 27 | val getInfo : t * variable -> Mil.typ * Mil.variableKind 28 | val kind : t * variable -> Mil.variableKind 29 | val typ : t * variable -> Mil.typ 30 | val fieldKind : t * variable -> Mil.fieldKind 31 | val print : t * variable -> unit 32 | val layout : t * variable -> Layout.t 33 | 34 | val labelFresh : t -> label 35 | end 36 | 37 | structure IMilVar : 38 | sig 39 | include IMIL_VAR 40 | end 41 | = 42 | struct 43 | open IMilPublicTypes 44 | 45 | structure M = Mil 46 | structure IM = MilUtils.SymbolTableManager 47 | structure IMT = IMilTypes 48 | structure Def = IMilDef 49 | 50 | val fail = 51 | fn (f, s) => Fail.fail ("var.sml", f, s) 52 | 53 | val new = 54 | fn (p, hint, t, g) => 55 | let 56 | val v = IM.variableFresh (IMT.tGetStm p, hint, t, g) 57 | val () = Def.add (p, v, IMT.DefUnk) 58 | in v 59 | end 60 | 61 | val clone = 62 | fn (p, v) => 63 | let 64 | val v = IM.variableClone (IMT.tGetStm p, v) 65 | val () = Def.add (p, v, IMT.DefUnk) 66 | in v 67 | end 68 | 69 | val related = 70 | fn (p, b, hint, t, k) => 71 | let 72 | val v = IM.variableRelated (IMT.tGetStm p, b, hint, t, k) 73 | val () = Def.add (p, v, IMT.DefUnk) 74 | in v 75 | end 76 | 77 | val setInfo = 78 | fn (p, v, t, k) => 79 | let 80 | val v = IM.variableSetInfo (IMT.tGetStm p, v, M.VI {typ = t, kind = k}) 81 | in () 82 | end 83 | 84 | val getInfo = 85 | fn (p, b) => 86 | let 87 | val M.VI {typ, kind} = IM.variableInfo (IMT.tGetStm p, b) 88 | in (typ, kind) 89 | end 90 | 91 | val kind = 92 | fn (p, v) => IM.variableKind (IMT.tGetStm p, v) 93 | 94 | val typ = 95 | fn (p, v) => 96 | IM.variableTyp (IMT.tGetStm p, v) 97 | 98 | val fieldKind = 99 | fn (p, v) => MilUtils.FieldKind.fromTyp (IMT.tGetConfig p, typ (p, v)) 100 | 101 | val layout = IMilLayout.var 102 | 103 | val print = LayoutUtils.printLayout o layout 104 | 105 | val labelFresh = 106 | fn p => 107 | Identifier.Manager.labelFresh (IMT.tGetStm p) 108 | 109 | 110 | end 111 | -------------------------------------------------------------------------------- /compiler/mil/imil/workset.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature IMIL_WORKSET = 20 | sig 21 | include IMIL_PUBLIC_TYPES 22 | 23 | type ws 24 | val new : unit -> ws 25 | val addAll : ws * t -> unit 26 | val addAllInstrs : ws * t -> unit 27 | val addUses : ws * (use Vector.t) -> unit 28 | val addItem : ws * item -> unit 29 | val addItems : ws * (item Vector.t) -> unit 30 | val addInstr : ws * iInstr -> unit 31 | val addGlobal : ws * iGlobal -> unit 32 | val addCode : ws * iFunc -> unit 33 | val hasWork : ws -> bool 34 | val chooseWork : ws -> item option 35 | val clear : ws -> unit 36 | end 37 | 38 | structure IMilWorkSet : 39 | sig 40 | include IMIL_WORKSET 41 | end 42 | = 43 | struct 44 | open IMilPublicTypes 45 | 46 | structure IMT = IMilTypes 47 | structure IVD = IMT.IVD 48 | structure IID = ImpIntDict 49 | structure Enumerate = IMilEnumerate 50 | structure Item = IMilItem 51 | 52 | datatype ws = WS of {items : IMT.item IID.t} 53 | 54 | val new = 55 | fn () => WS {items = IID.empty ()} 56 | 57 | val addItem = 58 | fn (WS {items}, i) => 59 | let 60 | val id = Item.itemGetId i 61 | val () = IID.insert (items, id, i) 62 | in () 63 | end 64 | 65 | val addInstr = 66 | fn (ws, i) => addItem (ws, IMT.ItemInstr i) 67 | val addGlobal = 68 | fn (ws, g) => addItem (ws, IMT.ItemGlobal g) 69 | val addCode = 70 | fn (ws, c) => addItem (ws, IMT.ItemFunc c) 71 | 72 | val addAllInstrs = 73 | fn (ws, p) => 74 | let 75 | val addInstr = 76 | fn i => addInstr (ws, i) 77 | val instrs = Enumerate.T.instructions p 78 | val () = List.foreach (instrs, addInstr) 79 | in () 80 | end 81 | 82 | val addAll = 83 | fn (ws, p) => 84 | let 85 | val addGlobal = 86 | fn (_, g) => addGlobal (ws, g) 87 | val addInstr = 88 | fn i => addInstr (ws, i) 89 | val addCode = 90 | fn (_, c) => addCode (ws, c) 91 | val () = 92 | IVD.foreach (IMT.tGetIGlobals p, 93 | addGlobal) 94 | val instrs = Enumerate.T.instructions p 95 | val () = List.foreach (instrs, addInstr) 96 | val cfgs = IVD.foreach (IMT.tGetIFuncs p, 97 | addCode) 98 | in () 99 | end 100 | 101 | val addUse = 102 | fn (ws, use) => 103 | case use 104 | of IMT.Used => () 105 | | IMT.UseInstr i => addInstr (ws, i) 106 | | IMT.UseGlobal g => addGlobal (ws, g) 107 | 108 | 109 | 110 | val addUses = 111 | fn (ws, uses) => Vector.foreach (uses, fn u => addUse (ws, u)) 112 | val addItems = 113 | fn (ws, items) => Vector.foreach (items, fn i => addItem (ws, i)) 114 | 115 | val hasWork = 116 | fn (WS {items}) => not (IID.isEmpty items) 117 | 118 | val chooseWork = 119 | fn (WS {items}) => 120 | (case IID.choose items 121 | of SOME (_, w) => SOME w 122 | | NONE => NONE) 123 | 124 | val clear = fn (WS {items}) => IID.clear items 125 | 126 | end 127 | -------------------------------------------------------------------------------- /compiler/mil/lower/lower.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | local 20 | $(SML_LIB)/mlton/sources.mlb 21 | ../../common/common.mlb 22 | ../mil.mlb 23 | ../imil/imil.mlb 24 | mil-to-core-mil.sml 25 | vector.sml 26 | in 27 | structure MilLowerClosures 28 | structure MilLowerPSums 29 | structure MilLowerPTypes 30 | structure MilLowerVector 31 | end 32 | -------------------------------------------------------------------------------- /compiler/mil/mil.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | local 20 | $(SML_LIB)/mlton/sources.mlb 21 | ../common/common.mlb 22 | prims.sml 23 | mil.sml 24 | prims-utils.sml 25 | utils.sml 26 | layout.sml 27 | cfg.sml 28 | rewrite.sml 29 | number-instructions.sml 30 | fmil.sml 31 | p-object-model.sml 32 | type.sml 33 | check.sml 34 | analyse.sml 35 | stats.sml 36 | free-vars.sml 37 | bound-vars.sml 38 | rename.sml 39 | code-copy.sml 40 | stream.sml 41 | stream2.sml 42 | transform.sml 43 | loop.sml 44 | extended-layout.sml 45 | name-small-values.sml 46 | call-graph.sml 47 | utils2.sml 48 | parse.sml 49 | profile.sml 50 | dataflow-analysis.sml 51 | dependence-analysis.sml 52 | in 53 | signature MIL_FREE_VARS 54 | signature RENAMER 55 | 56 | functor MilAnalyseF 57 | functor MilRewriterF 58 | functor MilStreamF 59 | functor MilStreamUtilsF 60 | functor MilTransformF 61 | 62 | structure FMil 63 | structure Mil 64 | structure MilCallGraph 65 | structure MilCfg 66 | structure MilCheck 67 | structure MilFragment 68 | structure MilFreeVars 69 | structure MilBoundVars 70 | structure MilCodeCopy 71 | structure MilLayout 72 | structure MilExtendedLayout 73 | structure MilLoop 74 | structure MilNameSmallValues 75 | structure MilNumberInstructions 76 | structure MilParse 77 | structure MilRename 78 | structure MilRewriterClient 79 | structure MilStats 80 | structure MilStream 81 | structure MilType 82 | structure MilUtils 83 | structure MilUtils2 84 | structure PObjectModelCommon 85 | structure PObjectModelHigh 86 | structure PObjectModelLow 87 | 88 | functor MilProfilerF 89 | functor MilDataFlowAnalysisF 90 | functor MilDependenceAnalysisF 91 | end 92 | -------------------------------------------------------------------------------- /compiler/mil/name-small-values.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature MIL_NAME_SMALL_VALUES = 20 | sig 21 | val program : Config.t 22 | * (Mil.constant -> bool) 23 | * Mil.t 24 | -> Mil.t 25 | end 26 | 27 | structure MilNameSmallValues :> MIL_NAME_SMALL_VALUES = 28 | struct 29 | structure I = Identifier 30 | structure IM = Identifier.Manager 31 | structure VD = I.VariableDict 32 | structure M = Mil 33 | structure MSTM = MilUtils.SymbolTableManager 34 | structure MRC = MilRewriterClient 35 | 36 | datatype state = S of {stm : M.symbolTableManager, globals : (M.variable * M.global) list ref} 37 | 38 | datatype env = E of {name : M.constant -> bool, config : Config.t} 39 | 40 | local 41 | val getS = fn g => fn (S t) => g t 42 | val getE = fn g => fn (E t) => g t 43 | in 44 | val stateGetStm = getS #stm 45 | val stateGetGlobals = getS #globals 46 | val envGetConfig = getE #config 47 | val envGetName = getE #name 48 | end 49 | 50 | val stateBindGlobal = 51 | fn (state, t, oper) => 52 | let 53 | val v = MSTM.variableFresh (stateGetStm state, "mnm_#", t, M.VkGlobal) 54 | val g = M.GSimple oper 55 | val globals = stateGetGlobals state 56 | val () = globals := (v, g) :: !globals 57 | in v 58 | end 59 | 60 | val nameOperand = 61 | fn (env, opnd) => 62 | (case opnd 63 | of M.SVariable _ => false 64 | | M.SConstant c => envGetName env c) 65 | 66 | structure TO = MilType.Typer 67 | 68 | val bind = 69 | fn (state, env, oper) => 70 | let 71 | val c = envGetConfig env 72 | val si = I.SymbolInfo.SiManager (stateGetStm state) 73 | val t = TO.operand (c, si, oper) 74 | val v = stateBindGlobal (state, t, oper) 75 | in M.SVariable v 76 | end 77 | 78 | structure Rewrite = 79 | MilRewriterF (struct 80 | type state = state 81 | type env = env 82 | val config = envGetConfig 83 | val label = fn _ => MRC.Continue 84 | val variable = fn _ => MRC.Continue 85 | val operand = 86 | fn (state, env, oper) => 87 | if nameOperand (env, oper) then 88 | MRC.StopWith (env, bind (state, env, oper)) 89 | else 90 | MRC.Stop 91 | val instruction = fn _ => MRC.Continue 92 | val transfer = fn _ => MRC.Continue 93 | val block = fn _ => MRC.Continue 94 | val global = fn _ => MRC.Continue 95 | val bind = fn (_, env, _) => (env, NONE) 96 | val bindLabel = fn (_, env, _) => (env, NONE) 97 | val indent = 2 98 | val cfgEnum = fn (_, _, t) => MilUtils.CodeBody.dfsTrees t 99 | end) 100 | 101 | 102 | val program = 103 | fn (config, name, p) => 104 | let 105 | val M.P {symbolTable, ...} = p 106 | val stm = IM.fromExistingAll symbolTable 107 | val glist = ref [] 108 | val state = S {stm = stm, globals = glist} 109 | val env = E {name = name, config = config} 110 | val M.P {includes, externs, symbolTable, globals, entry} = Rewrite.program (state, env, p) 111 | val st = IM.finish stm 112 | val globals = VD.insertAll (globals, !glist) 113 | val p = M.P {includes = includes, externs = externs, symbolTable = st, globals = globals, entry = entry} 114 | in p 115 | end 116 | 117 | end; 118 | -------------------------------------------------------------------------------- /compiler/mil/number-instructions.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature MIL_NUMBER_INSTRUCTIONS = 20 | sig 21 | (* Label every instruction in the program with a unique integer id. 22 | * Returns the numbered mil, and an integer guaranteed to be 23 | * greater than the largest instruction id. 24 | *) 25 | val program : Config.t * Mil.t -> Mil.t * int 26 | val globals : Config.t * Mil.globals -> Mil.globals * int 27 | val code : Config.t * Mil.code -> Mil.code * int 28 | val codeBody : Config.t * Mil.codeBody -> Mil.codeBody * int 29 | end (* MIL_NUMBER_INSTRUCTIONS *) 30 | 31 | structure MilNumberInstructions :> MIL_NUMBER_INSTRUCTIONS = 32 | struct 33 | structure MU = MilUtils 34 | structure MRC = MilRewriterClient 35 | structure M = Mil 36 | 37 | datatype state = S of {next : int ref} 38 | 39 | datatype env = E of {config : Config.t} 40 | 41 | val id = fn S {next} => Utils.Ref.inc next 42 | 43 | val instr = 44 | fn (state, env, M.I {dests, n, rhs}) => MRC.StopWith (env, M.I {dests = dests, n = id state, rhs = rhs}) 45 | 46 | structure R = 47 | MilRewriterF (struct 48 | type env = env 49 | type state = state 50 | val config = fn (E {config}) => config 51 | val label = fn _ => MRC.Stop 52 | val variable = fn _ => MRC.Stop 53 | val operand = fn _ => MRC.Stop 54 | val instruction = instr 55 | val transfer = fn _ => MRC.Stop 56 | val block = fn _ => MRC.Continue 57 | val global = fn _ => MRC.Continue 58 | val bind = fn (_, env, _) => (env, NONE) 59 | val bindLabel = fn (_, env, _) => (env, NONE) 60 | val indent = 2 61 | val cfgEnum = fn (_, _, t) => MilUtils.CodeBody.dfsTrees t 62 | end) 63 | 64 | val number = 65 | fn f => 66 | fn (config, obj) => 67 | let 68 | val next = ref 0 69 | val state = S {next = next} 70 | val env = E {config = config} 71 | val obj = f (state, env, obj) 72 | in (obj, !next) 73 | end 74 | 75 | val code = number R.code 76 | val codeBody = number R.codeBody 77 | val globals = (fn ((env, gs), i) => (gs, i)) o (number R.globals) 78 | val program = number R.program 79 | 80 | end (* MilNumberInstructions *) 81 | -------------------------------------------------------------------------------- /compiler/mil/optimise/optimise.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | local 20 | $(SML_LIB)/mlton/sources.mlb 21 | ../../common/common.mlb 22 | ../mil.mlb 23 | ../imil/imil.mlb 24 | cse.sml 25 | contify.sml 26 | fx-analysis.sml 27 | cfg-simplify.sml 28 | (* fun-known.sml *) 29 | simple-escape.sml 30 | 31 | simplify.sml 32 | double-diamond.sml 33 | licm.sml 34 | inline-rewrite.sml 35 | annotated-cg-printer.sml 36 | inline-aggressive.sml 37 | inline-profile.sml 38 | inline-leaves.sml 39 | inline-small.sml 40 | rep/rep.mlb 41 | thunks.sml 42 | branch-remove.sml 43 | loop-invert.sml 44 | iv-cse.sml 45 | vectorize.sml 46 | in 47 | structure MilContify 48 | structure MilCse 49 | structure MilDblDiamond 50 | structure MilFxAnalysis 51 | structure MilLicm 52 | structure MilRemoveBranch 53 | structure MilRep 54 | structure MilSimplify 55 | structure MilThunkOptimize 56 | structure MilVectorize 57 | structure MilInlineAggressive 58 | structure MilInlineLeaves 59 | structure MilInlineProfile 60 | structure MilInlineSmall 61 | structure MilLoopInvert 62 | structure MilIvCse 63 | end 64 | -------------------------------------------------------------------------------- /compiler/mil/optimise/rep/base.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature MIL_REP_BASE = 20 | sig 21 | 22 | datatype 'node iInfo = 23 | IiCode of {cargs : 'node Mil.callConv, args : 'node Vector.t, returns : 'node Vector.t} 24 | | IiMetaData of {pinned : bool, fixed : 'node Vector.t, array : (int * 'node) option} 25 | | IiTupleDescriptor of {fixed : 'node Vector.t, array : 'node option} 26 | | IiThunk of {typ : 'node, fvs : 'node Vector.t} 27 | | IiClosure of 'node Vector.t 28 | | IiSum of 'node * ('node Vector.t) 29 | 30 | val layoutIInfo : Config.t * Mil.symbolInfo * 'node iInfo * ('node -> Layout.t) -> Layout.t 31 | 32 | structure NameIntDict : DICT where type key = Mil.name * int 33 | datatype 'a edge = EUnify of 'a * 'a | EFlow of 'a * 'a 34 | 35 | end (* signature MIL_REP_BASE *) 36 | 37 | structure MilRepBase :> MIL_REP_BASE = 38 | struct 39 | structure M = Mil 40 | structure MU = MilUtils 41 | structure LU = LayoutUtils 42 | structure L = Layout 43 | structure PD = PassData 44 | 45 | datatype 'node iInfo = 46 | IiCode of {cargs : 'node Mil.callConv, args : 'node Vector.t, returns : 'node Vector.t} 47 | | IiMetaData of {pinned : bool, fixed : 'node Vector.t, array : (int * 'node) option} 48 | | IiTupleDescriptor of {fixed : 'node Vector.t, array : 'node option} 49 | | IiThunk of {typ : 'node, fvs : 'node Vector.t} 50 | | IiClosure of 'node Vector.t 51 | | IiSum of 'node * ('node Vector.t) 52 | 53 | val layoutIInfo = 54 | fn (config, si, info, node) => 55 | let 56 | val vector = fn nv => Vector.toListMap (nv, node) 57 | val l = 58 | (case info 59 | of IiCode {cargs, args, returns} => 60 | let 61 | val cargs = MilLayout.layoutCallConv (fn (_, _, n) => node n) (config, si, cargs) 62 | val args = LU.parenSeq (vector args) 63 | val returns = L.seq [L.str " => ", LU.parenSeq (vector returns)] 64 | in L.mayAlign [cargs, args, returns] 65 | end 66 | | IiMetaData {pinned, fixed, array} => 67 | let 68 | val pinned = if pinned then L.str "!" else L.str "" 69 | val fixed = vector fixed 70 | val array = 71 | (case array 72 | of NONE => [] 73 | | SOME (i, n) => [LU.bracket (L.seq [Int.layout i, L.str " : ", node n])]) 74 | val elts = LU.angleSeq (fixed @ array) 75 | in L.mayAlign [L.seq [L.str "MetaData ", (* pok, *) pinned], elts] 76 | end 77 | | IiTupleDescriptor {fixed, array} => 78 | let 79 | val fixed = vector fixed 80 | val array = 81 | (case array 82 | of NONE => [] 83 | | SOME n => [LU.bracket (node n)]) 84 | val elts = LU.angleSeq (fixed @ array) 85 | in L.mayAlign [L.str "TupleDesc ", elts] 86 | end 87 | | IiThunk {typ, fvs} => 88 | L.seq [L.str "Thunk", LU.paren (node typ), LU.angleSeq (vector fvs)] 89 | | IiClosure fvs => 90 | L.seq [L.str "Closure", LU.angleSeq (vector fvs)] 91 | | IiSum (n, v) => 92 | L.seq [L.str "Sum", LU.paren (node n), LU.angleSeq (vector v)]) 93 | in l 94 | end 95 | 96 | structure NameIntDict = DictF (struct 97 | type t = Mil.name * int 98 | val compare = Compare.pair (Identifier.nameCompare, Int.compare) 99 | end) 100 | 101 | datatype 'a edge = EUnify of 'a * 'a | EFlow of 'a * 'a 102 | 103 | end (* structure MilRepBase *) 104 | -------------------------------------------------------------------------------- /compiler/mil/optimise/rep/rep.mlb: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | local 20 | $(SML_LIB)/mlton/sources.mlb 21 | ../../../common/common.mlb 22 | ../../mil.mlb 23 | ../../imil/imil.mlb 24 | seq.sml 25 | base.sml 26 | object.sml 27 | prep.sml 28 | node.sml 29 | summary.sml 30 | analyze.sml 31 | reconstruct.sml 32 | show.sml 33 | flowgraph.sml 34 | driver.sml 35 | optimize.sml 36 | flatten.sml 37 | dead-code.sml 38 | rep.sml 39 | in 40 | structure MilRep 41 | end 42 | -------------------------------------------------------------------------------- /compiler/mil/optimise/rep/rep.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | structure MilRep :> 20 | sig 21 | val debugs : Config.Debug.debug list 22 | val features : Config.Feature.feature list 23 | structure Flatten : MIL_REP_PASS 24 | structure Dce : MIL_REP_PASS 25 | structure Optimize : MIL_REP_PASS 26 | end = 27 | struct 28 | val debugs = MilRepPrep.debugs 29 | @ MilRepReconstruct.debugs 30 | 31 | val features = MilRepPrep.features 32 | @ MilRepReconstruct.features 33 | 34 | structure Flatten :> MIL_REP_PASS = MilRepDriverF(structure Optimization = MilRepFlattenOptimization) 35 | structure Dce :> MIL_REP_PASS = MilRepDriverF(structure Optimization = MilRepDceOptimization) 36 | structure Optimize :> MIL_REP_PASS = MilRepDriverF(structure Optimization = MilRepOptimization) 37 | 38 | end (* structure MilRep *) 39 | 40 | 41 | -------------------------------------------------------------------------------- /compiler/mil/optimise/rep/show.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature MIL_REP_SHOW = 20 | sig 21 | val annotate : PassData.t * MilRepSummary.summary * Mil.t -> Mil.t 22 | val printAnalysis : PassData.t * MilRepSummary.summary * Mil.t -> unit 23 | val printReasons : PassData.t * MilRepSummary.summary * Mil.t -> unit 24 | end (* signature MIL_REP_SHOW *) 25 | 26 | structure MilRepShow :> MIL_REP_SHOW = 27 | struct 28 | structure PD = PassData 29 | structure M = Mil 30 | structure MU = MilUtils 31 | structure ST = Identifier 32 | structure STM = Identifier.Manager 33 | 34 | structure MRB = MilRepBase 35 | structure MRS = MilRepSummary 36 | structure Node = MilRepNode 37 | 38 | structure ID = IntDict 39 | structure VD = Mil.VD 40 | structure LD = Mil.LD 41 | structure ND = Mil.ND 42 | structure VS = Mil.VS 43 | structure LS = Mil.LS 44 | structure I = Identifier 45 | structure IVD = I.ImpVariableDict 46 | structure L = Layout 47 | structure LU = LayoutUtils 48 | 49 | val annotate = 50 | fn (pd, summary, p) => 51 | let 52 | val M.P {includes, externs, entry, globals, symbolTable} = p 53 | val stm = STM.fromExistingNoInfo symbolTable 54 | val renameVar = 55 | fn (v, rename) => 56 | if MRS.variableHasNode (summary, v) then 57 | let 58 | val info = ST.variableInfo (symbolTable, v) 59 | val id = MRS.variableClassId (summary, v) 60 | val string = Int.toString id 61 | val string = 62 | if MRS.variableUsesKnown (summary, v) then 63 | string 64 | else 65 | string ^ "^" 66 | val string = 67 | if MRS.variableDefsKnown (summary, v) then 68 | string 69 | else 70 | string ^ "?" 71 | val string = "id="^string 72 | val string = 73 | let 74 | val info = STM.variableString (stm, v) 75 | val info = 76 | case String.findSubstring (info, {substring = ".id="}) 77 | of SOME i => String.prefix (info, i) 78 | | NONE => info 79 | val string = info^"."^string 80 | in string 81 | end 82 | val newv = STM.variableFresh (stm, string, info) 83 | in Rename.renameTo (rename, v, newv) 84 | end 85 | else 86 | let 87 | val info = ST.variableInfo (symbolTable, v) 88 | val () = STM.variableSetInfo (stm, v, info) 89 | in rename 90 | end 91 | val keepVar = 92 | fn v => 93 | let 94 | val info = ST.variableInfo (symbolTable, v) 95 | val () = STM.variableSetInfo (stm, v, info) 96 | in () 97 | end 98 | val vars = STM.variablesList stm 99 | val (vars, varsE) = 100 | let 101 | val extern = 102 | fn v => (case MilUtils.SymbolTable.variableKind (symbolTable, v) 103 | of Mil.VkExtern => true 104 | | _ => false) 105 | val {yes, no} = List.partition (vars, extern) 106 | in (no, yes) 107 | end 108 | val rename = List.fold (vars, Rename.none, renameVar) 109 | val () = List.foreach (varsE, keepVar) 110 | val st = STM.finish stm 111 | val p = M.P {includes = includes, externs = externs, entry = entry, globals = globals, symbolTable = st} 112 | val p = MilRename.Var.program (PD.getConfig pd, rename, p) 113 | in p 114 | end 115 | 116 | 117 | val printAnalysis = 118 | fn (pd, summary, p) => 119 | let 120 | val l = MilRepSummary.layout (summary, Identifier.SymbolInfo.SiTable (MU.Program.symbolTable p)) 121 | val l = L.align [L.str "ANALYSIS RESULTS", 122 | LU.indent l] 123 | in LayoutUtils.printLayout l 124 | end 125 | 126 | val printReasons = 127 | fn (pd, summary, p) => 128 | let 129 | val l = MilRepSummary.layoutReasons (summary, Identifier.SymbolInfo.SiTable (MU.Program.symbolTable p)) 130 | val l = L.align [L.str "ANALYSIS ESCAPE/INTRUDES REASONS", 131 | LU.indent l] 132 | in LayoutUtils.printLayout l 133 | end 134 | 135 | end (* structure MilRepShow *) 136 | -------------------------------------------------------------------------------- /compiler/mil/stats.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature MIL_STATS = 20 | sig 21 | datatype options = O of {id: string option} 22 | val layout : options -> Mil.t * Config.t -> Layout.t 23 | val program : Config.t * options * Mil.t * Out.t -> unit 24 | end; 25 | 26 | structure MilStats :> MIL_STATS = 27 | struct 28 | 29 | val passname = "MilStats" 30 | 31 | structure M = Mil 32 | 33 | datatype options = O of {id: string option} 34 | 35 | datatype env = E of {config: Config.t, options: options} 36 | 37 | fun envMk (c, opts) = E {config = c, options = opts} 38 | 39 | datatype state = S of { 40 | globals : int ref, 41 | funs : int ref, 42 | blocks : int ref, 43 | instrs : int ref, 44 | calls : int ref, 45 | tailcalls : int ref 46 | } 47 | 48 | fun stateMk () = 49 | S {globals = ref 0, funs = ref 0, blocks = ref 0, instrs = ref 0, 50 | calls = ref 0, tailcalls = ref 0} 51 | 52 | fun incr r = r := (!r) + 1 53 | 54 | fun incGlobals (S {globals, ...}) = incr globals 55 | fun incFuns (S {funs, ...}) = incr funs 56 | fun incBlocks (S {blocks, ...}) = incr blocks 57 | fun incInstrs (S {instrs, ...}) = incr instrs 58 | fun incCalls (S {calls, ...}) = incr calls 59 | fun incTailcalls (S {tailcalls, ...}) = incr tailcalls 60 | 61 | fun analyseInstruction (s, e, _) = 62 | let 63 | val () = incInstrs s 64 | in e 65 | end 66 | 67 | fun analyseInterProc (s, e, ip, r) = 68 | case (ip, r) 69 | of (M.IpCall _, M.RNormal _) => let val () = incCalls s in e end 70 | | (M.IpCall _, M.RTail _) => let val () = incTailcalls s in e end 71 | | _ => e 72 | 73 | fun analyseTransfer (s, e, l, t) = 74 | case t 75 | of M.TInterProc {callee, ret, ...} => 76 | analyseInterProc (s, e, callee, ret) 77 | | _ => e 78 | 79 | fun analyseBlock (s, e, _ , _) = 80 | let 81 | val () = incBlocks s 82 | in e 83 | end 84 | 85 | fun analyseGlobal (s, e, _, g) = 86 | let 87 | val () = incGlobals s 88 | val () = 89 | case g 90 | of M.GCode _ => incFuns s 91 | | _ => () 92 | in e 93 | end 94 | 95 | structure MA = MilAnalyseF(type state = state 96 | type env = env 97 | fun config (E {config, ...}) = config 98 | val indent = 2 99 | val externBind = NONE 100 | val variableBind = NONE 101 | val labelBind = NONE 102 | val variableUse = NONE 103 | val analyseJump = NONE 104 | val analyseCut = NONE 105 | val analyseConstant = NONE 106 | val analyseInstruction = SOME analyseInstruction 107 | val analyseTransfer = SOME analyseTransfer 108 | val analyseBlock = SOME analyseBlock 109 | val analyseGlobal = SOME analyseGlobal) 110 | 111 | local 112 | open Layout 113 | in 114 | 115 | fun layoutStats (O {id, ...}, s) = 116 | let 117 | val S {globals, funs, blocks, instrs, calls, tailcalls} = s 118 | fun doOne (s, r) = seq [str (" Number of " ^ s), Int.layout (!r)] 119 | val l = align [doOne ("globals: ", globals), 120 | doOne ("funs: ", funs), 121 | doOne ("blocks: ", blocks), 122 | doOne ("instrs: ", instrs), 123 | doOne ("calls: ", calls), 124 | doOne ("tailcalls: ", tailcalls)] 125 | val l = 126 | case id 127 | of NONE => l 128 | | SOME id => 129 | align [str ("---------- Stats for: " ^ id), 130 | l, 131 | str ("---------- End stats for: " ^ id ^ "\n")] 132 | in l 133 | end 134 | 135 | end 136 | 137 | fun layout opts (p, config) = 138 | let 139 | val s = stateMk () 140 | val e = envMk (config, opts) 141 | val () = MA.analyseProgram (s, e, p) 142 | val l = layoutStats (opts, s) 143 | in l 144 | end 145 | 146 | fun program (config, opts, p, out) = 147 | Layout.outputWidth (layout opts (p, config), 78, out) 148 | 149 | end; 150 | -------------------------------------------------------------------------------- /compiler/mil/utils2.sml: -------------------------------------------------------------------------------- 1 | (* The Haskell Research Compiler *) 2 | (* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | *) 17 | 18 | 19 | signature MIL_UTILS2 = 20 | sig 21 | val irHelpers : Mil.t Pass.irHelpers 22 | end; 23 | 24 | structure MilUtils2 :> MIL_UTILS2 = 25 | struct 26 | 27 | val statOptions = MilStats.O {id = NONE} 28 | 29 | val irHelpers = {printer = fn (p, c) => MilLayout.layout (c, p), 30 | stater = MilStats.layout statOptions} 31 | 32 | end; 33 | 34 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | # -*- Autoconf -*- 2 | # Process this file with autoconf to produce a configure script. 3 | 4 | AC_PREREQ([2.60]) 5 | AC_INIT([hrc], [0.1], [BUG-REPORT-ADDRESS]) 6 | 7 | AC_CHECK_HEADERS([assert.h float.h immintrin.h limits.h locale.h malloc.h math.h nmmintrin.h signal.h stdarg.h stdio.h stdlib.h string.h time.h sys/time.h sys/timeb.h termios.h]) 8 | 9 | PKG_CHECK_MODULES([FLRC_LIB], [flrc-lib]) 10 | 11 | PLATFORM_CPPFLAGS= 12 | AC_CANONICAL_HOST 13 | case "$host" in 14 | *-mingw*|*-*-cygwin*) 15 | ;; 16 | *-*-linux*) 17 | PLATFORM_CPPFLAGS="-DPLSR_LINUX" 18 | ;; 19 | *) 20 | AC_MSG_ERROR([Unsupported host: $host]) 21 | ;; 22 | esac 23 | 24 | AC_SUBST([PLATFORM_CPPFLAGS]) 25 | 26 | AM_SUBST_NOTMAKE 27 | AC_CONFIG_FILES([Makefile]) 28 | AC_OUTPUT 29 | -------------------------------------------------------------------------------- /doc/flrc-pipeline.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IntelLabs/flrc/2f8ae042eeefbe39527609bcd03e5a5c8fd1e392/doc/flrc-pipeline.png -------------------------------------------------------------------------------- /runtime/ghc/Globals.c: -------------------------------------------------------------------------------- 1 | /* The Haskell Research Compiler */ 2 | /* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | */ 17 | 18 | #include 19 | #include "hrc/plsr-util.h" 20 | #include "hrc/ghc/Globals.h" 21 | 22 | static void* ihrStore[ISK_Num] = {NULL, }; 23 | static struct prtMutex* ihrStoreLock; 24 | 25 | /* hard code n_capabilities to 1 for now */ 26 | unsigned int n_capabilities_ = 1; 27 | unsigned int* n_capabilities = &n_capabilities_; 28 | 29 | void ihrSetNCapabilities(uint32 n) { 30 | *n_capabilities = n; 31 | } 32 | 33 | void ihrGlobalInit() 34 | { 35 | ihrStoreLock = prtMutexCreate(NULL); 36 | assert(ihrStoreLock); 37 | } 38 | 39 | void* getOrSetKey(IhrStoreKey k, void* p) 40 | { 41 | void* ret = ihrStore[k]; 42 | if (!ret) { 43 | uint32 status; 44 | status = prtMutexLock(ihrStoreLock); 45 | assert(!status); 46 | ret = ihrStore[k]; 47 | if (!ret) ihrStore[k] = ret = p; 48 | status = prtMutexUnlock(ihrStoreLock); 49 | assert(!status); 50 | } 51 | return ret; 52 | } 53 | 54 | void* getOrSetSystemEventThreadEventManagerStore(void* p) 55 | { 56 | return getOrSetKey(ISK_SystemEventThreadEventManager, p); 57 | } 58 | 59 | void* getOrSetSystemEventThreadIOManagerThreadStore(void* p) 60 | { 61 | return getOrSetKey(ISK_SystemEventThreadIOManager, p); 62 | } 63 | 64 | void* getOrSetGHCConcWindowsPendingDelaysStore(void* p) 65 | { 66 | return getOrSetKey(ISK_GHCConcWindowsPendingDelays, p); 67 | } 68 | 69 | void* getOrSetGHCConcWindowsIOManagerThreadStore(void* p) 70 | { 71 | return getOrSetKey(ISK_GHCConcWindowsIOManagerThread, p); 72 | } 73 | 74 | void* getOrSetGHCConcWindowsProddingStore(void* p) 75 | { 76 | return getOrSetKey(ISK_GHCConcWindowsProdding, p); 77 | } 78 | 79 | void* getOrSetGHCConcSignalSignalHandlerStore(void* p) 80 | { 81 | return getOrSetKey(ISK_GHCConcSignalSignalHandler, p); 82 | } 83 | 84 | void sysErrorBelch(char* s) {} 85 | 86 | void blockUserSignals() {} 87 | 88 | void unblockUserSignals() {} 89 | 90 | void stopTimer() {} 91 | 92 | void startTimer() {} 93 | 94 | void stackOverflow() {} 95 | 96 | int lockFile(int fd, uint64 dev, uint64 ino, int for_writing) { return 0; } 97 | 98 | int unlockFile(int fd) { return 0; } 99 | 100 | uint64 getMonotonicNSec() { return pLsrEventsTimeStamp() * 100; } 101 | -------------------------------------------------------------------------------- /runtime/ghc/TTY.c: -------------------------------------------------------------------------------- 1 | /* The Haskell Research Compiler */ 2 | /* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | */ 17 | 18 | /* ----------------------------------------------------------------------------- 19 | * 20 | * (c) The GHC Team, 1998-2009 21 | * 22 | * TTY-related functionality 23 | * 24 | * ---------------------------------------------------------------------------*/ 25 | /* 26 | #include "PosixSource.h" 27 | #include "Rts.h" 28 | 29 | #include "RtsUtils.h" // __hscore_get/set prototypes 30 | #include "TTY.h" 31 | */ 32 | #ifdef HAVE_TERMIOS_H 33 | #include 34 | #endif 35 | #ifdef HAVE_SIGNAL_H 36 | #include 37 | #endif 38 | 39 | #include "hrc/ghc/TTY.h" 40 | 41 | // Here we save the terminal settings on the standard file 42 | // descriptors, if we need to change them (eg. to support NoBuffering 43 | // input). 44 | static void *saved_termios[3] = {NULL,NULL,NULL}; 45 | 46 | void* 47 | __hscore_get_saved_termios(I_ fd0) 48 | { 49 | int fd = (int) fd0; 50 | return (0 <= fd && fd < (int)(sizeof(saved_termios) / sizeof(*saved_termios))) ? 51 | saved_termios[fd] : NULL; 52 | } 53 | 54 | void 55 | __hscore_set_saved_termios(I_ fd0, void* ts) 56 | { 57 | int fd = (int) fd0; 58 | if (0 <= fd && fd < (int)(sizeof(saved_termios) / sizeof(*saved_termios))) { 59 | saved_termios[fd] = ts; 60 | } 61 | } 62 | 63 | void 64 | resetTerminalSettings (void) 65 | { 66 | #if HAVE_TERMIOS_H 67 | // Reset the terminal settings on the standard file descriptors, 68 | // if we changed them. See System.Posix.Internals.tcSetAttr for 69 | // more details, including the reason we termporarily disable 70 | // SIGTTOU here. 71 | { 72 | int fd; 73 | sigset_t sigset, old_sigset; 74 | sigemptyset(&sigset); 75 | sigaddset(&sigset, SIGTTOU); 76 | sigprocmask(SIG_BLOCK, &sigset, &old_sigset); 77 | for (fd = 0; fd <= 2; fd++) { 78 | struct termios* ts = (struct termios*)__hscore_get_saved_termios(fd); 79 | if (ts != NULL) { 80 | tcsetattr(fd,TCSANOW,ts); 81 | } 82 | } 83 | sigprocmask(SIG_SETMASK, &old_sigset, NULL); 84 | } 85 | #endif 86 | } 87 | -------------------------------------------------------------------------------- /runtime/ghc/float.c: -------------------------------------------------------------------------------- 1 | /* ----------------------------------------------------------------------------- 2 | * 3 | * (c) Lennart Augustsson 4 | * (c) The GHC Team, 1998-2000 5 | * 6 | * Miscellaneous support for floating-point primitives 7 | * 8 | * ---------------------------------------------------------------------------*/ 9 | 10 | #include 11 | #include 12 | #include "hrc/ghc/float.h" 13 | 14 | StgDouble 15 | __2Int_encodeDouble (I_ j_high, I_ j_low, I_ e) 16 | { 17 | StgDouble r; 18 | 19 | /* assuming 32 bit ints */ 20 | ASSERT(sizeof(int ) == 4 ); 21 | 22 | r = (StgDouble)((unsigned int)j_high); 23 | r *= 4294967296.0; /* exp2f(32); */ 24 | r += (StgDouble)((unsigned int)j_low); 25 | 26 | /* Now raise to the exponent */ 27 | if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ 28 | r = ldexp(r, e); 29 | 30 | /* sign is encoded in the size */ 31 | if (j_high < 0) 32 | r = -r; 33 | 34 | return r; 35 | } 36 | 37 | /* Special version for words */ 38 | StgDouble 39 | __word_encodeDouble (W_ j, I_ e) 40 | { 41 | StgDouble r; 42 | 43 | r = (StgDouble)j; 44 | 45 | /* Now raise to the exponent */ 46 | if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ 47 | r = ldexp(r, e); 48 | 49 | return r; 50 | } 51 | 52 | /* Special version for small Integers */ 53 | StgDouble 54 | __int_encodeDouble (I_ j, I_ e) 55 | { 56 | StgDouble r; 57 | 58 | r = (StgDouble)__abs(j); 59 | 60 | /* Now raise to the exponent */ 61 | if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ 62 | r = ldexp(r, e); 63 | 64 | /* sign is encoded in the size */ 65 | if (j < 0) 66 | r = -r; 67 | 68 | return r; 69 | } 70 | 71 | /* Special version for small Integers */ 72 | StgFloat 73 | __int_encodeFloat (I_ j, I_ e) 74 | { 75 | StgFloat r; 76 | 77 | r = (StgFloat)__abs(j); 78 | 79 | /* Now raise to the exponent */ 80 | if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ 81 | r = ldexp(r, e); 82 | 83 | /* sign is encoded in the size */ 84 | if (j < 0) 85 | r = -r; 86 | 87 | return r; 88 | } 89 | 90 | /* Special version for small positive Integers */ 91 | StgFloat 92 | __word_encodeFloat (W_ j, I_ e) 93 | { 94 | StgFloat r; 95 | 96 | r = (StgFloat)j; 97 | 98 | /* Now raise to the exponent */ 99 | if ( r != 0.0 ) /* Lennart suggests this avoids a bug in MIPS's ldexp */ 100 | r = ldexp(r, e); 101 | 102 | return r; 103 | } 104 | 105 | /* This only supports IEEE floating point */ 106 | 107 | void 108 | __decodeDouble_2Int (I_ *man_sign, W_ *man_high, W_ *man_low, I_ *exp, StgDouble dbl) 109 | { 110 | /* Do some bit fiddling on IEEE */ 111 | unsigned int low, high; /* assuming 32 bit ints */ 112 | int sign, iexp; 113 | union { double d; unsigned int i[2]; } u; /* assuming 32 bit ints, 64 bit double */ 114 | 115 | ASSERT(sizeof(unsigned int ) == 4 ); 116 | ASSERT(sizeof(dbl ) == 8 ); 117 | ASSERT(sizeof(dbl ) == SIZEOF_DOUBLE); 118 | 119 | u.d = dbl; /* grab chunks of the double */ 120 | low = u.i[L]; 121 | high = u.i[H]; 122 | 123 | if (low == 0 && (high & ~DMSBIT) == 0) { 124 | *man_low = 0; 125 | *man_high = 0; 126 | *exp = 0L; 127 | } else { 128 | iexp = ((high >> 20) & 0x7ff) + MY_DMINEXP; 129 | sign = high; 130 | 131 | high &= DHIGHBIT-1; 132 | if (iexp != MY_DMINEXP) /* don't add hidden bit to denorms */ 133 | high |= DHIGHBIT; 134 | else { 135 | iexp++; 136 | /* A denorm, normalize the mantissa */ 137 | while (! (high & DHIGHBIT)) { 138 | high <<= 1; 139 | if (low & DMSBIT) 140 | high++; 141 | low <<= 1; 142 | iexp--; 143 | } 144 | } 145 | *exp = (I_) iexp; 146 | *man_low = low; 147 | *man_high = high; 148 | *man_sign = (sign < 0) ? -1 : 1; 149 | } 150 | } 151 | 152 | /* Convenient union types for checking the layout of IEEE 754 types - 153 | based on defs in GNU libc 154 | */ 155 | 156 | void 157 | __decodeFloat_Int (I_ *man, I_ *exp, StgFloat flt) 158 | { 159 | /* Do some bit fiddling on IEEE */ 160 | int high, sign; /* assuming 32 bit ints */ 161 | union { float f; int i; } u; /* assuming 32 bit float and int */ 162 | 163 | ASSERT(sizeof(int ) == 4 ); 164 | ASSERT(sizeof(flt ) == 4 ); 165 | ASSERT(sizeof(flt ) == SIZEOF_FLOAT ); 166 | 167 | u.f = flt; /* grab the float */ 168 | high = u.i; 169 | 170 | if ((high & ~FMSBIT) == 0) { 171 | *man = 0; 172 | *exp = 0; 173 | } else { 174 | *exp = ((high >> 23) & 0xff) + MY_FMINEXP; 175 | sign = high; 176 | 177 | high &= FHIGHBIT-1; 178 | if (*exp != MY_FMINEXP) /* don't add hidden bit to denorms */ 179 | high |= FHIGHBIT; 180 | else { 181 | (*exp)++; 182 | /* A denorm, normalize the mantissa */ 183 | while (! (high & FHIGHBIT)) { 184 | high <<= 1; 185 | (*exp)--; 186 | } 187 | } 188 | *man = high; 189 | if (sign < 0) 190 | *man = - *man; 191 | } 192 | } 193 | -------------------------------------------------------------------------------- /runtime/ghc/plsr-util.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "hrc/pil.h" 4 | #include "hrc/plsr-util.h" 5 | 6 | /* Time in 100 ns intervals since January 1, 1601 */ 7 | uint64 pLsrEventsTimeStamp() 8 | { 9 | #ifdef PLSR_LINUX 10 | struct timeval tv; 11 | gettimeofday(&tv,NULL); 12 | uint64 time; 13 | time = (((uint64)tv.tv_sec) * 1000000) + ((uint64)tv.tv_usec); 14 | time *= 10; // convert from micro-seconds to 100-nanosecond intervals 15 | #else // PLSR_LINUX 16 | FILETIME now; 17 | uint32 lowTime; 18 | uint32 highTime; 19 | uint64 time; 20 | 21 | GetSystemTimeAsFileTime(&now); 22 | lowTime = now.dwLowDateTime; 23 | highTime = now.dwHighDateTime; 24 | 25 | time = ((uint64)highTime)<<32 | (uint64)lowTime; 26 | #endif // PLSR_LINUX 27 | return time; 28 | } 29 | 30 | void pLsrDisableErrorBox() 31 | { 32 | #ifndef PLSR_LINUX 33 | unsigned int mode = SetErrorMode(SEM_NOGPFAULTERRORBOX); 34 | SetErrorMode(mode | SEM_NOGPFAULTERRORBOX); 35 | #endif // PLSR_LINUX 36 | } 37 | -------------------------------------------------------------------------------- /runtime/ghc/thread.c: -------------------------------------------------------------------------------- 1 | /* The Haskell Research Compiler */ 2 | /* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | */ 17 | 18 | #include "hrc/ghc/thread.h" 19 | 20 | /* place holders for now */ 21 | I_ rts_getThreadId (W_ tid) 22 | { 23 | return (I_)tid; 24 | } 25 | 26 | I_ cmp_thread (W_ tidA, W_ tidB) 27 | { 28 | if (tidA > tidB) return 1; 29 | else if (tidA < tidB) return -1; 30 | else return 0; 31 | } 32 | 33 | I_ rtsSupportsBoundThreads() 34 | { 35 | return 0; 36 | } 37 | 38 | /*** IO Manager Stuff ***/ 39 | 40 | #if defined (__MINGW32__) || defined(WIN32) 41 | HANDLE getIOManagerEvent() 42 | { 43 | /* XXX NG: this is for a non-threaded runtime. */ 44 | return NULL; 45 | } 46 | 47 | W_ readIOManagerEvent() 48 | { 49 | /* XXX NG: this is for a non-threaded runtime. */ 50 | return 0; 51 | } 52 | 53 | void sendIOManagerEvent(W_ e) 54 | { 55 | /* XXX NG: this is for a non-threaded runtime. */ 56 | } 57 | #endif 58 | -------------------------------------------------------------------------------- /runtime/include/hrc/ghc/Globals.h: -------------------------------------------------------------------------------- 1 | /* The Haskell Research Compiler */ 2 | /* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | */ 17 | 18 | #ifndef _GHC_GLOBALS_H_ 19 | #define _GHC_GLOBALS_H_ 20 | 21 | #include "hrc/ghc/float.h" 22 | 23 | typedef enum { 24 | ISK_SystemEventThreadEventManager, ISK_SystemEventThreadIOManager, ISK_GHCConcWindowsPendingDelays, 25 | ISK_GHCConcWindowsIOManagerThread, ISK_GHCConcWindowsProdding, ISK_GHCConcSignalSignalHandler, ISK_Num 26 | } IhrStoreKey; 27 | 28 | void ihrSetNCapabilities(uint32 n); 29 | void ihrGlobalInit(); 30 | void* getOrSetKey(IhrStoreKey k, void* p); 31 | void* getOrSetSystemEventThreadEventManagerStore(void* p); 32 | void* getOrSetSystemEventThreadIOManagerThreadStore(void* p); 33 | void* getOrSetGHCConcWindowsPendingDelaysStore(void* p); 34 | void* getOrSetGHCConcWindowsIOManagerThreadStore(void* p); 35 | void* getOrSetGHCConcWindowsProddingStore(void* p); 36 | void* getOrSetGHCConcSignalSignalHandlerStore(void* p); 37 | void sysErrorBelch(char* s); 38 | void blockUserSignals(); 39 | void unblockUserSignals(); 40 | void stopTimer(); 41 | void startTimer(); 42 | void stackOverflow(); 43 | // int lockFile(int fd, uint64 dev, uint64 ino, int for_writing); 44 | // int unlockFile(int fd); 45 | uint64 getMonotonicNSec(); 46 | unsigned int *n_capabilities; 47 | 48 | #endif 49 | -------------------------------------------------------------------------------- /runtime/include/hrc/ghc/TTY.h: -------------------------------------------------------------------------------- 1 | /* The Haskell Research Compiler */ 2 | /* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | */ 17 | 18 | #ifndef _GHC_TTY_H_ 19 | #define _GHC_TTY_H_ 20 | 21 | #include "hrc/ghc/float.h" 22 | 23 | #ifdef HAVE_TERMIOS_H 24 | #include 25 | #endif 26 | #ifdef HAVE_SIGNAL_H 27 | #include 28 | #endif 29 | 30 | void* __hscore_get_saved_termios(I_ fd0); 31 | void __hscore_set_saved_termios(I_ fd0, void* ts); 32 | void resetTerminalSettings (void); 33 | 34 | #endif 35 | -------------------------------------------------------------------------------- /runtime/include/hrc/ghc/float.h: -------------------------------------------------------------------------------- 1 | /* ----------------------------------------------------------------------------- 2 | * 3 | * (c) Lennart Augustsson 4 | * (c) The GHC Team, 1998-2000 5 | * 6 | * Miscellaneous support for floating-point primitives 7 | * 8 | * ---------------------------------------------------------------------------*/ 9 | 10 | #ifndef _GHC_FLOAT_H_ 11 | #define _GHC_FLOAT_H_ 12 | 13 | #include 14 | #include 15 | #include 16 | #include "hrc/pil.h" 17 | 18 | #define IEEE_FLOATING_POINT 1 19 | 20 | /* 21 | * Encoding and decoding Doubles. Code based on the HBC code 22 | * (lib/fltcode.c). 23 | */ 24 | 25 | #if IEEE_FLOATING_POINT 26 | #define MY_DMINEXP ((DBL_MIN_EXP) - (DBL_MANT_DIG) - 1) 27 | /* DMINEXP is defined in values.h on Linux (for example) */ 28 | #define DHIGHBIT 0x00100000 29 | #define DMSBIT 0x80000000 30 | 31 | #define MY_FMINEXP ((FLT_MIN_EXP) - (FLT_MANT_DIG) - 1) 32 | #define FHIGHBIT 0x00800000 33 | #define FMSBIT 0x80000000 34 | #endif 35 | 36 | #if defined(WORDS_BIGENDIAN) || defined(FLOAT_WORDS_BIGENDIAN) 37 | #define L 1 38 | #define H 0 39 | #else 40 | #define L 0 41 | #define H 1 42 | #endif 43 | 44 | #define __abs(a) (( (a) >= 0 ) ? (a) : (-(a))) 45 | 46 | typedef void* StgStablePtr; 47 | #define ASSERT assert 48 | //typedef uint32 nat; 49 | typedef float StgFloat; 50 | typedef double StgDouble; 51 | typedef sintp I_; 52 | typedef uintp W_; 53 | #define SIZEOF_FLOAT 4 54 | #define SIZEOF_DOUBLE 8 55 | 56 | StgDouble __2Int_encodeDouble (I_ j_high, I_ j_low, I_ e); 57 | StgDouble __word_encodeDouble (W_ j, I_ e); 58 | StgDouble __int_encodeDouble (I_ j, I_ e); 59 | StgFloat __int_encodeFloat (I_ j, I_ e); 60 | StgFloat __word_encodeFloat (W_ j, I_ e); 61 | void __decodeDouble_2Int (I_ *man_sign, W_ *man_high, W_ *man_low, I_ *exp, StgDouble dbl); 62 | void __decodeFloat_Int (I_ *man, I_ *exp, StgFloat flt); 63 | 64 | #endif 65 | -------------------------------------------------------------------------------- /runtime/include/hrc/ghc/thread.h: -------------------------------------------------------------------------------- 1 | /* The Haskell Research Compiler */ 2 | /* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | */ 17 | 18 | #ifndef _GHC_THREAD_H_ 19 | #define _GHC_THREAD_H_ 20 | 21 | #include "hrc/ghc/float.h" 22 | 23 | I_ rts_getThreadId (W_ tid); 24 | I_ cmp_thread (W_ tidA, W_ tidB); 25 | I_ rtsSupportsBoundThreads(); 26 | 27 | #if defined (__MINGW32__) || defined(WIN32) 28 | HANDLE getIOManagerEvent(); 29 | W_ readIOManagerEvent(); 30 | void sendIOManagerEvent(W_ e); 31 | #endif 32 | 33 | #endif 34 | -------------------------------------------------------------------------------- /runtime/include/hrc/plsr-ap-integer.h: -------------------------------------------------------------------------------- 1 | /* The Haskell Research Compiler */ 2 | /* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | */ 17 | 18 | #ifdef PLSR_GMP_USE_DEFAULT 19 | #ifdef __pillar2c__ 20 | #define PLSR_GMP_USE_GALLOCATE 21 | #else /* ! __pillar2c__ */ 22 | #define PLSR_GMP_USE_PINNING 23 | #endif /* ! __pillar2c__ */ 24 | #endif /* !PLSR_GMP_USE_DEFAULT */ 25 | 26 | #ifdef PLSR_NO_GMP_INTEGERS 27 | #include "hrc/plsr-flrc-integer.h" 28 | #else /* !PLSR_NO_GMP_INTEGERS */ 29 | #ifdef PLSR_GMP_USE_GALLOCATE 30 | #include "hrc/plsr-gmp-integer-gallocate.h" 31 | #else /* !PLSR_GMP_USE_GALLOCATE */ 32 | #include "hrc/plsr-gmp-integer.h" 33 | #endif /* !PLSR_GMP_USE_GALLOCATE */ 34 | #endif /* !PLSR_NO_GMP_INTEGERS */ 35 | -------------------------------------------------------------------------------- /runtime/include/hrc/plsr-main.h: -------------------------------------------------------------------------------- 1 | /* The Haskell Research Compiler */ 2 | /* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | */ 17 | 18 | #ifndef _PLSR_MAIN_H_ 19 | #define _PLSR_MAIN_H_ 20 | 21 | #ifdef P_USE_PILLAR 22 | # define MAIN pillar_main 23 | #else 24 | # define MAIN main 25 | #endif 26 | 27 | /* C functions used for Runtime */ 28 | #ifdef P_USE_PILLAR 29 | # pragma pillar_managed(off) 30 | # define to __to__ 31 | #endif /* P_USE_PILLAR */ 32 | 33 | #include 34 | 35 | #ifdef P_USE_PILLAR 36 | # undef to 37 | # pragma pillar_managed(on) 38 | #endif /* P_USE_PILLAR */ 39 | 40 | 41 | 42 | static void pLsrRuntimeInitialize() 43 | { 44 | pLsrGCInitialize(); 45 | pLsrNumericInitialize(pLsrGmpMemLimitParam); 46 | } 47 | 48 | static void pLsrRegisterRuntimeGlobals() 49 | { 50 | pLsrGCRegisterGlobals(); 51 | pLsrFinalizerRegisterGlobals(); 52 | pLsrWpoRegisterGlobals(); 53 | pLsrNumericRegisterGlobals(); 54 | pLsrValueRegisterGlobals(); 55 | } 56 | 57 | static void pLsrRegisterRuntimeVTables() 58 | { 59 | pLsrGCRegisterVTables(); 60 | pLsrFinalizerRegisterVTables(); 61 | pLsrWpoRegisterVTables(); 62 | pLsrNumericRegisterVTables(); 63 | pLsrValueRegisterVTables(); 64 | } 65 | 66 | static void pLsrCheckRuntimeAssertions() 67 | { 68 | pLsrFinalizerCheckAssertions(); 69 | pLsrWpoCheckAssertions(); 70 | pLsrNumericCheckAssertions(); 71 | pLsrObjectCheckModel(); 72 | pLsrThunkCheck(); 73 | pLsrValueCheck(); 74 | } 75 | 76 | #ifdef P_USE_PILLAR 77 | #pragma pillar_managed(off) 78 | static void pLsrRuntimeReportRoots(PrtRseCallback rse, void* env) 79 | { 80 | pLsrFinalizerReportRoots(rse, env); 81 | } 82 | #pragma pillar_managed(on) 83 | #endif 84 | 85 | static void pLsrFuturesStart () 86 | { 87 | uintp sizeInBytes = pLsrStackSizeWorker * 1024 * 1024; 88 | uintp digitsB10 = (uintp) log10(sizeInBytes); 89 | char *fmt = "stacksize=%u"; 90 | char *buf = pLsrAllocC(strlen(fmt) + digitsB10 + 1); 91 | if (!sprintf(buf, fmt, sizeInBytes)) { 92 | pLsrRuntimeError("Unable to set stack size"); 93 | } 94 | #ifdef P_USE_PARALLEL_FUTURES 95 | ptkFutureSystemSetOption(buf); 96 | ptkFutureSystemStart(0); 97 | #endif 98 | pLsrFreeC(buf); 99 | } 100 | 101 | static void pLsrIHRInitialize() { 102 | if (pLsrIHRThreadCountParam > 0) ihrSetNCapabilities(pLsrIHRThreadCountParam); 103 | } 104 | 105 | static void __pmain(); 106 | 107 | 108 | static void pLsrRun() 109 | { 110 | pLsrEventsTransition("Enter", "Main"); 111 | __pmain(); 112 | pLsrFinalizerShutdown (1); 113 | pLsrEventsTransition("Exit", "Main"); 114 | fflush(stdout); 115 | 116 | #ifdef PLSR_INSTRUMENT_ALLOCATION 117 | printf("plsr: Number objects allocated: %I64u\n", pLsrNumObjectsAllocated); 118 | printf("plsr: Number bytes allocated: %I64u\n", pLsrNumBytesAllocated); 119 | printf("plsr: Number padding bytes allocated: %I64u\n", pLsrNumPaddingBytesAllocated); 120 | printf("plsr: Number unmanaged objects allocated: %I64u\n", pLsrNumObjectsAllocatedUnmanaged); 121 | printf("plsr: Number unmanaged bytes allocated: %I64u\n", pLsrNumBytesAllocatedUnmanaged); 122 | printf("plsr: Number unmanaged objects freed: %I64u\n", pLsrNumObjectsFreedUnmanaged); 123 | #endif /* PLSR_INSTRUMENT_ALLOCATION */ 124 | #ifdef PLSR_INSTRUMENT_VTB_ALC 125 | { 126 | PlsrVTable cur = pLsrAllVTables; 127 | printf("plsr: vtable allocation stats:\n"); 128 | while(cur) { 129 | printf(" %s (%p): Number objects allocated: %I64u\n", 130 | cur->name, cur, cur->numObjects); 131 | printf(" %s (%p): Number bytes allocated: %I64u\n", 132 | cur->name, cur, cur->numBytes); 133 | printf(" %s (%p): Number padding bytes allocated: %I64u\n", 134 | cur->name, cur, cur->padding*cur->numObjects); 135 | cur = cur->next; 136 | } 137 | } 138 | #endif /* PLSR_INSTRUMENT_VTB_ALC */ 139 | 140 | pLsrEventsShutdown(); 141 | pLsrExit(0); 142 | 143 | return; 144 | } 145 | 146 | int MAIN(int _argc, const char** _argv) 147 | { 148 | int argc; 149 | const char** argv; 150 | 151 | #ifdef P_USE_MCRT 152 | mcrtStart(main, _argc, _argv); 153 | #endif 154 | setlocale(LC_CTYPE, ""); 155 | pLsrEventsInit(); 156 | pLsrEventsTransition("Enter", "Startup"); 157 | pLsrDisableErrorBox(); 158 | pilCheck(); 159 | pLsrCheckRuntimeAssertions(); 160 | pLsrParseOptions(_argc, _argv, &argc, &argv); 161 | pLsrGcInit(pLsrInitHeapParam, pLsrMaxHeapParam); 162 | pLsrRegisterRuntimeVTables(); 163 | pLsrRegisterRuntimeGlobals(); 164 | pLsrRuntimeInitialize(); 165 | pLsrIHRInitialize(); 166 | pLsrFuturesStart (); 167 | pLsrFinalizerStart (); 168 | pLsrEventsTransition("Exit", "Startup"); 169 | #ifdef __pillar2c__ 170 | prtSetPcallStackSize(pLsrStackSizeMain * 1024 * 1024); 171 | pcall pLsrRun(); 172 | #else 173 | pLsrRun(); 174 | #endif 175 | return 0; 176 | } 177 | 178 | #endif /* !_PLSR_MAIN_H_ */ 179 | -------------------------------------------------------------------------------- /runtime/include/hrc/plsr-numeric.h: -------------------------------------------------------------------------------- 1 | /* The Haskell Research Compiler */ 2 | /* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | */ 17 | 18 | /* Arbitrary precision numbers */ 19 | 20 | #ifndef _PLSR_NUMERIC_H_ 21 | #define _PLSR_NUMERIC_H_ 22 | 23 | /********************************************************************** 24 | * Arbitrary precision integers 25 | */ 26 | 27 | #include "hrc/plsr-integer.h" 28 | 29 | /********************************************************************** 30 | * Arbitrary precision rationals 31 | */ 32 | 33 | #include "hrc/plsr-rational.h" 34 | 35 | /********************************************************************** 36 | * Some miscellaneous floating point stuff 37 | */ 38 | 39 | static char* pLsrCStringFromFloat32(float32 flt) 40 | { 41 | char* str = pLsrAllocC(30); 42 | sprintf(str, "%f", flt); 43 | return str; 44 | } 45 | 46 | static float32 pLsrFloat32FromCString(char* str) 47 | { 48 | float32 res = 0.0f; 49 | sscanf(str, "%f", &res); 50 | return res; 51 | } 52 | 53 | /********************************************************************** 54 | * GC registration functions 55 | */ 56 | 57 | static void pLsrNumericRegisterVTables() 58 | { 59 | pLsrIntegerRegisterVTables(); 60 | pLsrRationalRegisterVTables(); 61 | } 62 | 63 | static void pLsrNumericRegisterGlobals() 64 | { 65 | pLsrIntegerRegisterGlobals(); 66 | pLsrRationalRegisterGlobals(); 67 | } 68 | 69 | static void pLsrNumericCheckAssertions() 70 | { 71 | pLsrRationalCheckAssertions(); 72 | } 73 | 74 | static void pLsrNumericInitialize(uintp memLimit) 75 | { 76 | pLsrAPIntInitialize(memLimit); 77 | pLsrAPRatInitialize(); 78 | } 79 | #endif /* !_PLSR_NUMERIC_H_ */ 80 | -------------------------------------------------------------------------------- /runtime/include/hrc/plsr-prims-ghc-longlong.h: -------------------------------------------------------------------------------- 1 | /* The Haskell Research Compiler */ 2 | /* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | */ 17 | 18 | #ifndef _PLSR_PRIMS_GHC_LONGLONG_H_ 19 | #define _PLSR_PRIMS_GHC_LONGLONG_H_ 20 | 21 | /* get type definitions from pil.h */ 22 | #include "hrc/pil.h" 23 | 24 | #define hs_gtWord64(a,b) ((a)> (b)) 25 | #define hs_geWord64(a,b) ((a)>=(b)) 26 | #define hs_eqWord64(a,b) ((a)==(b)) 27 | #define hs_neWord64(a,b) ((a)!=(b)) 28 | #define hs_ltWord64(a,b) ((a)< (b)) 29 | #define hs_leWord64(a,b) ((a)<=(b)) 30 | #define hs_gtInt64(a,b) ((a)> (b)) 31 | #define hs_geInt64(a,b) ((a)>=(b)) 32 | #define hs_eqInt64(a,b) ((a)==(b)) 33 | #define hs_neInt64(a,b) ((a)!=(b)) 34 | #define hs_ltInt64(a,b) ((a)< (b)) 35 | #define hs_leInt64(a,b) ((a)<=(b)) 36 | 37 | #define hs_remWord64(a,b) ((a)% (b)) 38 | #define hs_quotWord64(a,b) ((a)/ (b)) 39 | 40 | #define hs_remInt64(a,b) ((a)% (b)) 41 | #define hs_quotInt64(a,b) ((a)/ (b)) 42 | #define hs_negateInt64(a) (-(a)) 43 | #define hs_plusInt64(a,b) ((a)+ (b)) 44 | #define hs_minusInt64(a,b) ((a)- (b)) 45 | #define hs_timesInt64(a,b) ((a)* (b)) 46 | 47 | #define hs_and64(a,b) ((a)& (b)) 48 | #define hs_or64(a,b) ((a)| (b)) 49 | #define hs_xor64(a,b) ((a)^ (b)) 50 | #define hs_not64(a) ( ~(a)) 51 | 52 | #define hs_uncheckedShiftL64(a,b) ((a)<< (b)) 53 | #define hs_uncheckedShiftRL64(a,b) ((a)>> (b)) 54 | #define hs_uncheckedIShiftL64(a,b) ((a)<< (b)) 55 | #define hs_uncheckedIShiftRA64(a,b) ((a)>> (b)) 56 | #define hs_uncheckedIShiftRL64(a,b) ((sint64)((uint64)(a)>>(b))) 57 | 58 | #define hs_intToInt64(i) ((sint64) (i)) 59 | #define hs_int64ToInt(i) ((sintp) (i)) 60 | #define hs_int64ToWord64(i) ((uint64) (i)) 61 | #define hs_wordToWord64(w) ((uint64) (w)) 62 | #define hs_word64ToWord(w) ((uintp) (w)) 63 | #define hs_word64ToInt64(w) ((sint64) (w)) 64 | 65 | #endif 66 | -------------------------------------------------------------------------------- /runtime/include/hrc/plsr-prims-vector.h: -------------------------------------------------------------------------------- 1 | /* The Haskell Research Compiler */ 2 | /* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | */ 17 | 18 | #ifndef _PLSR_PRIMS_VECTOR_H_ 19 | #define _PLSR_PRIMS_VECTOR_H_ 20 | 21 | #ifdef P_USE_VI_SSE 22 | #define pLsrViWidth 128 23 | #include "hrc/plsr-prims-vector-sse.h" 24 | 25 | #elif P_USE_VI_AVX 26 | #define pLsrViWidth 256 27 | #include "hrc/plsr-prims-vector-sse.h" 28 | #include "hrc/plsr-prims-vector-avx.h" 29 | 30 | #elif P_USE_VI_MIC 31 | #define pLsrViWidth 512 32 | #include "hrc/plsr-prims-vector-mic.h" 33 | 34 | #else 35 | #define pLsrViWidth 128 36 | 37 | #endif 38 | 39 | #endif /* _PLSR_PRIMS_VECTOR_H_ */ 40 | -------------------------------------------------------------------------------- /runtime/include/hrc/plsr-prims.h: -------------------------------------------------------------------------------- 1 | /* The Haskell Research Compiler */ 2 | /* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | */ 17 | 18 | #ifndef _PLSR_PRIMS_H_ 19 | #define _PLSR_PRIMS_H_ 20 | 21 | #include "hrc/plsr-prims-prims.h" 22 | #include "hrc/plsr-prims-runtime.h" 23 | #include "hrc/plsr-prims-vector.h" 24 | #include "hrc/plsr-prims-ghc.h" 25 | 26 | #endif /* _PLSR_PRIMS_H_ */ 27 | -------------------------------------------------------------------------------- /runtime/include/hrc/plsr-thunk.h: -------------------------------------------------------------------------------- 1 | /* The Haskell Research Compiler */ 2 | /* 3 | * Redistribution and use in source and binary forms, with or without modification, are permitted 4 | * provided that the following conditions are met: 5 | * 1. Redistributions of source code must retain the above copyright notice, this list of 6 | * conditions and the following disclaimer. 7 | * 2. Redistributions in binary form must reproduce the above copyright notice, this list of 8 | * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, 10 | * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 11 | * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 12 | * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 13 | * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 14 | * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 15 | * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 16 | */ 17 | 18 | /* Unified Futures Thunk Implementation */ 19 | 20 | #ifdef PLSR_LIGHTWEIGHT_THUNKS 21 | #include "hrc/plsr-lightweight-thunk.h" 22 | #else 23 | #include "hrc/plsr-ptk-thunk.h" 24 | #endif 25 | -------------------------------------------------------------------------------- /sml-lib/Makefile: -------------------------------------------------------------------------------- 1 | MLTON_SRC_URL="https://sourceforge.net/projects/mlton/files/mlton/20130715/mlton-20130715.src.tgz/download" 2 | MLTON_BIN=$(shell which mlton) 3 | MLTON_LIBDIR=$(abspath $(dir $(MLTON_BIN))/../lib/mlton/sml) 4 | DIR_LIST=basis ckit-lib cml mllpt-lib mlnlffi-lib mlrisc-lib mlyacc-lib smlnj-lib 5 | 6 | mlb-path-map: mlton $(DIR_LIST) 7 | @echo "MLTON_ROOT $(shell pwd)" > mlb-path-map 8 | @echo "SML_LIB $(shell pwd)" >> mlb-path-map 9 | 10 | ./mlton: 11 | @echo Downloading mlton source and extract its directory lib/mlton to ./mlton. 12 | curl -L $(MLTON_SRC_URL)|tar zxf - mlton-20130715/lib/mlton --strip-components=2 13 | 14 | $(DIR_LIST): 15 | @echo linking $@ from system mlton installation to ./$@ 16 | @ln -s "$(MLTON_LIBDIR)/$@" . 17 | 18 | clean: 19 | rm -f $(DIR_LIST) 20 | 21 | cleanall: clean 22 | rm -rf mlton 23 | --------------------------------------------------------------------------------