├── .circleci ├── Dockerfile ├── config.yml └── upload-custom-images.sh ├── .gitignore ├── .hlint.yaml ├── .stylish-haskell.yaml ├── LICENSE ├── Makefile ├── README.md ├── docs ├── README.md ├── compiler │ ├── README.md │ ├── getting-started.md │ └── type-checker.md └── user-guide │ ├── README.md │ ├── differences-from-haskell.md │ └── introduction.md ├── executables └── Main.hs ├── integration-tests ├── Main.hs ├── README.md ├── fail │ └── RecordPoly.amy ├── package.yaml ├── pass │ ├── closures │ │ ├── Closures.amy │ │ └── Closures.ll │ ├── data │ │ ├── Data.amy │ │ └── Data.ll │ ├── fib │ │ ├── Fib.amy │ │ └── Fib.ll │ ├── func-args │ │ ├── FuncArgs.amy │ │ └── FuncArgs.ll │ ├── higher-rank-poly │ │ ├── HigherRankPoly.amy │ │ └── HigherRankPoly.ll │ ├── lambda-lift │ │ ├── LambdaLift.amy │ │ └── LambdaLift.ll │ ├── let │ │ ├── Let.amy │ │ └── Let.ll │ ├── poly-data │ │ ├── PolyData.amy │ │ └── PolyData.ll │ ├── poly │ │ ├── Poly.amy │ │ └── Poly.ll │ ├── primops │ │ ├── Primops.amy │ │ └── Primops.ll │ ├── records │ │ ├── Records.amy │ │ └── Records.ll │ ├── semicolons │ │ ├── Semicolons.amy │ │ └── Semicolons.ll │ └── text │ │ ├── Text.amy │ │ └── Text.ll └── tests.yaml ├── library ├── Amy.hs └── Amy │ ├── ANF.hs │ ├── ANF │ ├── AST.hs │ ├── Convert.hs │ ├── ConvertType.hs │ ├── Monad.hs │ ├── Pretty.hs │ └── TypeRep.hs │ ├── Codegen.hs │ ├── Codegen │ ├── CaseBlocks.hs │ ├── Closures.hs │ ├── Emit.hs │ ├── Malloc.hs │ ├── Monad.hs │ ├── Pure.hs │ ├── TypeConversion.hs │ └── Utils.hs │ ├── Compile.hs │ ├── Core.hs │ ├── Core │ ├── AST.hs │ ├── Desugar.hs │ ├── LambdaLift.hs │ ├── Monad.hs │ ├── PatternCompiler.hs │ └── Pretty.hs │ ├── Environment.hs │ ├── Errors.hs │ ├── Kind.hs │ ├── Literal.hs │ ├── Names.hs │ ├── Pretty.hs │ ├── Prim.hs │ ├── Syntax.hs │ ├── Syntax │ ├── AST.hs │ ├── BindingGroups.hs │ ├── Lexer.hs │ ├── Located.hs │ ├── Monad.hs │ ├── Parser.hs │ └── Pretty.hs │ ├── Type.hs │ ├── TypeCheck.hs │ ├── TypeCheck │ ├── KindInference.hs │ ├── Monad.hs │ ├── Subtyping.hs │ └── TypeCheck.hs │ └── Utils │ └── SolveSetEquations.hs ├── llvm-playground ├── closures.c ├── foo-bar.ll ├── func_pointer.c ├── func_pointer.ll ├── func_pointer_manual.ll ├── hello.c ├── hello.ll ├── if.ll └── struct.ll ├── misc ├── Bidirectional.hs ├── SetsoftMatchCompiler.hs └── interesting-haskell.hs ├── package.yaml ├── rts ├── .gitignore ├── README.md └── rts.c ├── stack.yaml ├── stdlib ├── .gitignore └── Prelude.amy └── tests ├── Amy ├── Core │ └── PatternCompilerSpec.hs ├── Syntax │ └── ParserSpec.hs └── Utils │ └── SolveSetEquationsSpec.hs └── Spec.hs /.circleci/Dockerfile: -------------------------------------------------------------------------------- 1 | # Container for running the Haskell build 2 | 3 | FROM ubuntu:16.04 4 | 5 | # Install apt dependencies 6 | RUN \ 7 | apt-get update && \ 8 | apt-get install -y \ 9 | build-essential \ 10 | curl \ 11 | git \ 12 | libelf-dev \ 13 | libgmp3-dev \ 14 | libtinfo-dev \ 15 | locales \ 16 | moreutils \ 17 | pkg-config \ 18 | python-yaml \ 19 | wget && \ 20 | rm -rf /var/lib/apt/lists/* 21 | 22 | # Install LLVM 23 | RUN \ 24 | echo "deb http://apt.llvm.org/xenial/ llvm-toolchain-xenial-6.0 main" > /etc/apt/sources.list.d/llvm.list && \ 25 | echo "deb-src http://apt.llvm.org/xenial/ llvm-toolchain-xenial-6.0 main" >> /etc/apt/sources.list.d/llvm.list && \ 26 | apt-get update && \ 27 | apt-get install -y --allow-unauthenticated \ 28 | clang-6.0 \ 29 | llvm-6.0-dev && \ 30 | ln -s /usr/bin/clang-6.0 /usr/bin/clang && \ 31 | rm -rf /var/lib/apt/lists/* 32 | 33 | # Install Boehm garbage collector 34 | RUN \ 35 | apt-get update && \ 36 | apt-get install -y \ 37 | libgc-dev && \ 38 | rm -rf /var/lib/apt/lists/* 39 | 40 | # Install stack 41 | ENV STACK_VERSION 1.7.1 42 | RUN \ 43 | curl -L https://github.com/commercialhaskell/stack/releases/download/v$STACK_VERSION/stack-$STACK_VERSION-linux-x86_64.tar.gz | tar -xzv -C /tmp && \ 44 | mv /tmp/stack-$STACK_VERSION-linux-x86_64/stack /usr/local/bin/stack && \ 45 | rm -rf /tmp/* 46 | 47 | # Use en_US.UTF-8 locale to fix decoding errors. It isn't here by default so we 48 | # use locale-gen. 49 | RUN locale-gen en_US.UTF-8 50 | ENV LANG='en_US.UTF-8' LANGUAGE='en_US:en' LC_ALL='en_US.UTF-8' 51 | -------------------------------------------------------------------------------- /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | --- 2 | version: 2 3 | 4 | jobs: 5 | 6 | test: 7 | docker: 8 | - image: jdreaver/circleci-amy 9 | working_directory: ~/amy 10 | steps: 11 | - checkout: 12 | path: ~/amy 13 | 14 | - run: 15 | name: Digest 16 | command: | 17 | # Dependencies 18 | { 19 | stack --version 20 | md5sum stack.yaml 21 | git ls-files --exclude="package.yaml" --ignore | xargs md5sum 22 | } >> dependencies 23 | 24 | # All files 25 | git ls-files | xargs md5sum > file-md5sums 26 | 27 | - restore_cache: 28 | keys: 29 | # yamllint disable-line rule:line-length 30 | - test-deps-v1-{{ checksum "stack.yaml" }}-{{ checksum "dependencies" }} 31 | - test-deps-v1-{{ checksum "stack.yaml" }}- 32 | 33 | - run: 34 | name: Dependencies 35 | command: stack build --jobs=1 --only-dependencies --test --no-run-tests 36 | no_output_timeout: 30m 37 | 38 | - save_cache: 39 | # yamllint disable-line rule:line-length 40 | key: test-deps-v1-{{ checksum "stack.yaml" }}-{{ checksum "dependencies" }} 41 | paths: 42 | - ~/.stack 43 | 44 | - restore_cache: 45 | keys: 46 | # yamllint disable-line rule:line-length 47 | - test-v1-{{ checksum "stack.yaml" }}-{{ .Branch }}-{{ checksum "file-md5sums" }} 48 | - test-v1-{{ checksum "stack.yaml" }}-master-{{ checksum "file-md5sums" }} 49 | - test-v1-{{ checksum "stack.yaml" }}-{{ .Branch }}- 50 | - test-v1-{{ checksum "stack.yaml" }}-master- 51 | - test-v1-{{ checksum "stack.yaml" }}- 52 | 53 | - run: 54 | name: Build 55 | command: stack build --pedantic --test --no-run-tests 56 | 57 | - save_cache: 58 | # yamllint disable-line rule:line-length 59 | key: test-v1-{{ checksum "stack.yaml" }}-{{ .Branch }}-{{ checksum "file-md5sums" }} 60 | paths: 61 | - ~/amy/.stack-work 62 | - ~/amy/integration-tests/.stack-work 63 | 64 | - run: 65 | name: Test 66 | command: LLI_COMMAND=lli-6.0 make test 67 | no_output_timeout: 30m 68 | 69 | workflows: 70 | version: 2 71 | test: 72 | jobs: 73 | - test 74 | -------------------------------------------------------------------------------- /.circleci/upload-custom-images.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # Builds and uploads all of our custom images needed for CircleCI 4 | 5 | set -eux; 6 | 7 | image_tag="jdreaver/circleci-amy:latest" 8 | docker build -t "$image_tag" . 9 | docker push "$image_tag" 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *.cabal 3 | a.out 4 | *-rts-linked.ll 5 | *-rts-opt.ll 6 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | - ignore: {name: "Redundant do", within: spec} 3 | - ignore: {name: "Use list comprehension"} 4 | - ignore: {name: "Use section"} 5 | - ignore: {name: "Use lambda-case"} 6 | - ignore: {name: "Eta reduce"} 7 | 8 | # Custom Warnings 9 | - warn: {lhs: mapM, rhs: traverse} 10 | - warn: {lhs: mapM_, rhs: traverse_} 11 | - warn: {lhs: forM, rhs: for} 12 | - warn: {lhs: forM_, rhs: for_} 13 | 14 | - modules: 15 | - {name: [Data.Set], as: Set} 16 | - {name: [Data.Map], as: Map} 17 | - {name: [Data.HashSet], as: HashSet} 18 | - {name: [Data.HashMap.Strict], as: HashMap} 19 | - {name: [Data.Text], as: T} 20 | - {name: [Data.Text.Encoding], as: T} 21 | - {name: [Data.Text.IO], as: T} 22 | - {name: [Data.Text.Lazy], as: TL} 23 | - {name: [Data.Text.Lazy.Encoding], as: TL} 24 | - {name: [Data.Text.IO.Lazy], as: TL} 25 | - {name: [Data.ByteString], as: BS} 26 | - {name: [Data.ByteString.Lazy], as: BSL} 27 | - {name: [Data.ByteString.Char8], as: BS8} 28 | - {name: [Data.ByteString.Lazy.Char8], as: BSL8} 29 | - {name: [Data.List.NonEmpty], as: NE} 30 | - {name: [Data.Sequence], as: Seq} 31 | 32 | - functions: 33 | - {name: unsafePerformIO, within: []} # never use unsafePerformIO 34 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - simple_align: 3 | cases: false 4 | top_level_patterns: false 5 | records: false 6 | - imports: 7 | align: none 8 | list_align: after_alias 9 | pad_module_names: false 10 | long_list_align: new_line_multiline 11 | empty_list_align: right_after 12 | list_padding: 2 13 | separate_lists: false 14 | space_surround: false 15 | - language_pragmas: 16 | style: vertical 17 | align: false 18 | remove_redundant: true 19 | - trailing_whitespace: {} 20 | newline: native 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 David Reaver 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | RTS_LL = rts/rts.ll 2 | RTS_C = rts/rts.c 3 | 4 | .PHONY: all 5 | all: build 6 | 7 | .PHONY: build 8 | build: $(RTS_LL) 9 | stack build --pedantic amy 10 | 11 | .PHONY: test 12 | test: $(RTS_LL) 13 | stack test --pedantic amy 14 | stack test --pedantic amy-integration-tests 15 | (cd integration-tests && PRELUDE_LOCATION=../stdlib/Prelude.amy RTS_LL_LOCATION=../rts/rts.ll stack exec amy-integration-tests) 16 | 17 | .PHONY: watch 18 | watch: 19 | stack test --fast --pedantic --file-watch amy 20 | 21 | $(RTS_LL): $(RTS_C) 22 | (cd rts && clang -O3 -Wall -Wconversion -Werror -S -emit-llvm rts.c) 23 | 24 | .PHONY: clean 25 | clean: 26 | git clean -xfd 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # The Amy Programming Language 2 | 3 | Amy is a strict, Haskell-like programming language that compiles to LLVM. It is 4 | currently under heavy development, so if you happen to come across this repo 5 | please excuse the lack of documentation. There are however some examples of 6 | source code along with LLVM output in the 7 | [integration-tests](integration-tests/pass) directory. 8 | 9 | ## Documentation 10 | 11 | See the [docs](docs/) directory for more thorough documentation. It contains 12 | both [user-facing documentation](docs/user-guide/README.md) and [compiler 13 | documentation](docs/compiler/README.md) for the `amy` compiler. 14 | -------------------------------------------------------------------------------- /docs/README.md: -------------------------------------------------------------------------------- 1 | # Amy Documentation 2 | 3 | This folder contains the documentation for the Amy programming language. 4 | 5 | * The [user-guide](user-guide/) directory contains user-facing documentation 6 | about the language itself. 7 | * The [compiler](compiler/) directory contains internal documentation for the 8 | `amy` compiler. 9 | -------------------------------------------------------------------------------- /docs/compiler/README.md: -------------------------------------------------------------------------------- 1 | # Amy Compiler Documentation 2 | 3 | ## Hacking on the compiler 4 | 5 | * [Getting Started](getting-started.md) 6 | * [Integration test suite](../../integration-tests/README.md) 7 | 8 | ## Compiler architecture and algorithms 9 | 10 | * [Type Checker](type-checker.md) 11 | * [Runtime System](../../rts/README.md) 12 | -------------------------------------------------------------------------------- /docs/compiler/getting-started.md: -------------------------------------------------------------------------------- 1 | # Getting started with the compiler 2 | 3 | This document explains how to get started hacking on the `amy` compiler. 4 | 5 | ## Requirements 6 | 7 | * Haskell development environment, preferably `stack` 8 | * LLVM development libraries, version 6 (`llvm-6.0-dev` on Ubuntu, see 9 | http://apt.llvm.org/) 10 | * A recent version of `clang`, presumably the version packed with the LLVM 11 | libraries you installed (`clang-6.0` on Ubuntu) 12 | * [Boehm Garbage Collector](http://www.hboehm.info/gc/) development libs. 13 | (`libgc-dev` on Ubuntu) 14 | 15 | ## Compiling the compiler 16 | 17 | Running `make test` should build the `amy` compiler and run all the integration 18 | tests. If you are missing a library like LLVM or `libgc`, surely this process 19 | will complain. 20 | -------------------------------------------------------------------------------- /docs/compiler/type-checker.md: -------------------------------------------------------------------------------- 1 | # Amy Type Checker 2 | 3 | This document explains the Amy type checking algorithm, and the work that 4 | inspired it. 5 | 6 | ## Papers 7 | 8 | The Amy type checking algorithm is based on a few different papers: 9 | 10 | * [Complete and Easy Bidirectional Typechecking for Higher-Rank Polymorphism 11 | (Dunfield 2013)](https://www.cl.cam.ac.uk/~nk480/bidir.pdf): This paper 12 | describes the core of the Amy type checking algorithm. Everything else is 13 | essentially added onto this core. 14 | * [Extensible records with scoped labels (Leijen 15 | 2005)](http://www.cs.ioc.ee/tfp-icfp-gpce05/tfp-proc/21num.pdf): This paper 16 | describes a more thorough extensible implementation than the one we use (we 17 | actually remove some features from this system). 18 | * [Typing Haskell in Haskell (Jones 19 | 2000)](https://web.cecs.pdx.edu/~mpj/thih/thih.pdf): This paper mainly 20 | provided details about typing mutually recursive binding groups and binding 21 | group dependency analysis. This useful information is surprisingly absent 22 | from many academic type checking papers. 23 | -------------------------------------------------------------------------------- /docs/user-guide/README.md: -------------------------------------------------------------------------------- 1 | # Amy User Guide 2 | 3 | * [Introduction](introduction.md) 4 | * [Difference from Haskell](differences-from-haskell.md) 5 | -------------------------------------------------------------------------------- /docs/user-guide/differences-from-haskell.md: -------------------------------------------------------------------------------- 1 | # Differences from Haskell 2 | 3 | Amy is heavily inspired by Haskell and Haskell-like languages (like 4 | Purescript), as well as languages from the ML family (including OCaml). 5 | 6 | > **NOTE**: Amy is under heavy development, and many of the features 7 | > highlighted here might not be complete yet. See the [roadmap](roadmap.md) for 8 | > the current status of any in-progress features. 9 | 10 | ## Criticisms of Haskell 11 | 12 | Haskell is a lazy functional programming language with a best-in-class type 13 | system. It holds a unique position in the programming language design space, 14 | and despite its age it has evolved remarkably well, producing numerous original 15 | contributions to programming languages in general. 16 | 17 | Haskell has been known as a hotbed of language and compiler research, and has 18 | accrued lots of new extensions and features during its lifetime. For better or 19 | for worse, Haskell also has to live with decisions that were made decades ago 20 | in the interest of backwards compatibility, decisions that might not live up to 21 | the lens of 20/20 hindsight today. 22 | 23 | We have the privilege of standing on the shoulders of giants, taking the best 24 | features of Haskell, combining them with unique new features, and culling any 25 | language design decisions that we don't like. 26 | 27 | ### "Why does Haskell, in your opinion, suck?" 28 | 29 | There was a series of threads online in 2016 with variations on the theme of 30 | "What sucks about Haskell?". 31 | 32 | * Reddit: https://www.reddit.com/r/haskell/comments/4f47ou/why_does_haskell_in_your_opinion_suck/ 33 | * Also Reddit: https://www.reddit.com/r/haskell/comments/4sihcv/haskell_the_bad_parts/ 34 | * Hacker News: https://news.ycombinator.com/item?id=11513883 35 | 36 | While some comments there are a bit overzealous, there are nuggets of honest, 37 | constructive criticisms that inspired some of the directions taken in Amy. Feel 38 | free to read through those threads. 39 | 40 | In the rest of this document we will cover the specific differences between Amy 41 | and Haskell. 42 | 43 | ## Strict Evaluation 44 | 45 | One key feature of Haskell is lazy evaluation by default. Values in Haskell are 46 | computed when they are needed, not when they are defined. Certainly, laziness 47 | is mind-blowing when you first learn about it. Laziness allows you to more 48 | easily compose algorithms as well. Laziness has greatly influenced the 49 | development of Haskell, and pretty much forced Haskell to stick to purity. 50 | 51 | Criticisms of lazy evaluation are all over the internet, but we highlight a few 52 | here: 53 | 54 | * Reasoning about the space/time complexity of code is more difficult. 55 | * Writing a lazy compiler that produces performant code is harder. (GHC is a 56 | trailblazer in this space, and the optimizations it produces are astounding). 57 | * Interop with other languages that are not lazy is tougher. 58 | * This is a rather minor criticism, but laziness is something that is foreign 59 | to most programmers, and the pitfalls of laziness are yet another thing to 60 | learn. 61 | 62 | ## Extensible Records 63 | 64 | Haskell's record system is rather rudimentary, and is a very commonly 65 | criticized component of the language. Amy uses a real extensible record system. 66 | 67 | TODO: Flesh this out with an example 68 | 69 | ## Lack of advanced type system features 70 | 71 | Amy is focused on being **easy to learn** without sacrificing **power**. The 72 | language is kept as small as possible. This prevents proliferation of too many 73 | different idioms for doing the same thing. It also keeps the compiler smaller, 74 | easier to maintain, fast, and easier to optimize. 75 | 76 | It's really cool that Haskell's type system allows library authors to build 77 | libraries for things like extensible records, lenses for record updates, etc. 78 | However, in the interest of ease-of-use, learning, and quality error messages, 79 | we prefer to bake these into the language itself. 80 | 81 | ## Module system 82 | 83 | > **NOTE**: This module system in particular is a work in progress. 84 | 85 | ## Explicit `forall` 86 | 87 | TODO: Flesh this out 88 | -------------------------------------------------------------------------------- /docs/user-guide/introduction.md: -------------------------------------------------------------------------------- 1 | # The Amy Programming Language 2 | 3 | Amy is a strict, Haskell-like language that compiles to LLVM. 4 | 5 | ## Features 6 | 7 | * **Powerful type system**: Static typing helps ensure programs are correct and 8 | safe. Type systems should help you write software, not get in your way. 9 | * **Focus on simplicity and ease of learning**: This is not a grab-bag of 10 | functional programming paradigms. The language focuses on being small and 11 | easy to learn, yet still powerful. 12 | * **Strict evaluation**: Strict evaluation makes performance easier to reason 13 | about, and it also makes it easier to write a compiler that produces 14 | performant code. 15 | * **Compiles to LLVM**: Compilation to LLVM allows us to reap the benefits of 16 | the LLVM toolchain, including advanced optimizations and targeting multiple 17 | backends. This frees compiler developers to focus on the compiler frontend 18 | instead of low-level details like register allocation and backend code 19 | generation. 20 | -------------------------------------------------------------------------------- /executables/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Main 6 | ( main 7 | ) where 8 | 9 | import Control.Monad.Except 10 | import Data.List (intercalate) 11 | import qualified Data.List.NonEmpty as NE 12 | import Data.Maybe (fromMaybe) 13 | import qualified Data.Text.IO as T 14 | import Options.Applicative 15 | import System.Environment (lookupEnv) 16 | import System.Exit (die) 17 | 18 | import Amy.Compile 19 | import Amy.Environment 20 | 21 | main :: IO () 22 | main = 23 | getCommand >>= 24 | \case 25 | CompileFiles opts -> compileFiles opts 26 | Repl -> error "TODO: Fix REPL" 27 | 28 | compileFiles :: CompileFilesOptions -> IO () 29 | compileFiles CompileFilesOptions{..} = do 30 | eFailure <- runExceptT $ do 31 | modules <- foldM (processFile cfoDumpFlags) [] cfoFilePaths 32 | modulesNE <- maybe (throwError ["Empty list of modules!"]) pure $ NE.nonEmpty modules 33 | 34 | rtsLL <- fromMaybe "rts/rts.ll" <$> lift (lookupEnv "RTS_LL_LOCATION") 35 | liftIO $ linkModules modulesNE rtsLL 36 | 37 | either (die . intercalate "\n") (\_ -> pure ()) eFailure 38 | 39 | processFile :: DumpFlags -> [CompiledModule] -> FilePath -> ExceptT [String] IO [CompiledModule] 40 | processFile flags importModules filePath = do 41 | fileText <- lift $ T.readFile filePath 42 | let env = foldl1 mergeEnvironments $ primEnvironment : (compiledModuleEnvironment <$> importModules) 43 | compiled <- ExceptT $ compileModule env filePath flags fileText 44 | pure $ importModules ++ [compiled] 45 | 46 | -- runRepl :: IO () 47 | -- runRepl = runInputT defaultSettings loop 48 | -- where 49 | -- loop = do 50 | -- minput <- getInputLine "amy> " 51 | -- case minput of 52 | -- Nothing -> outputStrLn "Goodbye." 53 | -- Just input -> do 54 | -- liftIO $ process "" dumpFlags (pack input) 55 | -- loop 56 | 57 | -- 58 | -- Options 59 | -- 60 | 61 | data Command 62 | = CompileFiles !CompileFilesOptions 63 | | Repl 64 | deriving (Show, Eq) 65 | 66 | getCommand :: IO Command 67 | getCommand = 68 | execParser $ info (helper <*> commandParser) (fullDesc <> progDesc "Amy compile CLI") 69 | 70 | commandParser :: Parser Command 71 | commandParser = 72 | subparser ( 73 | command "compile" 74 | (info (helper <*> fmap CompileFiles parseCompileFiles) (progDesc "Compile a file")) <> 75 | command "repl" 76 | (info (helper <*> pure Repl) (progDesc "Run the repl")) 77 | ) 78 | 79 | data CompileFilesOptions 80 | = CompileFilesOptions 81 | { cfoFilePaths :: ![FilePath] 82 | , cfoDumpFlags :: !DumpFlags 83 | } deriving (Show, Eq) 84 | 85 | parseCompileFiles :: Parser CompileFilesOptions 86 | parseCompileFiles = 87 | CompileFilesOptions 88 | <$> some (argument str ( 89 | metavar "FILE" <> 90 | helpDoc (Just "File to compile") 91 | )) 92 | <*> parseDumpFlags 93 | 94 | parseDumpFlags :: Parser DumpFlags 95 | parseDumpFlags = 96 | DumpFlags 97 | <$> switch (long "dump-parsed" <> helpDoc (Just "Dump parsed AST")) 98 | <*> switch (long "dump-typechecked" <> helpDoc (Just "Dump type checked AST")) 99 | <*> switch (long "dump-core" <> helpDoc (Just "Dump Core AST")) 100 | <*> switch (long "dump-core-lifted" <> helpDoc (Just "Dump lifted Core AST")) 101 | <*> switch (long "dump-anf" <> helpDoc (Just "Dump ANF AST")) 102 | <*> switch (long "dump-llvm-pretty" <> helpDoc (Just "Dump pure LLVM AST from llvm-hs-pretty")) 103 | -------------------------------------------------------------------------------- /integration-tests/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Main 6 | ( main 7 | ) where 8 | 9 | import Control.Exception (throw) 10 | import Control.Monad (unless, when) 11 | import Control.Monad.Except 12 | import Data.Either (isRight) 13 | import Data.Foldable (for_) 14 | import Data.Maybe (fromMaybe, isJust) 15 | import Data.Text (Text, unpack) 16 | import Data.Traversable (traverse) 17 | import Data.Yaml 18 | import System.Directory (doesFileExist) 19 | import System.Environment (lookupEnv) 20 | import System.Exit (ExitCode(..), exitFailure) 21 | import System.Process 22 | 23 | main :: IO () 24 | main = do 25 | (testDefs :: [TestDefinition]) <- either throw pure =<< decodeFileEither "tests.yaml" 26 | results <- traverse runTest testDefs 27 | unless (and results) exitFailure 28 | 29 | runTest :: TestDefinition -> IO Bool 30 | runTest testDef = do 31 | putStrLn $ "Running test '" ++ unpack (testName testDef) ++ "'..." 32 | result <- runExceptT $ runTest' testDef 33 | either (\e -> putStrLn $ "Failed:\n" ++ e) (const $ putStrLn "Success!") result 34 | pure $ isRight result 35 | 36 | runTest' :: TestDefinition -> ExceptT String IO () 37 | runTest' TestDefinition{..} = do 38 | let 39 | sourcePath = testSource unpack testName ++ ".amy" 40 | exePath = testSource "a.out" 41 | 42 | -- Ensure source file exists 43 | exists <- liftIO $ doesFileExist sourcePath 44 | unless exists $ 45 | throwError $ "File doesn't exist! " ++ sourcePath 46 | 47 | -- Get Prelude 48 | preludePath <- liftIO $ fromMaybe "stdlib/Prelude.amy" <$> lookupEnv "PRELUDE_LOCATION" 49 | 50 | -- Compile program 51 | (compilerExitCode, compilerStdout, compilerStderr) <- 52 | liftIO $ readProcessWithExitCode "amy" ["compile", preludePath, sourcePath] "" 53 | let compilerExpectedExitCode = if isJust testCompilerStderr then ExitFailure 1 else ExitSuccess 54 | when (compilerExitCode /= compilerExpectedExitCode) $ 55 | throwError $ 56 | "Incorrect compiler exit code. Expected: " ++ show compilerExpectedExitCode ++ 57 | " got: " ++ show compilerExitCode ++ 58 | (if null compilerStdout then "" else "\nstdout:\n" ++ compilerStdout) ++ 59 | (if null compilerStderr then "" else "\nstderr:\n" ++ compilerStderr) 60 | 61 | for_ testCompilerStderr $ \expected -> 62 | when (expected /= compilerStderr) $ 63 | throwError $ 64 | "Incorrect compiler stderr.\nExpected:\n" ++ expected ++ "\nGot:\n" ++ compilerStderr 65 | 66 | when (compilerExitCode == ExitSuccess) $ do 67 | -- Run llvm program 68 | (programExitCode, programStdout, programStderr) <- liftIO $ readProcessWithExitCode exePath [] "" 69 | when (programExitCode /= testProgramExitCode) $ 70 | throwError $ 71 | "Incorrect program exit code. Expected: " ++ show testProgramExitCode ++ 72 | " got: " ++ show programExitCode ++ 73 | (if null programStdout then "" else "\nstdout:\n" ++ programStdout) ++ 74 | (if null programStderr then "" else "\nstderr:\n" ++ programStderr) 75 | 76 | for_ testProgramStdout $ \expected -> 77 | when (expected /= programStdout) $ 78 | throwError $ "Incorrect program stdout.\nExpected:\n" ++ expected ++ "\nGot:\n" ++ programStdout 79 | 80 | data TestDefinition 81 | = TestDefinition 82 | { testName :: !Text 83 | , testSource :: !FilePath 84 | , testCompilerStderr :: !(Maybe String) 85 | , testProgramExitCode :: !ExitCode 86 | , testProgramStdout :: !(Maybe String) 87 | } deriving (Show, Eq) 88 | 89 | instance FromJSON TestDefinition where 90 | parseJSON = withObject "TestDefinition" $ \o -> do 91 | testName <- o .: "name" 92 | testSource <- o .: "source" 93 | testCompilerStderr <- o .:? "compiler_stderr" 94 | testProgramExitCode <- mkExitCode <$> o .:? "program_exit_code" .!= 0 95 | testProgramStdout <- o .:? "program_stdout" 96 | pure TestDefinition{..} 97 | 98 | mkExitCode :: Int -> ExitCode 99 | mkExitCode 0 = ExitSuccess 100 | mkExitCode x = ExitFailure x 101 | 102 | () :: FilePath -> FilePath -> FilePath 103 | "" fp2 = fp2 104 | fp1 fp2 = 105 | if last fp1 == '/' 106 | then fp1 ++ fp2 107 | else fp1 ++ "/" ++ fp2 108 | -------------------------------------------------------------------------------- /integration-tests/README.md: -------------------------------------------------------------------------------- 1 | # Amy Integration Test Suite 2 | 3 | This directory holds the integration test suite for the `amy` compiler. 4 | 5 | ## Overview 6 | 7 | * Tests are defined in `tests.yaml` 8 | * Tests can technically be placed anywhere, but by convention we put passing 9 | tests under `pass`, and failing tests under `fail`. That way we can point 10 | users to passing tests as examples of `amy` programs, not failing tests. 11 | * `Main.hs` is the program that actually runs the tests. **It assumes that the 12 | `amy` compiler is already built**. 13 | 14 | ## Running tests 15 | 16 | The easiest way to run the test suite is via `make test` in the root of this 17 | repo. That ensures the compiler is built, and then it runs the tests. 18 | -------------------------------------------------------------------------------- /integration-tests/fail/RecordPoly.amy: -------------------------------------------------------------------------------- 1 | f :: forall a b. { x :: Int | a } -> { x :: Int | b } 2 | f x = x 3 | -------------------------------------------------------------------------------- /integration-tests/package.yaml: -------------------------------------------------------------------------------- 1 | name: amy-integration-tests 2 | 3 | ghc-options: -Wall 4 | 5 | executables: 6 | amy-integration-tests: 7 | main: Main.hs 8 | dependencies: 9 | - base 10 | - directory 11 | - process 12 | - mtl 13 | - text 14 | - yaml 15 | -------------------------------------------------------------------------------- /integration-tests/pass/closures/Closures.amy: -------------------------------------------------------------------------------- 1 | # Tests closures via partial application and applications with too many 2 | # arguments. 3 | 4 | main :: Int 5 | main = inc (incDouble 2.01) 6 | 7 | myAdd :: Int -> Double -> Int 8 | myAdd x y = iAdd# x (doubleToInt# y) 9 | 10 | inc :: Double -> Int 11 | inc = myAdd 1 12 | 13 | myAddDouble :: Double -> Double -> Double 14 | myAddDouble x = \y -> dAdd# x y 15 | 16 | incDouble :: Double -> Double 17 | incDouble = myAddDouble 1.01 18 | -------------------------------------------------------------------------------- /integration-tests/pass/closures/Closures.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'amy-module' 2 | source_filename = "" 3 | 4 | %struct.Closure = type { i8, %struct.Closure* (i64*)*, i8, i64* } 5 | 6 | declare i8* @GC_malloc(i64) 7 | 8 | declare %struct.Closure* @call_closure(%struct.Closure*, i8, i64*) 9 | 10 | declare %struct.Closure* @create_closure(i8, %struct.Closure* (i64*)*) 11 | 12 | define private %struct.Closure* @incDouble_closure_wrapper(i64* %env) { 13 | entry: 14 | %0 = call %struct.Closure* @incDouble() 15 | ret %struct.Closure* %0 16 | } 17 | 18 | define private %struct.Closure* @inc_closure_wrapper(i64* %env) { 19 | entry: 20 | %0 = call %struct.Closure* @inc() 21 | ret %struct.Closure* %0 22 | } 23 | 24 | define private %struct.Closure* @"lambda1_$2_closure_wrapper"(i64* %env) { 25 | entry: 26 | %0 = getelementptr i64, i64* %env, i32 0 27 | %1 = bitcast i64* %0 to double* 28 | %2 = load double, double* %1 29 | %3 = getelementptr i64, i64* %env, i32 1 30 | %4 = bitcast i64* %3 to double* 31 | %5 = load double, double* %4 32 | %6 = call double @"lambda1_$2"(double %2, double %5) 33 | %7 = bitcast double %6 to i64 34 | %8 = inttoptr i64 %7 to %struct.Closure* 35 | ret %struct.Closure* %8 36 | } 37 | 38 | define private %struct.Closure* @myAdd_closure_wrapper(i64* %env) { 39 | entry: 40 | %0 = getelementptr i64, i64* %env, i32 0 41 | %1 = load i64, i64* %0 42 | %2 = getelementptr i64, i64* %env, i32 1 43 | %3 = bitcast i64* %2 to double* 44 | %4 = load double, double* %3 45 | %5 = call i64 @myAdd(i64 %1, double %4) 46 | %6 = inttoptr i64 %5 to %struct.Closure* 47 | ret %struct.Closure* %6 48 | } 49 | 50 | define %struct.Closure* @myAddDouble(double %x) { 51 | entry: 52 | %"lambda1_$2_closure1" = call %struct.Closure* @create_closure(i8 2, %struct.Closure* (i64*)* @"lambda1_$2_closure_wrapper") 53 | %0 = call i8* @GC_malloc(i64 64) 54 | %1 = bitcast i8* %0 to i64* 55 | %2 = getelementptr i64, i64* %1, i32 0 56 | %3 = bitcast i64* %2 to double* 57 | store double %x, double* %3 58 | %4 = call %struct.Closure* @call_closure(%struct.Closure* %"lambda1_$2_closure1", i8 1, i64* %1) 59 | %5 = alloca %struct.Closure* 60 | store %struct.Closure* %4, %struct.Closure** %5 61 | %ret = load %struct.Closure*, %struct.Closure** %5 62 | ret %struct.Closure* %ret 63 | } 64 | 65 | define i64 @myAdd(i64 %x, double %y) { 66 | entry: 67 | %res2 = fptoui double %y to i64 68 | %ret = add i64 %x, %res2 69 | ret i64 %ret 70 | } 71 | 72 | define %struct.Closure* @incDouble() { 73 | entry: 74 | %ret = call %struct.Closure* @myAddDouble(double 1.010000e+00) 75 | ret %struct.Closure* %ret 76 | } 77 | 78 | define %struct.Closure* @inc() { 79 | entry: 80 | %myAdd_closure3 = call %struct.Closure* @create_closure(i8 2, %struct.Closure* (i64*)* @myAdd_closure_wrapper) 81 | %0 = call i8* @GC_malloc(i64 64) 82 | %1 = bitcast i8* %0 to i64* 83 | %2 = getelementptr i64, i64* %1, i32 0 84 | store i64 1, i64* %2 85 | %3 = call %struct.Closure* @call_closure(%struct.Closure* %myAdd_closure3, i8 1, i64* %1) 86 | %4 = alloca %struct.Closure* 87 | store %struct.Closure* %3, %struct.Closure** %4 88 | %ret = load %struct.Closure*, %struct.Closure** %4 89 | ret %struct.Closure* %ret 90 | } 91 | 92 | define i64 @main() { 93 | entry: 94 | %incDouble_closure4 = call %struct.Closure* @create_closure(i8 0, %struct.Closure* (i64*)* @incDouble_closure_wrapper) 95 | %0 = call i8* @GC_malloc(i64 64) 96 | %1 = bitcast i8* %0 to i64* 97 | %2 = getelementptr i64, i64* %1, i32 0 98 | %3 = bitcast i64* %2 to double* 99 | store double 2.010000e+00, double* %3 100 | %4 = call %struct.Closure* @call_closure(%struct.Closure* %incDouble_closure4, i8 1, i64* %1) 101 | %5 = ptrtoint %struct.Closure* %4 to i64 102 | %res5 = bitcast i64 %5 to double 103 | %inc_closure6 = call %struct.Closure* @create_closure(i8 0, %struct.Closure* (i64*)* @inc_closure_wrapper) 104 | %6 = call i8* @GC_malloc(i64 64) 105 | %7 = bitcast i8* %6 to i64* 106 | %8 = getelementptr i64, i64* %7, i32 0 107 | %9 = bitcast i64* %8 to double* 108 | store double %res5, double* %9 109 | %10 = call %struct.Closure* @call_closure(%struct.Closure* %inc_closure6, i8 1, i64* %7) 110 | %ret = ptrtoint %struct.Closure* %10 to i64 111 | ret i64 %ret 112 | } 113 | 114 | define double @"lambda1_$2"(double %x, double %y) { 115 | entry: 116 | %ret = fadd double %x, %y 117 | ret double %ret 118 | } 119 | -------------------------------------------------------------------------------- /integration-tests/pass/data/Data.amy: -------------------------------------------------------------------------------- 1 | Void = Void 2 | 3 | MyEnum = MyEnumA | MyEnumB | MyEnumC 4 | 5 | MySum = MySumA Int | MySumB Double | MySumC 6 | 7 | EmptyType 8 | 9 | Nat = Zero | Suc Nat 10 | 11 | main :: Int 12 | main = 13 | let 14 | x :: MySum 15 | x = MySumB 7.8 16 | y :: MyEnum 17 | y = MyEnumB 18 | z = Suc (Suc Zero) 19 | in 20 | case x of 21 | MySumA x' -> 0 22 | MySumB x' -> f x' y 23 | MySumC -> countNat z 24 | 25 | f :: Double -> MyEnum -> Int 26 | f x enum = 27 | case enum of 28 | MyEnumA -> 2 29 | MyEnumB -> doubleToInt# x 30 | MyEnumC -> 3 31 | 32 | countNat :: Nat -> Int 33 | countNat n = 34 | case n of 35 | Zero -> 0 36 | Suc n' -> iAdd# 1 (countNat n') -------------------------------------------------------------------------------- /integration-tests/pass/data/Data.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'amy-module' 2 | source_filename = "" 3 | 4 | %Nat = type { i1, i64* } 5 | %MySum = type { i8, i64* } 6 | 7 | declare i8* @GC_malloc(i64) 8 | 9 | define i64 @f(double %x, i8 %enum) { 10 | entry: 11 | switch i8 %enum, label %case.0.ret [ 12 | i8 0, label %case.0.ret 13 | i8 1, label %case.1.ret 14 | i8 2, label %case.2.ret 15 | ] 16 | 17 | case.0.ret: ; preds = %entry, %entry 18 | %0 = alloca i64 19 | store i64 2, i64* %0 20 | %1 = load i64, i64* %0 21 | br label %case.end.ret 22 | 23 | case.1.ret: ; preds = %entry 24 | %2 = fptoui double %x to i64 25 | br label %case.end.ret 26 | 27 | case.2.ret: ; preds = %entry 28 | %3 = alloca i64 29 | store i64 3, i64* %3 30 | %4 = load i64, i64* %3 31 | br label %case.end.ret 32 | 33 | case.end.ret: ; preds = %case.2.ret, %case.1.ret, %case.0.ret 34 | %ret = phi i64 [ %1, %case.0.ret ], [ %2, %case.1.ret ], [ %4, %case.2.ret ] 35 | ret i64 %ret 36 | } 37 | 38 | define i64 @countNat(%Nat* %n) { 39 | entry: 40 | %0 = getelementptr %Nat, %Nat* %n, i32 0, i32 0 41 | %1 = load i1, i1* %0 42 | %2 = getelementptr %Nat, %Nat* %n, i32 0, i32 1 43 | %3 = load i64*, i64** %2 44 | switch i1 %1, label %case.0.ret [ 45 | i1 false, label %case.0.ret 46 | i1 true, label %case.1.ret 47 | ] 48 | 49 | case.0.ret: ; preds = %entry, %entry 50 | %4 = alloca i64 51 | store i64 0, i64* %4 52 | %5 = load i64, i64* %4 53 | br label %case.end.ret 54 | 55 | case.1.ret: ; preds = %entry 56 | %_u3 = bitcast i64* %3 to %Nat* 57 | %res1 = call i64 @countNat(%Nat* %_u3) 58 | %6 = add i64 1, %res1 59 | br label %case.end.ret 60 | 61 | case.end.ret: ; preds = %case.1.ret, %case.0.ret 62 | %ret = phi i64 [ %5, %case.0.ret ], [ %6, %case.1.ret ] 63 | ret i64 %ret 64 | } 65 | 66 | define i64 @main() { 67 | entry: 68 | %0 = getelementptr %Nat, %Nat* null, i32 1 69 | %1 = ptrtoint %Nat* %0 to i64 70 | %2 = call i8* @GC_malloc(i64 %1) 71 | %z2 = bitcast i8* %2 to %Nat* 72 | %z21 = alloca %Nat 73 | %3 = getelementptr %Nat, %Nat* %z21, i32 0, i32 0 74 | store i1 false, i1* %3 75 | %4 = getelementptr %Nat, %Nat* null, i32 1 76 | %5 = ptrtoint %Nat* %4 to i64 77 | %6 = call i8* @GC_malloc(i64 %5) 78 | %z3 = bitcast i8* %6 to %Nat* 79 | %z32 = alloca %Nat 80 | %7 = getelementptr %Nat, %Nat* %z32, i32 0, i32 0 81 | store i1 true, i1* %7 82 | %8 = bitcast %Nat* %z21 to i64* 83 | %9 = getelementptr %Nat, %Nat* %z32, i32 0, i32 1 84 | store i64* %8, i64** %9 85 | %10 = getelementptr %Nat, %Nat* null, i32 1 86 | %11 = ptrtoint %Nat* %10 to i64 87 | %12 = call i8* @GC_malloc(i64 %11) 88 | %z = bitcast i8* %12 to %Nat* 89 | %z4 = alloca %Nat 90 | %13 = getelementptr %Nat, %Nat* %z4, i32 0, i32 0 91 | store i1 true, i1* %13 92 | %14 = bitcast %Nat* %z32 to i64* 93 | %15 = getelementptr %Nat, %Nat* %z4, i32 0, i32 1 94 | store i64* %14, i64** %15 95 | %16 = alloca i8 96 | store i8 1, i8* %16 97 | %y = load i8, i8* %16 98 | %17 = getelementptr %MySum, %MySum* null, i32 1 99 | %18 = ptrtoint %MySum* %17 to i64 100 | %19 = call i8* @GC_malloc(i64 %18) 101 | %x = bitcast i8* %19 to %MySum* 102 | %x5 = alloca %MySum 103 | %20 = getelementptr %MySum, %MySum* %x5, i32 0, i32 0 104 | store i8 1, i8* %20 105 | %21 = getelementptr double, double* null, i32 1 106 | %22 = ptrtoint double* %21 to i64 107 | %23 = call i8* @GC_malloc(i64 %22) 108 | %24 = bitcast i8* %23 to double* 109 | store double 0x401F333333333333, double* %24 110 | %25 = bitcast double* %24 to i64* 111 | %26 = getelementptr %MySum, %MySum* %x5, i32 0, i32 1 112 | store i64* %25, i64** %26 113 | %27 = getelementptr %MySum, %MySum* %x5, i32 0, i32 0 114 | %28 = load i8, i8* %27 115 | %29 = getelementptr %MySum, %MySum* %x5, i32 0, i32 1 116 | %30 = load i64*, i64** %29 117 | switch i8 %28, label %case.0.ret [ 118 | i8 0, label %case.0.ret 119 | i8 1, label %case.1.ret 120 | i8 2, label %case.2.ret 121 | ] 122 | 123 | case.0.ret: ; preds = %entry, %entry 124 | %_u5 = load i64, i64* %30 125 | %31 = alloca i64 126 | store i64 0, i64* %31 127 | %32 = load i64, i64* %31 128 | br label %case.end.ret 129 | 130 | case.1.ret: ; preds = %entry 131 | %33 = bitcast i64* %30 to double* 132 | %_u6 = load double, double* %33 133 | %34 = call i64 @f(double %_u6, i8 %y) 134 | br label %case.end.ret 135 | 136 | case.2.ret: ; preds = %entry 137 | %35 = call i64 @countNat(%Nat* %z4) 138 | br label %case.end.ret 139 | 140 | case.end.ret: ; preds = %case.2.ret, %case.1.ret, %case.0.ret 141 | %ret = phi i64 [ %32, %case.0.ret ], [ %34, %case.1.ret ], [ %35, %case.2.ret ] 142 | ret i64 %ret 143 | } 144 | -------------------------------------------------------------------------------- /integration-tests/pass/fib/Fib.amy: -------------------------------------------------------------------------------- 1 | main :: Int 2 | main = fib 10 3 | 4 | fib x = 5 | case x of 6 | 0 -> 0 7 | 1 -> 1 8 | y -> iAdd# (fib (iSub# y 1)) (fib (iSub# y 2)) 9 | -------------------------------------------------------------------------------- /integration-tests/pass/fib/Fib.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'amy-module' 2 | source_filename = "" 3 | 4 | define i64 @fib(i64 %x) { 5 | entry: 6 | switch i64 %x, label %case.default.ret [ 7 | i64 0, label %case.0.ret 8 | i64 1, label %case.1.ret 9 | ] 10 | 11 | case.default.ret: ; preds = %entry 12 | %0 = alloca i64 13 | store i64 %x, i64* %0 14 | %c1 = load i64, i64* %0 15 | %res1 = sub i64 %c1, 1 16 | %res2 = call i64 @fib(i64 %res1) 17 | %res3 = sub i64 %c1, 2 18 | %res4 = call i64 @fib(i64 %res3) 19 | %1 = add i64 %res2, %res4 20 | br label %case.end.ret 21 | 22 | case.0.ret: ; preds = %entry 23 | %2 = alloca i64 24 | store i64 0, i64* %2 25 | %3 = load i64, i64* %2 26 | br label %case.end.ret 27 | 28 | case.1.ret: ; preds = %entry 29 | %4 = alloca i64 30 | store i64 1, i64* %4 31 | %5 = load i64, i64* %4 32 | br label %case.end.ret 33 | 34 | case.end.ret: ; preds = %case.1.ret, %case.0.ret, %case.default.ret 35 | %ret = phi i64 [ %1, %case.default.ret ], [ %3, %case.0.ret ], [ %5, %case.1.ret ] 36 | ret i64 %ret 37 | } 38 | 39 | define i64 @main() { 40 | entry: 41 | %ret = call i64 @fib(i64 10) 42 | ret i64 %ret 43 | } 44 | -------------------------------------------------------------------------------- /integration-tests/pass/func-args/FuncArgs.amy: -------------------------------------------------------------------------------- 1 | # Demonstrate use of a function as an argument 2 | 3 | main :: Int 4 | main = apply iAdd# 5 | 6 | apply :: (Int -> Int -> Int) -> Int 7 | apply f = f 1 2 8 | -------------------------------------------------------------------------------- /integration-tests/pass/func-args/FuncArgs.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'amy-module' 2 | source_filename = "" 3 | 4 | %struct.Closure = type { i8, %struct.Closure* (i64*)*, i8, i64* } 5 | 6 | declare i8* @GC_malloc(i64) 7 | 8 | declare %struct.Closure* @call_closure(%struct.Closure*, i8, i64*) 9 | 10 | declare %struct.Closure* @create_closure(i8, %struct.Closure* (i64*)*) 11 | 12 | define private %struct.Closure* @"lambda3_$4_closure_wrapper"(i64* %env) { 13 | entry: 14 | %0 = getelementptr i64, i64* %env, i32 0 15 | %1 = load i64, i64* %0 16 | %2 = getelementptr i64, i64* %env, i32 1 17 | %3 = load i64, i64* %2 18 | %4 = call i64 @"lambda3_$4"(i64 %1, i64 %3) 19 | %5 = inttoptr i64 %4 to %struct.Closure* 20 | ret %struct.Closure* %5 21 | } 22 | 23 | define i64 @apply(%struct.Closure* %f) { 24 | entry: 25 | %0 = call i8* @GC_malloc(i64 128) 26 | %1 = bitcast i8* %0 to i64* 27 | %2 = getelementptr i64, i64* %1, i32 0 28 | store i64 1, i64* %2 29 | %3 = getelementptr i64, i64* %1, i32 1 30 | store i64 2, i64* %3 31 | %4 = call %struct.Closure* @call_closure(%struct.Closure* %f, i8 2, i64* %1) 32 | %ret = ptrtoint %struct.Closure* %4 to i64 33 | ret i64 %ret 34 | } 35 | 36 | define i64 @main() { 37 | entry: 38 | %"lambda3_$4_closure1" = call %struct.Closure* @create_closure(i8 2, %struct.Closure* (i64*)* @"lambda3_$4_closure_wrapper") 39 | %ret = call i64 @apply(%struct.Closure* %"lambda3_$4_closure1") 40 | ret i64 %ret 41 | } 42 | 43 | define i64 @"lambda3_$4"(i64 %_x1, i64 %_x2) { 44 | entry: 45 | %ret = add i64 %_x1, %_x2 46 | ret i64 %ret 47 | } 48 | -------------------------------------------------------------------------------- /integration-tests/pass/higher-rank-poly/HigherRankPoly.amy: -------------------------------------------------------------------------------- 1 | main :: Int 2 | main = idFancy id 1 3 | 4 | idFancy :: forall a. (forall b. b -> b) -> a -> a 5 | idFancy f x = f x 6 | -------------------------------------------------------------------------------- /integration-tests/pass/higher-rank-poly/HigherRankPoly.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'amy-module' 2 | source_filename = "" 3 | 4 | %struct.Closure = type { i8, %struct.Closure* (i64*)*, i8, i64* } 5 | 6 | declare i8* @GC_malloc(i64) 7 | 8 | declare %struct.Closure* @call_closure(%struct.Closure*, i8, i64*) 9 | 10 | declare %struct.Closure* @create_closure(i8, %struct.Closure* (i64*)*) 11 | 12 | declare i64* @id(i64*) 13 | 14 | define private %struct.Closure* @id_closure_wrapper(i64* %env) { 15 | entry: 16 | %0 = getelementptr i64, i64* %env, i32 0 17 | %1 = bitcast i64* %0 to i64** 18 | %2 = load i64*, i64** %1 19 | %3 = call i64* @id(i64* %2) 20 | %4 = bitcast i64* %3 to %struct.Closure* 21 | ret %struct.Closure* %4 22 | } 23 | 24 | define i64* @idFancy(%struct.Closure* %f, i64* %x) { 25 | entry: 26 | %0 = call i8* @GC_malloc(i64 64) 27 | %1 = bitcast i8* %0 to i64* 28 | %2 = getelementptr i64, i64* %1, i32 0 29 | %3 = bitcast i64* %2 to i64** 30 | store i64* %x, i64** %3 31 | %4 = call %struct.Closure* @call_closure(%struct.Closure* %f, i8 1, i64* %1) 32 | %ret = bitcast %struct.Closure* %4 to i64* 33 | ret i64* %ret 34 | } 35 | 36 | define i64 @main() { 37 | entry: 38 | %id_closure1 = call %struct.Closure* @create_closure(i8 1, %struct.Closure* (i64*)* @id_closure_wrapper) 39 | %0 = getelementptr i64, i64* null, i32 1 40 | %1 = ptrtoint i64* %0 to i64 41 | %2 = call i8* @GC_malloc(i64 %1) 42 | %3 = bitcast i8* %2 to i64* 43 | store i64 1, i64* %3 44 | %4 = call i64* @idFancy(%struct.Closure* %id_closure1, i64* %3) 45 | %ret = load i64, i64* %4 46 | ret i64 %ret 47 | } 48 | -------------------------------------------------------------------------------- /integration-tests/pass/lambda-lift/LambdaLift.amy: -------------------------------------------------------------------------------- 1 | # Demonstrate lambda lifting 2 | 3 | main :: Int 4 | main = 5 | let 6 | # Nested lift 7 | id' x = 8 | let 9 | id'' y = x 10 | in id'' x 11 | 12 | # Depends on id' 13 | const' x y = id' y 14 | 15 | # Needs closing 16 | z = 2 17 | f = iAdd# z 18 | 19 | # Mutually recursive, and needs closing 20 | a = 1 21 | g x = if iLessThan# x 0 then 100 else g' (iSub# x z) 22 | g' x = g ((\y -> iAdd# x y) a) 23 | in g (f (const' 2 1)) 24 | 25 | mkJust :: forall a. a -> Maybe a 26 | mkJust = Just 27 | -------------------------------------------------------------------------------- /integration-tests/pass/lambda-lift/LambdaLift.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'amy-module' 2 | source_filename = "" 3 | 4 | %struct.Closure = type { i8, %struct.Closure* (i64*)*, i8, i64* } 5 | %Maybe = type { i1, i64* } 6 | 7 | declare i8* @GC_malloc(i64) 8 | 9 | declare %struct.Closure* @call_closure(%struct.Closure*, i8, i64*) 10 | 11 | declare %struct.Closure* @create_closure(i8, %struct.Closure* (i64*)*) 12 | 13 | define private %struct.Closure* @"lambda12_$13_closure_wrapper"(i64* %env) { 14 | entry: 15 | %0 = getelementptr i64, i64* %env, i32 0 16 | %1 = load i64, i64* %0 17 | %2 = getelementptr i64, i64* %env, i32 1 18 | %3 = load i64, i64* %2 19 | %4 = call i64 @"lambda12_$13"(i64 %1, i64 %3) 20 | %5 = inttoptr i64 %4 to %struct.Closure* 21 | ret %struct.Closure* %5 22 | } 23 | 24 | define private %struct.Closure* @"lambda2_$3_closure_wrapper"(i64* %env) { 25 | entry: 26 | %0 = getelementptr i64, i64* %env, i32 0 27 | %1 = bitcast i64* %0 to i64** 28 | %2 = load i64*, i64** %1 29 | %3 = call %Maybe* @"lambda2_$3"(i64* %2) 30 | %4 = bitcast %Maybe* %3 to %struct.Closure* 31 | ret %struct.Closure* %4 32 | } 33 | 34 | define private %struct.Closure* @"lambda7_$8_closure_wrapper"(i64* %env) { 35 | entry: 36 | %0 = getelementptr i64, i64* %env, i32 0 37 | %1 = load i64, i64* %0 38 | %2 = getelementptr i64, i64* %env, i32 1 39 | %3 = load i64, i64* %2 40 | %4 = call i64 @"lambda7_$8"(i64 %1, i64 %3) 41 | %5 = inttoptr i64 %4 to %struct.Closure* 42 | ret %struct.Closure* %5 43 | } 44 | 45 | define %struct.Closure* @mkJust() { 46 | entry: 47 | %"lambda2_$3_closure1" = call %struct.Closure* @create_closure(i8 1, %struct.Closure* (i64*)* @"lambda2_$3_closure_wrapper") 48 | %0 = alloca %struct.Closure* 49 | store %struct.Closure* %"lambda2_$3_closure1", %struct.Closure** %0 50 | %ret = load %struct.Closure*, %struct.Closure** %0 51 | ret %struct.Closure* %ret 52 | } 53 | 54 | define i64 @main() { 55 | entry: 56 | %0 = alloca i64 57 | store i64 2, i64* %0 58 | %z = load i64, i64* %0 59 | %"lambda7_$8_closure2" = call %struct.Closure* @create_closure(i8 2, %struct.Closure* (i64*)* @"lambda7_$8_closure_wrapper") 60 | %1 = call i8* @GC_malloc(i64 64) 61 | %2 = bitcast i8* %1 to i64* 62 | %3 = getelementptr i64, i64* %2, i32 0 63 | store i64 %z, i64* %3 64 | %4 = call %struct.Closure* @call_closure(%struct.Closure* %"lambda7_$8_closure2", i8 1, i64* %2) 65 | %5 = alloca %struct.Closure* 66 | store %struct.Closure* %4, %struct.Closure** %5 67 | %f = load %struct.Closure*, %struct.Closure** %5 68 | %6 = alloca i64 69 | store i64 1, i64* %6 70 | %a = load i64, i64* %6 71 | %res3 = call i64 @"const'_$9"(i64 2, i64 1) 72 | %7 = call i8* @GC_malloc(i64 64) 73 | %8 = bitcast i8* %7 to i64* 74 | %9 = getelementptr i64, i64* %8, i32 0 75 | store i64 %res3, i64* %9 76 | %10 = call %struct.Closure* @call_closure(%struct.Closure* %f, i8 1, i64* %8) 77 | %res4 = ptrtoint %struct.Closure* %10 to i64 78 | %ret = call i64 @"g_$11"(i64 %a, i64 %z, i64 %res4) 79 | ret i64 %ret 80 | } 81 | 82 | define %Maybe* @"lambda2_$3"(i64* %_x1) { 83 | entry: 84 | %0 = getelementptr %Maybe, %Maybe* null, i32 1 85 | %1 = ptrtoint %Maybe* %0 to i64 86 | %2 = call i8* @GC_malloc(i64 %1) 87 | %ret = bitcast i8* %2 to %Maybe* 88 | %ret1 = alloca %Maybe 89 | %3 = getelementptr %Maybe, %Maybe* %ret1, i32 0, i32 0 90 | store i1 true, i1* %3 91 | %4 = getelementptr %Maybe, %Maybe* %ret1, i32 0, i32 1 92 | store i64* %_x1, i64** %4 93 | ret %Maybe* %ret1 94 | } 95 | 96 | define i64 @"id''_$5"(i64 %x, i64 %y) { 97 | entry: 98 | %0 = alloca i64 99 | store i64 %x, i64* %0 100 | %ret = load i64, i64* %0 101 | ret i64 %ret 102 | } 103 | 104 | define i64 @"id'_$4"(i64 %x) { 105 | entry: 106 | %ret = call i64 @"id''_$5"(i64 %x, i64 %x) 107 | ret i64 %ret 108 | } 109 | 110 | define i64 @"lambda7_$8"(i64 %z, i64 %_x6) { 111 | entry: 112 | %ret = add i64 %z, %_x6 113 | ret i64 %ret 114 | } 115 | 116 | define i64 @"const'_$9"(i64 %x, i64 %y) { 117 | entry: 118 | %ret = call i64 @"id'_$4"(i64 %y) 119 | ret i64 %ret 120 | } 121 | 122 | define i64 @"lambda12_$13"(i64 %x, i64 %y) { 123 | entry: 124 | %ret = add i64 %x, %y 125 | ret i64 %ret 126 | } 127 | 128 | define i64 @"g'_$10"(i64 %a, i64 %z, i64 %x) { 129 | entry: 130 | %"lambda12_$13_closure5" = call %struct.Closure* @create_closure(i8 2, %struct.Closure* (i64*)* @"lambda12_$13_closure_wrapper") 131 | %0 = call i8* @GC_malloc(i64 64) 132 | %1 = bitcast i8* %0 to i64* 133 | %2 = getelementptr i64, i64* %1, i32 0 134 | store i64 %x, i64* %2 135 | %3 = call %struct.Closure* @call_closure(%struct.Closure* %"lambda12_$13_closure5", i8 1, i64* %1) 136 | %4 = alloca %struct.Closure* 137 | store %struct.Closure* %3, %struct.Closure** %4 138 | %res6 = load %struct.Closure*, %struct.Closure** %4 139 | %5 = call i8* @GC_malloc(i64 64) 140 | %6 = bitcast i8* %5 to i64* 141 | %7 = getelementptr i64, i64* %6, i32 0 142 | store i64 %a, i64* %7 143 | %8 = call %struct.Closure* @call_closure(%struct.Closure* %res6, i8 1, i64* %6) 144 | %res7 = ptrtoint %struct.Closure* %8 to i64 145 | %ret = call i64 @"g_$11"(i64 %a, i64 %z, i64 %res7) 146 | ret i64 %ret 147 | } 148 | 149 | define i64 @"g_$11"(i64 %a, i64 %z, i64 %x) { 150 | entry: 151 | %res8 = icmp slt i64 %x, 0 152 | switch i1 %res8, label %case.0.ret [ 153 | i1 true, label %case.0.ret 154 | i1 false, label %case.1.ret 155 | ] 156 | 157 | case.0.ret: ; preds = %entry, %entry 158 | %0 = alloca i64 159 | store i64 100, i64* %0 160 | %1 = load i64, i64* %0 161 | br label %case.end.ret 162 | 163 | case.1.ret: ; preds = %entry 164 | %res9 = sub i64 %x, %z 165 | %2 = call i64 @"g'_$10"(i64 %a, i64 %z, i64 %res9) 166 | br label %case.end.ret 167 | 168 | case.end.ret: ; preds = %case.1.ret, %case.0.ret 169 | %ret = phi i64 [ %1, %case.0.ret ], [ %2, %case.1.ret ] 170 | ret i64 %ret 171 | } 172 | -------------------------------------------------------------------------------- /integration-tests/pass/let/Let.amy: -------------------------------------------------------------------------------- 1 | extern abs :: Int -> Int 2 | 3 | main :: Int 4 | main = 5 | let 6 | x :: Int 7 | x = 8 | if True 9 | then abs (f 100) 10 | else abs (f threeHundred) 11 | y :: Int 12 | y = x 13 | in iAdd# x y 14 | 15 | # f :: Int -> Int 16 | f x = if True then abs x else threeHundred 17 | 18 | threeHundred :: Int 19 | threeHundred = 300 20 | -------------------------------------------------------------------------------- /integration-tests/pass/let/Let.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'amy-module' 2 | source_filename = "" 3 | 4 | declare i64 @abs(i64) 5 | 6 | define i64 @threeHundred() { 7 | entry: 8 | %0 = alloca i64 9 | store i64 300, i64* %0 10 | %ret = load i64, i64* %0 11 | ret i64 %ret 12 | } 13 | 14 | define i64 @f(i64 %x) { 15 | entry: 16 | switch i1 true, label %case.0.ret [ 17 | i1 true, label %case.0.ret 18 | i1 false, label %case.1.ret 19 | ] 20 | 21 | case.0.ret: ; preds = %entry, %entry 22 | %0 = call i64 @abs(i64 %x) 23 | br label %case.end.ret 24 | 25 | case.1.ret: ; preds = %entry 26 | %res1 = call i64 @threeHundred() 27 | %1 = alloca i64 28 | store i64 %res1, i64* %1 29 | %2 = load i64, i64* %1 30 | br label %case.end.ret 31 | 32 | case.end.ret: ; preds = %case.1.ret, %case.0.ret 33 | %ret = phi i64 [ %0, %case.0.ret ], [ %2, %case.1.ret ] 34 | ret i64 %ret 35 | } 36 | 37 | define i64 @main() { 38 | entry: 39 | switch i1 true, label %case.0.x [ 40 | i1 true, label %case.0.x 41 | i1 false, label %case.1.x 42 | ] 43 | 44 | case.0.x: ; preds = %entry, %entry 45 | %x2 = call i64 @f(i64 100) 46 | %0 = call i64 @abs(i64 %x2) 47 | br label %case.end.x 48 | 49 | case.1.x: ; preds = %entry 50 | %x3 = call i64 @threeHundred() 51 | %x4 = call i64 @f(i64 %x3) 52 | %1 = call i64 @abs(i64 %x4) 53 | br label %case.end.x 54 | 55 | case.end.x: ; preds = %case.1.x, %case.0.x 56 | %x = phi i64 [ %0, %case.0.x ], [ %1, %case.1.x ] 57 | %2 = alloca i64 58 | store i64 %x, i64* %2 59 | %y = load i64, i64* %2 60 | %ret = add i64 %x, %y 61 | ret i64 %ret 62 | } 63 | -------------------------------------------------------------------------------- /integration-tests/pass/poly-data/PolyData.amy: -------------------------------------------------------------------------------- 1 | main :: Int 2 | main = 3 | case f of 4 | Left i -> i 5 | Right x -> case h of 6 | Left j -> j 7 | (Right (Left l)) -> l 8 | (Right (Right m)) -> x 9 | 10 | f :: forall b. Either Int b 11 | f = 12 | case Left 42 of 13 | Left i -> Left i 14 | Right j -> Right j 15 | 16 | h :: forall a. Either a (Either a Int) 17 | h = Right (Right 1) 18 | -------------------------------------------------------------------------------- /integration-tests/pass/poly-data/PolyData.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'amy-module' 2 | source_filename = "" 3 | 4 | %Either = type { i1, i64* } 5 | 6 | declare i8* @GC_malloc(i64) 7 | 8 | define %Either* @h() { 9 | entry: 10 | %0 = getelementptr %Either, %Either* null, i32 1 11 | %1 = ptrtoint %Either* %0 to i64 12 | %2 = call i8* @GC_malloc(i64 %1) 13 | %res1 = bitcast i8* %2 to %Either* 14 | %res11 = alloca %Either 15 | %3 = getelementptr %Either, %Either* %res11, i32 0, i32 0 16 | store i1 true, i1* %3 17 | %4 = getelementptr i64, i64* null, i32 1 18 | %5 = ptrtoint i64* %4 to i64 19 | %6 = call i8* @GC_malloc(i64 %5) 20 | %7 = bitcast i8* %6 to i64* 21 | store i64 1, i64* %7 22 | %8 = getelementptr %Either, %Either* %res11, i32 0, i32 1 23 | store i64* %7, i64** %8 24 | %9 = getelementptr %Either, %Either* null, i32 1 25 | %10 = ptrtoint %Either* %9 to i64 26 | %11 = call i8* @GC_malloc(i64 %10) 27 | %ret = bitcast i8* %11 to %Either* 28 | %ret2 = alloca %Either 29 | %12 = getelementptr %Either, %Either* %ret2, i32 0, i32 0 30 | store i1 true, i1* %12 31 | %13 = bitcast %Either* %res11 to i64* 32 | %14 = getelementptr %Either, %Either* %ret2, i32 0, i32 1 33 | store i64* %13, i64** %14 34 | ret %Either* %ret2 35 | } 36 | 37 | define %Either* @f() { 38 | entry: 39 | %0 = getelementptr %Either, %Either* null, i32 1 40 | %1 = ptrtoint %Either* %0 to i64 41 | %2 = call i8* @GC_malloc(i64 %1) 42 | %res2 = bitcast i8* %2 to %Either* 43 | %res21 = alloca %Either 44 | %3 = getelementptr %Either, %Either* %res21, i32 0, i32 0 45 | store i1 false, i1* %3 46 | %4 = getelementptr i64, i64* null, i32 1 47 | %5 = ptrtoint i64* %4 to i64 48 | %6 = call i8* @GC_malloc(i64 %5) 49 | %7 = bitcast i8* %6 to i64* 50 | store i64 42, i64* %7 51 | %8 = getelementptr %Either, %Either* %res21, i32 0, i32 1 52 | store i64* %7, i64** %8 53 | %9 = getelementptr %Either, %Either* %res21, i32 0, i32 0 54 | %10 = load i1, i1* %9 55 | %11 = getelementptr %Either, %Either* %res21, i32 0, i32 1 56 | %12 = load i64*, i64** %11 57 | switch i1 %10, label %case.0.ret [ 58 | i1 false, label %case.0.ret 59 | i1 true, label %case.1.ret 60 | ] 61 | 62 | case.0.ret: ; preds = %entry, %entry 63 | %_u2 = load i64, i64* %12 64 | %13 = getelementptr %Either, %Either* null, i32 1 65 | %14 = ptrtoint %Either* %13 to i64 66 | %15 = call i8* @GC_malloc(i64 %14) 67 | %16 = bitcast i8* %15 to %Either* 68 | %17 = alloca %Either 69 | %18 = getelementptr %Either, %Either* %17, i32 0, i32 0 70 | store i1 false, i1* %18 71 | %19 = getelementptr i64, i64* null, i32 1 72 | %20 = ptrtoint i64* %19 to i64 73 | %21 = call i8* @GC_malloc(i64 %20) 74 | %22 = bitcast i8* %21 to i64* 75 | store i64 %_u2, i64* %22 76 | %23 = getelementptr %Either, %Either* %17, i32 0, i32 1 77 | store i64* %22, i64** %23 78 | br label %case.end.ret 79 | 80 | case.1.ret: ; preds = %entry 81 | %24 = alloca i64* 82 | store i64* %12, i64** %24 83 | %_u3 = load i64*, i64** %24 84 | %25 = getelementptr %Either, %Either* null, i32 1 85 | %26 = ptrtoint %Either* %25 to i64 86 | %27 = call i8* @GC_malloc(i64 %26) 87 | %28 = bitcast i8* %27 to %Either* 88 | %29 = alloca %Either 89 | %30 = getelementptr %Either, %Either* %29, i32 0, i32 0 90 | store i1 true, i1* %30 91 | %31 = getelementptr %Either, %Either* %29, i32 0, i32 1 92 | store i64* %_u3, i64** %31 93 | br label %case.end.ret 94 | 95 | case.end.ret: ; preds = %case.1.ret, %case.0.ret 96 | %ret = phi %Either* [ %17, %case.0.ret ], [ %29, %case.1.ret ] 97 | ret %Either* %ret 98 | } 99 | 100 | define i64 @main() { 101 | entry: 102 | %res3 = call %Either* @f() 103 | %0 = getelementptr %Either, %Either* %res3, i32 0, i32 0 104 | %1 = load i1, i1* %0 105 | %2 = getelementptr %Either, %Either* %res3, i32 0, i32 1 106 | %3 = load i64*, i64** %2 107 | switch i1 %1, label %case.0.ret [ 108 | i1 false, label %case.0.ret 109 | i1 true, label %case.1.ret 110 | ] 111 | 112 | case.0.ret: ; preds = %entry, %entry 113 | %_u10 = load i64, i64* %3 114 | %4 = alloca i64 115 | store i64 %_u10, i64* %4 116 | %5 = load i64, i64* %4 117 | br label %case.end.ret 118 | 119 | case.1.ret: ; preds = %entry 120 | %_u11 = load i64, i64* %3 121 | %res4 = call %Either* @h() 122 | %6 = getelementptr %Either, %Either* %res4, i32 0, i32 0 123 | %7 = load i1, i1* %6 124 | %8 = getelementptr %Either, %Either* %res4, i32 0, i32 1 125 | %9 = load i64*, i64** %8 126 | switch i1 %7, label %case.0.6 [ 127 | i1 false, label %case.0.6 128 | i1 true, label %case.1.6 129 | ] 130 | 131 | case.0.6: ; preds = %case.1.ret, %case.1.ret 132 | %_u6 = load i64, i64* %9 133 | %10 = alloca i64 134 | store i64 %_u6, i64* %10 135 | %11 = load i64, i64* %10 136 | br label %case.end.6 137 | 138 | case.1.6: ; preds = %case.1.ret 139 | %_u7 = bitcast i64* %9 to %Either* 140 | %12 = getelementptr %Either, %Either* %_u7, i32 0, i32 0 141 | %13 = load i1, i1* %12 142 | %14 = getelementptr %Either, %Either* %_u7, i32 0, i32 1 143 | %15 = load i64*, i64** %14 144 | switch i1 %13, label %case.0.13 [ 145 | i1 false, label %case.0.13 146 | i1 true, label %case.1.13 147 | ] 148 | 149 | case.0.13: ; preds = %case.1.6, %case.1.6 150 | %_u8 = load i64, i64* %15 151 | %16 = alloca i64 152 | store i64 %_u8, i64* %16 153 | %17 = load i64, i64* %16 154 | br label %case.end.13 155 | 156 | case.1.13: ; preds = %case.1.6 157 | %_u9 = load i64, i64* %15 158 | %18 = alloca i64 159 | store i64 %_u11, i64* %18 160 | %19 = load i64, i64* %18 161 | br label %case.end.13 162 | 163 | case.end.13: ; preds = %case.1.13, %case.0.13 164 | %20 = phi i64 [ %17, %case.0.13 ], [ %19, %case.1.13 ] 165 | br label %case.end.6 166 | 167 | case.end.6: ; preds = %case.end.13, %case.0.6 168 | %21 = phi i64 [ %11, %case.0.6 ], [ %20, %case.end.13 ] 169 | br label %case.end.ret 170 | 171 | case.end.ret: ; preds = %case.end.6, %case.0.ret 172 | %ret = phi i64 [ %5, %case.0.ret ], [ %21, %case.end.6 ] 173 | ret i64 %ret 174 | } 175 | -------------------------------------------------------------------------------- /integration-tests/pass/poly/Poly.amy: -------------------------------------------------------------------------------- 1 | main :: Int 2 | main = doubleToInt# (const (id 3.1) 5.1) 3 | 4 | # TODO: Use this once we have lambda lifting and test tyvar scoping rules 5 | # const :: forall a b. a -> b -> a 6 | # const x y = 7 | # let 8 | # # "a" is in scope from above 9 | # const' :: forall c. a -> c -> c 10 | # const' x' y' = y' 11 | # in const' y x 12 | -------------------------------------------------------------------------------- /integration-tests/pass/poly/Poly.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'amy-module' 2 | source_filename = "" 3 | 4 | declare i8* @GC_malloc(i64) 5 | 6 | declare i64* @const(i64*, i64*) 7 | 8 | declare i64* @id(i64*) 9 | 10 | define i64 @main() { 11 | entry: 12 | %0 = getelementptr double, double* null, i32 1 13 | %1 = ptrtoint double* %0 to i64 14 | %2 = call i8* @GC_malloc(i64 %1) 15 | %3 = bitcast i8* %2 to double* 16 | store double 3.100000e+00, double* %3 17 | %4 = bitcast double* %3 to i64* 18 | %5 = call i64* @id(i64* %4) 19 | %6 = bitcast i64* %5 to double* 20 | %res1 = load double, double* %6 21 | %7 = getelementptr double, double* null, i32 1 22 | %8 = ptrtoint double* %7 to i64 23 | %9 = call i8* @GC_malloc(i64 %8) 24 | %10 = bitcast i8* %9 to double* 25 | store double %res1, double* %10 26 | %11 = bitcast double* %10 to i64* 27 | %12 = getelementptr double, double* null, i32 1 28 | %13 = ptrtoint double* %12 to i64 29 | %14 = call i8* @GC_malloc(i64 %13) 30 | %15 = bitcast i8* %14 to double* 31 | store double 5.100000e+00, double* %15 32 | %16 = bitcast double* %15 to i64* 33 | %17 = call i64* @const(i64* %11, i64* %16) 34 | %18 = bitcast i64* %17 to double* 35 | %res2 = load double, double* %18 36 | %ret = fptoui double %res2 to i64 37 | ret i64 %ret 38 | } 39 | -------------------------------------------------------------------------------- /integration-tests/pass/primops/Primops.amy: -------------------------------------------------------------------------------- 1 | main :: Int 2 | main = 3 | let 4 | x :: Int 5 | x = 2 6 | in f (f x) 7 | 8 | # f :: Int -> Int 9 | f x = 10 | let 11 | y :: Int 12 | y = iAdd# x (iSub# 4 5) 13 | in 14 | if iLessThan# 5 (iSub# 3 y) then 100 else 200 15 | -------------------------------------------------------------------------------- /integration-tests/pass/primops/Primops.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'amy-module' 2 | source_filename = "" 3 | 4 | define i64 @f(i64 %x) { 5 | entry: 6 | %y1 = sub i64 4, 5 7 | %y = add i64 %x, %y1 8 | %res2 = sub i64 3, %y 9 | %res3 = icmp slt i64 5, %res2 10 | switch i1 %res3, label %case.0.ret [ 11 | i1 true, label %case.0.ret 12 | i1 false, label %case.1.ret 13 | ] 14 | 15 | case.0.ret: ; preds = %entry, %entry 16 | %0 = alloca i64 17 | store i64 100, i64* %0 18 | %1 = load i64, i64* %0 19 | br label %case.end.ret 20 | 21 | case.1.ret: ; preds = %entry 22 | %2 = alloca i64 23 | store i64 200, i64* %2 24 | %3 = load i64, i64* %2 25 | br label %case.end.ret 26 | 27 | case.end.ret: ; preds = %case.1.ret, %case.0.ret 28 | %ret = phi i64 [ %1, %case.0.ret ], [ %3, %case.1.ret ] 29 | ret i64 %ret 30 | } 31 | 32 | define i64 @main() { 33 | entry: 34 | %0 = alloca i64 35 | store i64 2, i64* %0 36 | %x = load i64, i64* %0 37 | %res4 = call i64 @f(i64 %x) 38 | %ret = call i64 @f(i64 %res4) 39 | ret i64 %ret 40 | } 41 | -------------------------------------------------------------------------------- /integration-tests/pass/records/Records.amy: -------------------------------------------------------------------------------- 1 | List a = Nil | Cons { car :: a, cdr :: List a } 2 | 3 | main :: Int 4 | main = addXY { x: 1, y: 2 } 5 | 6 | addXY :: forall a. { x :: Int, y :: Int | a } -> Int 7 | addXY r = iAdd# r.x r.y 8 | 9 | g :: forall a b. a -> { x :: a, y :: Int } 10 | g x = { y: 1, x: x } 11 | 12 | h :: forall a. a -> List a 13 | h x = Cons { car: x, cdr: Cons { car: x, cdr: Nil } } 14 | 15 | # a :: { x :: Int, y :: Bool } 16 | a = 17 | if True 18 | then { x: 1, y: True } 19 | else { y: False, x: 2 } 20 | 21 | # q :: forall a b c d. { x :: a, y :: b, z :: c | d } -> { x :: a, y :: b, z :: c } 22 | q r = { x: r.x, y: r.y, z: r.z } 23 | -------------------------------------------------------------------------------- /integration-tests/pass/records/Records.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'amy-module' 2 | source_filename = "" 3 | 4 | %List = type { i1, i64* } 5 | 6 | declare i8* @GC_malloc(i64) 7 | 8 | define { i64*, i64*, i64* }* @q({ i64*, i64*, i64* }* %r) { 9 | entry: 10 | %0 = getelementptr { i64*, i64*, i64* }, { i64*, i64*, i64* }* %r, i32 0, i32 0 11 | %x1 = load i64*, i64** %0 12 | %1 = getelementptr { i64*, i64*, i64* }, { i64*, i64*, i64* }* %r, i32 0, i32 1 13 | %y2 = load i64*, i64** %1 14 | %2 = getelementptr { i64*, i64*, i64* }, { i64*, i64*, i64* }* %r, i32 0, i32 2 15 | %z3 = load i64*, i64** %2 16 | %3 = getelementptr { i64*, i64*, i64* }, { i64*, i64*, i64* }* null, i32 1 17 | %4 = ptrtoint { i64*, i64*, i64* }* %3 to i64 18 | %5 = call i8* @GC_malloc(i64 %4) 19 | %ret = bitcast i8* %5 to { i64*, i64*, i64* }* 20 | %6 = getelementptr { i64*, i64*, i64* }, { i64*, i64*, i64* }* %ret, i32 0, i32 0 21 | %7 = bitcast i64** %6 to i64** 22 | store i64* %x1, i64** %7 23 | %8 = getelementptr { i64*, i64*, i64* }, { i64*, i64*, i64* }* %ret, i32 0, i32 1 24 | %9 = bitcast i64** %8 to i64** 25 | store i64* %y2, i64** %9 26 | %10 = getelementptr { i64*, i64*, i64* }, { i64*, i64*, i64* }* %ret, i32 0, i32 2 27 | %11 = bitcast i64** %10 to i64** 28 | store i64* %z3, i64** %11 29 | ret { i64*, i64*, i64* }* %ret 30 | } 31 | 32 | define %List* @h(i64* %x) { 33 | entry: 34 | %0 = getelementptr %List, %List* null, i32 1 35 | %1 = ptrtoint %List* %0 to i64 36 | %2 = call i8* @GC_malloc(i64 %1) 37 | %cdr4 = bitcast i8* %2 to %List* 38 | %cdr41 = alloca %List 39 | %3 = getelementptr %List, %List* %cdr41, i32 0, i32 0 40 | store i1 false, i1* %3 41 | %4 = getelementptr { i64*, %List* }, { i64*, %List* }* null, i32 1 42 | %5 = ptrtoint { i64*, %List* }* %4 to i64 43 | %6 = call i8* @GC_malloc(i64 %5) 44 | %cdr5 = bitcast i8* %6 to { i64*, %List* }* 45 | %7 = getelementptr { i64*, %List* }, { i64*, %List* }* %cdr5, i32 0, i32 0 46 | %8 = bitcast i64** %7 to i64** 47 | store i64* %x, i64** %8 48 | %9 = getelementptr { i64*, %List* }, { i64*, %List* }* %cdr5, i32 0, i32 1 49 | %10 = bitcast %List** %9 to %List** 50 | store %List* %cdr41, %List** %10 51 | %11 = getelementptr %List, %List* null, i32 1 52 | %12 = ptrtoint %List* %11 to i64 53 | %13 = call i8* @GC_malloc(i64 %12) 54 | %cdr6 = bitcast i8* %13 to %List* 55 | %cdr62 = alloca %List 56 | %14 = getelementptr %List, %List* %cdr62, i32 0, i32 0 57 | store i1 true, i1* %14 58 | %15 = bitcast { i64*, %List* }* %cdr5 to i64* 59 | %16 = getelementptr %List, %List* %cdr62, i32 0, i32 1 60 | store i64* %15, i64** %16 61 | %17 = getelementptr { i64*, %List* }, { i64*, %List* }* null, i32 1 62 | %18 = ptrtoint { i64*, %List* }* %17 to i64 63 | %19 = call i8* @GC_malloc(i64 %18) 64 | %res7 = bitcast i8* %19 to { i64*, %List* }* 65 | %20 = getelementptr { i64*, %List* }, { i64*, %List* }* %res7, i32 0, i32 0 66 | %21 = bitcast i64** %20 to i64** 67 | store i64* %x, i64** %21 68 | %22 = getelementptr { i64*, %List* }, { i64*, %List* }* %res7, i32 0, i32 1 69 | %23 = bitcast %List** %22 to %List** 70 | store %List* %cdr62, %List** %23 71 | %24 = getelementptr %List, %List* null, i32 1 72 | %25 = ptrtoint %List* %24 to i64 73 | %26 = call i8* @GC_malloc(i64 %25) 74 | %ret = bitcast i8* %26 to %List* 75 | %ret3 = alloca %List 76 | %27 = getelementptr %List, %List* %ret3, i32 0, i32 0 77 | store i1 true, i1* %27 78 | %28 = bitcast { i64*, %List* }* %res7 to i64* 79 | %29 = getelementptr %List, %List* %ret3, i32 0, i32 1 80 | store i64* %28, i64** %29 81 | ret %List* %ret3 82 | } 83 | 84 | define { i64*, i64 }* @g(i64* %x) { 85 | entry: 86 | %0 = getelementptr { i64*, i64 }, { i64*, i64 }* null, i32 1 87 | %1 = ptrtoint { i64*, i64 }* %0 to i64 88 | %2 = call i8* @GC_malloc(i64 %1) 89 | %ret = bitcast i8* %2 to { i64*, i64 }* 90 | %3 = getelementptr { i64*, i64 }, { i64*, i64 }* %ret, i32 0, i32 0 91 | %4 = bitcast i64** %3 to i64** 92 | store i64* %x, i64** %4 93 | %5 = getelementptr { i64*, i64 }, { i64*, i64 }* %ret, i32 0, i32 1 94 | store i64 1, i64* %5 95 | ret { i64*, i64 }* %ret 96 | } 97 | 98 | define i64 @addXY({ i64, i64 }* %r) { 99 | entry: 100 | %0 = getelementptr { i64, i64 }, { i64, i64 }* %r, i32 0, i32 0 101 | %res8 = load i64, i64* %0 102 | %1 = getelementptr { i64, i64 }, { i64, i64 }* %r, i32 0, i32 1 103 | %res9 = load i64, i64* %1 104 | %ret = add i64 %res8, %res9 105 | ret i64 %ret 106 | } 107 | 108 | define i64 @main() { 109 | entry: 110 | %0 = getelementptr { i64, i64 }, { i64, i64 }* null, i32 1 111 | %1 = ptrtoint { i64, i64 }* %0 to i64 112 | %2 = call i8* @GC_malloc(i64 %1) 113 | %res10 = bitcast i8* %2 to { i64, i64 }* 114 | %3 = getelementptr { i64, i64 }, { i64, i64 }* %res10, i32 0, i32 0 115 | store i64 1, i64* %3 116 | %4 = getelementptr { i64, i64 }, { i64, i64 }* %res10, i32 0, i32 1 117 | store i64 2, i64* %4 118 | %ret = call i64 @addXY({ i64, i64 }* %res10) 119 | ret i64 %ret 120 | } 121 | 122 | define { i64, i1 }* @a() { 123 | entry: 124 | switch i1 true, label %case.0.ret [ 125 | i1 true, label %case.0.ret 126 | i1 false, label %case.1.ret 127 | ] 128 | 129 | case.0.ret: ; preds = %entry, %entry 130 | %0 = getelementptr { i64, i1 }, { i64, i1 }* null, i32 1 131 | %1 = ptrtoint { i64, i1 }* %0 to i64 132 | %2 = call i8* @GC_malloc(i64 %1) 133 | %3 = bitcast i8* %2 to { i64, i1 }* 134 | %4 = getelementptr { i64, i1 }, { i64, i1 }* %3, i32 0, i32 0 135 | store i64 1, i64* %4 136 | %5 = getelementptr { i64, i1 }, { i64, i1 }* %3, i32 0, i32 1 137 | %6 = bitcast i1* %5 to i1* 138 | store i1 true, i1* %6 139 | br label %case.end.ret 140 | 141 | case.1.ret: ; preds = %entry 142 | %7 = getelementptr { i64, i1 }, { i64, i1 }* null, i32 1 143 | %8 = ptrtoint { i64, i1 }* %7 to i64 144 | %9 = call i8* @GC_malloc(i64 %8) 145 | %10 = bitcast i8* %9 to { i64, i1 }* 146 | %11 = getelementptr { i64, i1 }, { i64, i1 }* %10, i32 0, i32 0 147 | store i64 2, i64* %11 148 | %12 = getelementptr { i64, i1 }, { i64, i1 }* %10, i32 0, i32 1 149 | %13 = bitcast i1* %12 to i1* 150 | store i1 false, i1* %13 151 | br label %case.end.ret 152 | 153 | case.end.ret: ; preds = %case.1.ret, %case.0.ret 154 | %ret = phi { i64, i1 }* [ %3, %case.0.ret ], [ %10, %case.1.ret ] 155 | ret { i64, i1 }* %ret 156 | } 157 | -------------------------------------------------------------------------------- /integration-tests/pass/semicolons/Semicolons.amy: -------------------------------------------------------------------------------- 1 | # Ensure that blocks can be parsed with semicolons. These look really funny in 2 | # this module, but using semicolons is really nice in the REPL. This test 3 | # ensures block parsing with semicolons doesn't break. 4 | 5 | main :: Int; main = 6 | let a = 1; b = 2 in 7 | let 8 | c = 3; d = 4 9 | e = 5 in 10 | a 11 | -------------------------------------------------------------------------------- /integration-tests/pass/semicolons/Semicolons.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'amy-module' 2 | source_filename = "" 3 | 4 | define i64 @main() { 5 | entry: 6 | %0 = alloca i64 7 | store i64 2, i64* %0 8 | %b = load i64, i64* %0 9 | %1 = alloca i64 10 | store i64 1, i64* %1 11 | %a = load i64, i64* %1 12 | %2 = alloca i64 13 | store i64 5, i64* %2 14 | %e = load i64, i64* %2 15 | %3 = alloca i64 16 | store i64 4, i64* %3 17 | %d = load i64, i64* %3 18 | %4 = alloca i64 19 | store i64 3, i64* %4 20 | %c = load i64, i64* %4 21 | %5 = alloca i64 22 | store i64 %a, i64* %5 23 | %ret = load i64, i64* %5 24 | ret i64 %ret 25 | } 26 | -------------------------------------------------------------------------------- /integration-tests/pass/text/Text.amy: -------------------------------------------------------------------------------- 1 | extern puts :: Text -> Int 2 | 3 | main :: Int 4 | main = let x = puts hello in 0 5 | 6 | hello :: Text 7 | hello = "Hello\nwith\t\"escapes\"" 8 | -------------------------------------------------------------------------------- /integration-tests/pass/text/Text.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'amy-module' 2 | source_filename = "" 3 | 4 | @"$str.1" = private global [21 x i8] c"Hello\0Awith\09\22escapes\22\00" 5 | 6 | declare i64 @puts(i8*) 7 | 8 | define i8* @hello() { 9 | entry: 10 | %0 = alloca i8* 11 | store i8* getelementptr inbounds ([21 x i8], [21 x i8]* @"$str.1", i32 0, i32 0), i8** %0 12 | %ret = load i8*, i8** %0 13 | ret i8* %ret 14 | } 15 | 16 | define i64 @main() { 17 | entry: 18 | %x2 = call i8* @hello() 19 | %x = call i64 @puts(i8* %x2) 20 | %0 = alloca i64 21 | store i64 0, i64* %0 22 | %ret = load i64, i64* %0 23 | ret i64 %ret 24 | } 25 | -------------------------------------------------------------------------------- /integration-tests/tests.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | # Passing tests 4 | - name: Closures 5 | source: pass/closures 6 | program_exit_code: 4 7 | 8 | - name: Data 9 | source: pass/data 10 | program_exit_code: 7 11 | 12 | - name: Fib 13 | source: pass/fib 14 | program_exit_code: 55 15 | 16 | - name: FuncArgs 17 | source: pass/func-args 18 | program_exit_code: 3 19 | 20 | - name: HigherRankPoly 21 | source: pass/higher-rank-poly 22 | program_exit_code: 1 23 | 24 | - name: LambdaLift 25 | source: pass/lambda-lift 26 | program_exit_code: 100 27 | 28 | - name: Let 29 | source: pass/let 30 | program_exit_code: 200 31 | 32 | - name: PolyData 33 | source: pass/poly-data 34 | program_exit_code: 42 35 | 36 | - name: Poly 37 | source: pass/poly 38 | program_exit_code: 3 39 | 40 | - name: Primops 41 | source: pass/primops 42 | program_exit_code: 200 43 | 44 | - name: Records 45 | source: pass/records 46 | program_exit_code: 3 47 | 48 | - name: Semicolons 49 | source: pass/semicolons 50 | program_exit_code: 1 51 | 52 | - name: Text 53 | source: pass/text 54 | program_exit_code: 0 55 | program_stdout: | 56 | Hello 57 | with "escapes" 58 | 59 | # Failing tests 60 | - name: RecordPoly 61 | source: fail 62 | compiler_stderr: | 63 | fail/RecordPoly.amy:2:7: 64 | Could not match type 65 | a 66 | with type 67 | b 68 | -------------------------------------------------------------------------------- /library/Amy.hs: -------------------------------------------------------------------------------- 1 | module Amy 2 | ( 3 | ) where 4 | -------------------------------------------------------------------------------- /library/Amy/ANF.hs: -------------------------------------------------------------------------------- 1 | module Amy.ANF 2 | ( module X 3 | ) where 4 | 5 | import Amy.ANF.AST as X 6 | import Amy.ANF.Convert as X 7 | import Amy.ANF.TypeRep as X 8 | import Amy.ANF.Pretty as X 9 | -------------------------------------------------------------------------------- /library/Amy/ANF/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | 3 | module Amy.ANF.AST 4 | ( Module(..) 5 | , Binding(..) 6 | , Extern(..) 7 | , TypeDeclaration(..) 8 | , DataConDefinition(..) 9 | , ClosureWrapper(..) 10 | , Val(..) 11 | , Literal(..) 12 | , TextPointer(..) 13 | , DataCon(..) 14 | , ConstructorIndex(..) 15 | , Expr(..) 16 | , LetVal(..) 17 | , LetValBinding(..) 18 | , Case(..) 19 | , CreateClosure(..) 20 | , CallClosure(..) 21 | , Match(..) 22 | , Pattern(..) 23 | , PatCons(..) 24 | , KnownFuncApp(..) 25 | , App(..) 26 | , ConApp(..) 27 | 28 | , Type(..) 29 | , Typed(..) 30 | 31 | , module Amy.Names 32 | ) where 33 | 34 | import GHC.Word (Word32) 35 | import Data.Map.Strict (Map) 36 | import Data.Text (Text) 37 | 38 | import Amy.Names 39 | import Amy.Prim 40 | 41 | data Module 42 | = Module 43 | { moduleBindings :: ![Binding] 44 | , moduleExterns :: ![Extern] 45 | , moduleTypeDeclarations :: ![TypeDeclaration] 46 | , moduleExternTypes :: ![Type] 47 | , moduleTextPointers :: ![TextPointer] 48 | , moduleClosureWrappers :: ![ClosureWrapper] 49 | } deriving (Show, Eq) 50 | 51 | data Binding 52 | = Binding 53 | { bindingName :: !IdentName 54 | , bindingArgs :: ![Typed IdentName] 55 | , bindingReturnType :: !Type 56 | , bindingBody :: !Expr 57 | } deriving (Show, Eq) 58 | 59 | data Extern 60 | = Extern 61 | { externName :: !IdentName 62 | , externArgTypes :: ![Type] 63 | , externReturnType :: !Type 64 | } deriving (Show, Eq) 65 | 66 | data TypeDeclaration 67 | = TypeDeclaration 68 | { typeDeclarationTypeName :: !TyConName 69 | , typeDeclarationType :: !Type 70 | , typeDeclarationConstructors :: ![DataConDefinition] 71 | } deriving (Show, Eq) 72 | 73 | data DataConDefinition 74 | = DataConDefinition 75 | { dataConDefinitionName :: !DataConName 76 | , dataConDefinitionArgument :: !(Maybe Type) 77 | } deriving (Show, Eq, Ord) 78 | 79 | data ClosureWrapper 80 | = ClosureWrapper 81 | { closureWrapperName :: !IdentName 82 | , closureWrapperOriginalName :: !IdentName 83 | , closureWrapperArgTypes :: ![Type] 84 | , closureWrapperReturnType :: !Type 85 | } deriving (Show, Eq) 86 | 87 | data Val 88 | = Var !(Typed IdentName) 89 | | Lit !Literal 90 | | ConEnum !Word32 !DataCon 91 | deriving (Show, Eq) 92 | 93 | data Literal 94 | = LiteralInt !Int 95 | | LiteralDouble !Double 96 | | LiteralTextPointer !TextPointer 97 | deriving (Show, Eq) 98 | 99 | data TextPointer 100 | = TextPointer 101 | { textPointerId :: !Int 102 | , textPointerText :: !Text 103 | } deriving (Show, Eq) 104 | 105 | data DataCon 106 | = DataCon 107 | { dataConName :: !DataConName 108 | , dataConType :: !Type 109 | , dataConIndex :: !ConstructorIndex 110 | } deriving (Show, Eq, Ord) 111 | 112 | -- | The index of a data constructor is the position of a constructor within 113 | -- the declaration. For @Bool = False | True@, @False@ has position 0 and 114 | -- @True@ has position 1. The constructor in types with only one constructor 115 | -- have position 0 of course. 116 | newtype ConstructorIndex = ConstructorIndex { unConstructorIndex :: Int } 117 | deriving (Show, Eq, Ord) 118 | 119 | data Expr 120 | = EVal !Val 121 | | ERecord !(Map RowLabel (Typed Val)) 122 | | ERecordSelect !Val !RowLabel !Type 123 | | ELetVal !LetVal 124 | | ECase !Case 125 | | ECreateClosure !CreateClosure 126 | | ECallClosure !CallClosure 127 | | EKnownFuncApp !KnownFuncApp 128 | | EConApp !ConApp 129 | | EPrimOp !(App PrimitiveFunction) 130 | deriving (Show, Eq) 131 | 132 | data LetVal 133 | = LetVal 134 | { letValBindings :: ![LetValBinding] 135 | , letValExpression :: !Expr 136 | } deriving (Show, Eq) 137 | 138 | data LetValBinding 139 | = LetValBinding 140 | { letValBindingName :: !IdentName 141 | , letValBindingType :: !Type 142 | , letValBindingBody :: !Expr 143 | } deriving (Show, Eq) 144 | 145 | data Case 146 | = Case 147 | { caseScrutinee :: !Val 148 | , caseScrutineeBinding :: !(Typed IdentName) 149 | , caseAlternatives :: ![Match] 150 | , caseDefault :: !(Maybe Expr) 151 | , caseType :: !Type 152 | } deriving (Show, Eq) 153 | 154 | data CreateClosure 155 | = CreateClosure 156 | { createClosureFunctionName :: !IdentName 157 | , createClosureArity :: !Int 158 | } deriving (Show, Eq) 159 | 160 | data CallClosure 161 | = CallClosure 162 | { callClosureClosure :: !Val 163 | , callClosureArgs :: ![Val] 164 | , callClosureReturnType :: !Type 165 | } deriving (Show, Eq) 166 | 167 | data Match 168 | = Match 169 | { matchPattern :: !Pattern 170 | , matchBody :: !Expr 171 | } deriving (Show, Eq) 172 | 173 | data Pattern 174 | = PLit !Literal 175 | | PCons !PatCons 176 | deriving (Show, Eq) 177 | 178 | data PatCons 179 | = PatCons 180 | { patConsConstructor :: !DataCon 181 | , patConsArg :: !(Maybe (Typed IdentName)) 182 | , patConsType :: !Type 183 | } deriving (Show, Eq) 184 | 185 | data KnownFuncApp 186 | = KnownFuncApp 187 | { knownFuncAppFunction :: !IdentName 188 | , knownFuncAppArgs :: ![Val] 189 | , knownFuncAppArgTypes :: ![Type] 190 | , knownFuncAppOriginalReturnType :: !Type 191 | , knownFuncAppReturnType :: !Type 192 | } deriving (Show, Eq) 193 | 194 | data App f 195 | = App 196 | { appFunction :: !f 197 | , appArgs :: ![Val] 198 | , appReturnType :: !Type 199 | } deriving (Show, Eq) 200 | 201 | data ConApp 202 | = ConApp 203 | { conAppCon :: !DataCon 204 | , conAppArg :: !(Maybe Val) 205 | , conAppTaggedUnionName :: !TyConName 206 | , conAppTaggedUnionTagBits :: !Word32 207 | } deriving (Show, Eq) 208 | 209 | data Type 210 | = PrimIntType 211 | | PrimDoubleType 212 | | PrimTextType 213 | | PointerType !Type 214 | | OpaquePointerType 215 | -- ^ Used for polymorphic types 216 | | ClosureType 217 | | EnumType !Word32 218 | | TaggedUnionType !TyConName !Word32 219 | | RecordType ![(RowLabel, Type)] 220 | deriving (Show, Eq, Ord) 221 | 222 | data Typed a 223 | = Typed 224 | { typedType :: !Type 225 | , typedValue :: !a 226 | } deriving (Show, Eq, Ord, Functor) 227 | -------------------------------------------------------------------------------- /library/Amy/ANF/ConvertType.hs: -------------------------------------------------------------------------------- 1 | module Amy.ANF.ConvertType 2 | ( convertANFType 3 | ) where 4 | 5 | import Data.List.NonEmpty (NonEmpty(..)) 6 | import Data.Map.Strict (Map) 7 | import qualified Data.Map.Strict as Map 8 | import Data.Maybe (fromMaybe) 9 | 10 | import Amy.ANF.AST as ANF 11 | import Amy.Syntax.AST as S 12 | 13 | -- | Converts a 'S.Type' into an ANF 'ANF.Type' 14 | -- 15 | -- The only trickiness here is we have to know how type constructors are 16 | -- represented in order to properly convert a type. 17 | -- 18 | convertANFType :: Map TyConName ANF.Type -> S.Type -> ANF.Type 19 | convertANFType tyConReps ty = go (unfoldTyFun ty) 20 | where 21 | lookupTyConRep :: TyConName -> ANF.Type 22 | lookupTyConRep tyCon = 23 | fromMaybe (error $ "Couldn't find ANF Type for unknown TyCon " ++ show tyCon) 24 | $ Map.lookup tyCon tyConReps 25 | go :: NonEmpty S.Type -> ANF.Type 26 | go (ty' :| []) = 27 | case ty' of 28 | S.TyUnknown -> error "Encountered TyUnknown in convertType" 29 | S.TyCon (MaybeLocated _ con) -> lookupTyConRep con 30 | S.TyVar _ -> OpaquePointerType 31 | S.TyExistVar _ -> error "Found TyExistVar in Core" 32 | app@S.TyApp{} -> 33 | case unfoldTyApp app of 34 | TyCon (MaybeLocated _ con) :| _ -> lookupTyConRep con 35 | _ -> error $ "Can't convert non-TyCon TyApp yet " ++ show ty' 36 | -- N.B. ANF/LLVM doesn't care about polymorphic records 37 | S.TyRecord rows _ -> mkRecordType tyConReps rows 38 | S.TyFun{} -> ClosureType 39 | S.TyForall _ ty'' -> convertANFType tyConReps ty'' 40 | go _ = ClosureType 41 | 42 | mkRecordType :: Map TyConName ANF.Type -> Map (MaybeLocated RowLabel) S.Type -> ANF.Type 43 | mkRecordType tyConReps rows = 44 | RecordType $ flip fmap (Map.toAscList rows) $ \(MaybeLocated _ label, ty) -> (label, convertANFType tyConReps ty) 45 | -------------------------------------------------------------------------------- /library/Amy/ANF/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TupleSections #-} 4 | 5 | module Amy.ANF.Monad 6 | ( ANFConvert 7 | , runANFConvert 8 | , ANFConvertState 9 | , freshId 10 | , freshIdent 11 | , convertType 12 | , getTyConDefinitionType 13 | , getDataConInfo 14 | , getKnownFuncType 15 | , makeTextPointer 16 | , getTextPointers 17 | , putClosureWrapper 18 | , getClosureWrappers 19 | , getExternFunctions 20 | , getExternTypes 21 | ) where 22 | 23 | import Control.Monad.Reader 24 | import Control.Monad.State.Strict 25 | import Data.Foldable (for_) 26 | import Data.Map.Strict (Map) 27 | import qualified Data.Map.Strict as Map 28 | import Data.Maybe (fromMaybe) 29 | import Data.Set (Set) 30 | import qualified Data.Set as Set 31 | import Data.Text (Text, pack) 32 | 33 | import Amy.ANF.AST as ANF 34 | import Amy.ANF.ConvertType 35 | import Amy.Core.AST as C 36 | import Amy.Environment 37 | 38 | newtype ANFConvert a = ANFConvert (ReaderT ANFConvertRead (State ANFConvertState) a) 39 | deriving (Functor, Applicative, Monad, MonadReader ANFConvertRead, MonadState ANFConvertState) 40 | 41 | runANFConvert :: Environment -> Environment -> ANFConvert a -> a 42 | runANFConvert depsEnv moduleEnv (ANFConvert action) = 43 | let 44 | combinedEnv = depsEnv `mergeEnvironments` moduleEnv 45 | modTyCons = Set.fromList . Map.keys $ environmentANFTypeReps moduleEnv 46 | read' = ANFConvertRead combinedEnv moduleEnv modTyCons 47 | in evalState (runReaderT action read') (ANFConvertState 0 [] Map.empty Map.empty Map.empty) 48 | 49 | data ANFConvertRead 50 | = ANFConvertRead 51 | { combinedEnvironment :: !Environment 52 | , moduleEnvironment :: !Environment 53 | , moduleTyCons :: !(Set TyConName) 54 | } deriving (Show, Eq) 55 | 56 | data ANFConvertState 57 | = ANFConvertState 58 | { lastId :: !Int 59 | , textPointers :: ![TextPointer] 60 | , closureWrappers :: !(Map IdentName ClosureWrapper) 61 | , externFunctions :: !(Map IdentName ANF.Extern) 62 | , externTypes :: !(Map TyConName ANF.Type) 63 | } deriving (Show, Eq) 64 | 65 | freshId :: ANFConvert Int 66 | freshId = do 67 | modify' (\s -> s { lastId = 1 + lastId s }) 68 | gets lastId 69 | 70 | freshIdent :: Text -> ANFConvert IdentName 71 | freshIdent t = do 72 | id' <- freshId 73 | -- TODO: Give these a special name to ensure the name doesn't conflict with 74 | -- user-defined type variables. Prefix with "$"? 75 | pure $ IdentName (t <> pack (show id')) 76 | 77 | convertType :: C.Type -> ANFConvert ANF.Type 78 | convertType ty = do 79 | read' <- ask 80 | 81 | -- Compute ANF type 82 | let 83 | combinedTyMap = environmentANFTypeReps $ combinedEnvironment read' 84 | ty' = convertANFType combinedTyMap ty 85 | 86 | -- Record any types from outside the current module 87 | let 88 | tyCons = typeTyCons ty 89 | externalTyCons = tyCons `Set.difference` moduleTyCons read' 90 | externalTyMap = 91 | Map.fromList 92 | . fmap (\n -> maybe (error $ "Couldn't find TyCon rep " ++ show n) (n,) $ Map.lookup n combinedTyMap) 93 | $ Set.toList externalTyCons 94 | modify' $ \s -> s { externTypes = externTypes s <> externalTyMap } 95 | 96 | pure ty' 97 | 98 | getTyConDefinitionType :: C.TyConDefinition -> ANFConvert ANF.Type 99 | getTyConDefinitionType tyCon = 100 | fromMaybe err 101 | . Map.lookup (locatedValue $ tyConDefinitionName tyCon) 102 | <$> asks (environmentANFTypeReps . combinedEnvironment) 103 | where 104 | err = error $ "Couldn't find TypeCompilationMethod of TyConDefinition " ++ show tyCon 105 | 106 | getDataConInfo :: DataConName -> ANFConvert DataConInfo 107 | getDataConInfo con = fromMaybe err . Map.lookup con <$> asks (environmentDataConInfos . combinedEnvironment) 108 | where 109 | err = error $ "Couldn't find TypeCompilationMethod of TyConDefinition " ++ show con 110 | 111 | getKnownFuncType :: IdentName -> ANFConvert (Maybe ([ANF.Type], ANF.Type)) 112 | getKnownFuncType ident = do 113 | read' <- ask 114 | 115 | -- Look up known function type from current module 116 | let 117 | moduleFuncs = environmentANFFunctionTypes $ moduleEnvironment read' 118 | mFunc = Map.lookup ident moduleFuncs 119 | case mFunc of 120 | Just f -> pure (Just f) 121 | Nothing -> do 122 | -- Look up known function type from external module 123 | let 124 | combinedFuncs = environmentANFFunctionTypes $ combinedEnvironment read' 125 | mExternalFunc = Map.lookup ident combinedFuncs 126 | 127 | -- Record external function use 128 | for_ mExternalFunc $ \(argTys, retTy) -> do 129 | let extern = ANF.Extern ident argTys retTy 130 | modify' $ \s -> s { externFunctions = Map.insert ident extern (externFunctions s) } 131 | 132 | pure mExternalFunc 133 | 134 | makeTextPointer :: Text -> ANFConvert ANF.TextPointer 135 | makeTextPointer text = do 136 | id' <- freshId 137 | let ptr = ANF.TextPointer id' text 138 | modify' $ \s -> s { textPointers = ptr : textPointers s } 139 | pure ptr 140 | 141 | getTextPointers :: ANFConvert [TextPointer] 142 | getTextPointers = reverse <$> gets textPointers 143 | 144 | putClosureWrapper :: IdentName -> [ANF.Type] -> ANF.Type -> ANFConvert IdentName 145 | putClosureWrapper original@(IdentName t) argTys retTy = do 146 | let 147 | name = IdentName $ t <> "_closure_wrapper" 148 | wrapper = ANF.ClosureWrapper name original argTys retTy 149 | -- TODO: Maybe check for duplicates and ensure they are equal 150 | modify' $ \s -> s { closureWrappers = Map.insert name wrapper (closureWrappers s) } 151 | pure name 152 | 153 | getClosureWrappers :: ANFConvert [ClosureWrapper] 154 | getClosureWrappers = fmap snd . Map.toAscList <$> gets closureWrappers 155 | 156 | getExternFunctions :: ANFConvert [ANF.Extern] 157 | getExternFunctions = fmap snd . Map.toAscList <$> gets externFunctions 158 | 159 | getExternTypes :: ANFConvert [ANF.Type] 160 | getExternTypes = fmap snd . Map.toAscList <$> gets externTypes 161 | -------------------------------------------------------------------------------- /library/Amy/ANF/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Amy.ANF.Pretty 4 | ( prettyModule 5 | , prettyExpr 6 | ) where 7 | 8 | import Data.Foldable (toList) 9 | import Data.Maybe (maybeToList) 10 | import qualified Data.Map.Strict as Map 11 | 12 | import Amy.ANF.AST 13 | import Amy.Pretty hiding (prettyType) 14 | import Amy.Prim 15 | 16 | prettyType :: Type -> Doc ann 17 | prettyType PrimIntType = "PrimInt" 18 | prettyType PrimDoubleType = "PrimDouble" 19 | prettyType PrimTextType = "PrimText" 20 | prettyType (PointerType ty) = "Pointer" <+> parens (prettyType ty) 21 | prettyType OpaquePointerType = "OpaquePointer" 22 | prettyType ClosureType = "ClosureType" 23 | prettyType (EnumType bits) = "Enum" <+> pretty bits 24 | prettyType (TaggedUnionType (TyConName name) bits) = "TaggedUnion" <+> pretty name <+> pretty bits 25 | prettyType (RecordType rows) = 26 | "RecordType" <> groupOrHang (bracketed ((\(RowLabel label, ty) -> pretty label <+> "::" <> groupOrHang (prettyType ty)) <$> rows)) 27 | 28 | prettyFunctionType :: [Type] -> Type -> Doc ann 29 | prettyFunctionType args retTy = "Func" <> groupOrHang (tupled (prettyType <$> args) <+> "=>" <+> prettyType retTy) 30 | 31 | prettyModule :: Module -> Doc ann 32 | prettyModule (Module bindings externs typeDeclarations _ _ closureWrappers) = 33 | vcatTwoHardLines 34 | $ (prettyExtern' <$> externs) 35 | ++ (prettyTypeDeclaration' <$> typeDeclarations) 36 | ++ (prettyClosureWrapper <$> closureWrappers) 37 | ++ (prettyBinding' <$> bindings) 38 | 39 | prettyExtern' :: Extern -> Doc ann 40 | prettyExtern' (Extern name argTys retTy) = 41 | prettyExtern (prettyIdent name) (prettyFunctionType argTys retTy) 42 | 43 | prettyTypeDeclaration' :: TypeDeclaration -> Doc ann 44 | prettyTypeDeclaration' (TypeDeclaration tyName _ cons) = 45 | prettyTypeDeclaration (prettyTyConName tyName) (prettyConstructor <$> cons) 46 | where 47 | prettyConstructor (DataConDefinition conName mArg) = 48 | prettyDataConstructor (prettyDataConName conName) (prettyType <$> mArg) 49 | 50 | prettyClosureWrapper :: ClosureWrapper -> Doc ann 51 | prettyClosureWrapper (ClosureWrapper wrapperName originalName argTys returnTy) = 52 | prettyIdent wrapperName <+> parens (prettyIdent originalName) <+> list (prettyType <$> argTys) <+> "=>" <+> prettyType returnTy 53 | 54 | prettyBinding' :: Binding -> Doc ann 55 | prettyBinding' (Binding ident args retTy body) = 56 | prettyBindingType (prettyIdent ident) (prettyFunctionType (typedType <$> args) retTy) <> 57 | hardline <> 58 | prettyBinding (prettyIdent ident) (prettyIdent . typedValue <$> args) (prettyExpr body) 59 | 60 | prettyVal :: Val -> Doc ann 61 | prettyVal (Var (Typed _ ident)) = prettyIdent ident 62 | prettyVal (Lit lit) = pretty $ show lit 63 | prettyVal (ConEnum _ con) = prettyDataConName (dataConName con) 64 | 65 | prettyExpr :: Expr -> Doc ann 66 | prettyExpr (EVal val) = prettyVal val 67 | prettyExpr (ERecord rows) = bracketed $ uncurry prettyRow <$> Map.toList (typedValue <$> rows) 68 | prettyExpr (ERecordSelect val field _) = prettyVal val <> "." <> prettyRowLabel field 69 | prettyExpr (ECase (Case scrutinee (Typed _ bind) matches mDefault _)) = 70 | prettyCase 71 | (prettyVal scrutinee) 72 | (Just $ prettyIdent bind) 73 | (toList (mkMatch <$> matches) ++ defaultMatch) 74 | where 75 | mkMatch (Match pat body) = (prettyPattern pat, prettyExpr body) 76 | defaultMatch = 77 | case mDefault of 78 | Nothing -> [] 79 | Just def -> [("__DEFAULT", prettyExpr def)] 80 | prettyExpr (ECreateClosure (CreateClosure f arity)) = 81 | "$createClosure" <+> prettyIdent f <+> pretty arity 82 | prettyExpr (ECallClosure (CallClosure f args retTy)) = 83 | "$callClosure" <+> prettyVal f <+> list (prettyVal <$> args) <+> "::" <+> prettyType retTy 84 | prettyExpr (ELetVal (LetVal bindings body)) = 85 | prettyLetVal (prettyLetValBinding <$> bindings) (prettyExpr body) 86 | prettyExpr (EKnownFuncApp (KnownFuncApp ident args _ _ _)) = 87 | "$call" <+> prettyIdent ident <+> list (prettyVal <$> args) 88 | prettyExpr (EConApp (ConApp info mArg _ _)) = 89 | "$mkCon" <+> prettyDataConName (dataConName info) <+> list (prettyVal <$> maybeToList mArg) 90 | prettyExpr (EPrimOp (App (PrimitiveFunction _ name _) args _)) = 91 | "$primOp" <+> prettyIdent name <+> list (prettyVal <$> args) 92 | 93 | prettyRow :: RowLabel -> Val -> Doc ann 94 | prettyRow label val = prettyRowLabel label <> ":" <> groupOrHang (prettyVal val) 95 | 96 | prettyLetValBinding :: LetValBinding -> Doc ann 97 | prettyLetValBinding (LetValBinding ident ty body) = 98 | prettyBindingType (prettyIdent ident) (prettyType ty) <> 99 | hardline <> 100 | prettyBinding (prettyIdent ident) [] (prettyExpr body) 101 | 102 | prettyPattern :: Pattern -> Doc ann 103 | prettyPattern (PLit lit) = pretty $ show lit 104 | prettyPattern (PCons (PatCons con mArg _)) = 105 | prettyDataConName (dataConName con) 106 | <> maybe mempty (\(Typed ty arg) -> space <> parens (prettyIdent arg <+> "::" <+> prettyType ty)) mArg 107 | -------------------------------------------------------------------------------- /library/Amy/ANF/TypeRep.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Amy.ANF.TypeRep 5 | ( typeRep 6 | ) where 7 | 8 | import Data.Maybe (isNothing) 9 | import Data.Text (Text) 10 | import GHC.Word (Word32) 11 | 12 | import Amy.ANF.AST as ANF 13 | import Amy.Syntax.AST as S 14 | 15 | -- | Describes how an Amy type is represented in LLVM. 16 | data TypeRep 17 | = EnumRep !Word32 18 | -- ^ Compile as an int type with 'Word32' bits. 19 | | TaggedUnionRep !Text !Word32 20 | -- ^ Represent as a struct with a 'Word32'-sized integer tag and an integer 21 | -- pointer to data. 22 | deriving (Show, Eq, Ord) 23 | 24 | -- | Decide how we are going to compile a type declaration. 25 | typeRep :: S.TypeDeclaration -> ANF.Type 26 | typeRep (S.TypeDeclaration tyName constructors) = 27 | case maybePrimitiveType tyName of 28 | Just prim -> prim 29 | Nothing -> 30 | -- Check if we can do an enum. This is when all constructors have no 31 | -- arguments. 32 | if all (isNothing . S.dataConDefinitionArgument) constructors 33 | then EnumType wordSize 34 | -- Can't do an enum. We'll have to use tagged pairs. 35 | else TaggedUnionType (locatedValue $ tyConDefinitionName tyName) wordSize 36 | where 37 | -- Pick a proper integer size 38 | wordSize :: Word32 39 | wordSize = 40 | if | length constructors <= 2 -> 1 41 | | length constructors < (2 :: Int) ^ (8 :: Int) -> 8 42 | | otherwise -> 32 43 | 44 | maybePrimitiveType :: S.TyConDefinition -> Maybe ANF.Type 45 | maybePrimitiveType (S.TyConDefinition (Located _ name) _) 46 | -- TODO: Something more robust here besides text name matching. 47 | | name == "Int" = Just PrimIntType 48 | | name == "Double" = Just PrimDoubleType 49 | | name == "Text" = Just PrimTextType 50 | | otherwise = Nothing 51 | -------------------------------------------------------------------------------- /library/Amy/Codegen.hs: -------------------------------------------------------------------------------- 1 | module Amy.Codegen 2 | ( module X 3 | ) where 4 | 5 | import Amy.Codegen.Emit as X 6 | import Amy.Codegen.Pure as X 7 | -------------------------------------------------------------------------------- /library/Amy/Codegen/CaseBlocks.hs: -------------------------------------------------------------------------------- 1 | module Amy.Codegen.CaseBlocks 2 | ( CaseBlocks(..) 3 | , caseBlocks 4 | , CaseLiteralBlock(..) 5 | , CaseDefaultBlock(..) 6 | , CaseEndBlock(..) 7 | , literalConstant 8 | ) where 9 | 10 | import LLVM.AST as LLVM 11 | import LLVM.AST.AddrSpace 12 | import qualified LLVM.AST.Constant as C 13 | import LLVM.AST.Float as F 14 | 15 | import Amy.ANF.AST as ANF 16 | import Amy.Codegen.Utils 17 | 18 | data CaseBlocks 19 | = CaseBlocks 20 | { caseBlocksSwitchDefaultBlockName :: !Name 21 | , caseBlocksLiteralBlocks :: ![CaseLiteralBlock] 22 | , caseBlocksDefaultBlock :: !(Maybe CaseDefaultBlock) 23 | , caseBlocksEndBlock :: !CaseEndBlock 24 | } deriving (Show, Eq) 25 | 26 | data CaseLiteralBlock 27 | = CaseLiteralBlock 28 | { caseLiteralBlockExpr :: !Expr 29 | , caseLiteralBlockName :: !Name 30 | , caseLiteralBlockNextName :: !Name 31 | , caseLiteralBlockConstant :: !C.Constant 32 | , caseLiteralBlockBind :: !(Maybe (Typed IdentName)) 33 | } deriving (Show, Eq) 34 | 35 | data CaseDefaultBlock 36 | = CaseDefaultBlock 37 | { caseDefaultBlockExpr :: !Expr 38 | , caseDefaultBlockName :: !Name 39 | , caseDefaultBlockNextName :: !Name 40 | } deriving (Show, Eq) 41 | 42 | data CaseEndBlock 43 | = CaseEndBlock 44 | { caseEndBlockName :: !Name 45 | , caseEndBlockType :: !ANF.Type 46 | } deriving (Show, Eq) 47 | 48 | caseBlocks :: (String -> Name) -> Case -> CaseBlocks 49 | caseBlocks mkBlockName (Case _ _ matches mDefault ty) = 50 | let 51 | -- Compute names for everything 52 | defaultBlockName = mkBlockName "case.default." 53 | endBlockName = mkBlockName "case.end." 54 | literalBlockNames = mkBlockName . (\i -> "case." ++ i ++ ".") . show <$> [0 .. (length matches - 1)] 55 | nextLiteralBlockNames = drop 1 literalBlockNames ++ [endBlockName] 56 | 57 | -- Compute default block 58 | defaultBlockNextName = 59 | case literalBlockNames of 60 | [] -> endBlockName 61 | firstBlockName:_ -> firstBlockName 62 | mkDefaultBlock expr = 63 | CaseDefaultBlock 64 | { caseDefaultBlockExpr = expr 65 | , caseDefaultBlockName = defaultBlockName 66 | , caseDefaultBlockNextName = defaultBlockNextName 67 | } 68 | defaultBlock = mkDefaultBlock <$> mDefault 69 | switchDefaultBlockName = 70 | case (defaultBlock, literalBlockNames) of 71 | (Just block, _) -> caseDefaultBlockName block 72 | (Nothing, firstBlockName:_) -> firstBlockName 73 | (Nothing, []) -> endBlockName 74 | 75 | -- Compute literal blocks 76 | literalBlock (Match pat expr, (blockName, nextBlockName)) = 77 | let 78 | (constant, mBind) = 79 | case pat of 80 | PLit lit -> (literalConstant lit, Nothing) 81 | PCons (PatCons con mArg _) -> (constructorConstant con, mArg) 82 | in 83 | CaseLiteralBlock 84 | { caseLiteralBlockExpr = expr 85 | , caseLiteralBlockName = blockName 86 | , caseLiteralBlockNextName = nextBlockName 87 | , caseLiteralBlockConstant = constant 88 | , caseLiteralBlockBind = mBind 89 | } 90 | literalBlocks = literalBlock <$> zip matches (zip literalBlockNames nextLiteralBlockNames) 91 | 92 | -- Compute end block 93 | endBlock = 94 | CaseEndBlock 95 | { caseEndBlockName = endBlockName 96 | , caseEndBlockType = ty 97 | } 98 | in 99 | CaseBlocks 100 | { caseBlocksSwitchDefaultBlockName = switchDefaultBlockName 101 | , caseBlocksLiteralBlocks = literalBlocks 102 | , caseBlocksDefaultBlock = defaultBlock 103 | , caseBlocksEndBlock = endBlock 104 | } 105 | 106 | literalConstant :: Literal -> C.Constant 107 | literalConstant lit = 108 | case lit of 109 | LiteralInt i -> C.Int 64 (fromIntegral i) 110 | LiteralDouble x -> C.Float (F.Double x) 111 | LiteralTextPointer ptr -> 112 | C.GetElementPtr 113 | True 114 | (C.GlobalReference (LLVM.PointerType (textPointerType ptr) (AddrSpace 0)) (textPointerName ptr)) 115 | [ C.Int 32 0 116 | , C.Int 32 0 117 | ] 118 | 119 | constructorConstant :: DataCon -> C.Constant 120 | constructorConstant con = 121 | case dataConType con of 122 | EnumType intBits -> C.Int intBits (fromIntegral i) 123 | TaggedUnionType _ intBits -> C.Int intBits (fromIntegral i) 124 | _ -> error $ "Invalid constructor type " ++ show con 125 | where 126 | (ConstructorIndex i) = dataConIndex con 127 | -------------------------------------------------------------------------------- /library/Amy/Codegen/Emit.hs: -------------------------------------------------------------------------------- 1 | module Amy.Codegen.Emit 2 | ( generateLLVMIR 3 | , linkModuleIRs 4 | , optimizeLLVM 5 | ) where 6 | 7 | import Control.Monad (foldM, void) 8 | import Data.ByteString (ByteString) 9 | import Data.List.NonEmpty (NonEmpty(..)) 10 | import LLVM.AST 11 | import LLVM.Context 12 | import LLVM.Module 13 | import LLVM.PassManager 14 | 15 | generateLLVMIR :: LLVM.AST.Module -> IO ByteString 16 | generateLLVMIR mod' = 17 | withContext $ \context -> 18 | withModuleFromAST context mod' $ \m -> 19 | moduleLLVMAssembly m 20 | 21 | linkModuleIRs :: NonEmpty FilePath -> IO ByteString 22 | linkModuleIRs modules = 23 | withContext $ \context -> do 24 | let 25 | go mod1 mod2IR = 26 | withModuleFromLLVMAssembly context (File mod2IR) $ \mod2 -> do 27 | linkModules mod1 mod2 28 | pure mod1 29 | mod1IR :| restIR = modules 30 | withModuleFromLLVMAssembly context (File mod1IR) $ \mod1 -> do 31 | linked <- foldM go mod1 restIR 32 | moduleLLVMAssembly linked 33 | 34 | optimizeLLVM :: FilePath -> IO ByteString 35 | optimizeLLVM path = 36 | withContext $ \context -> 37 | withModuleFromLLVMAssembly context (File path) $ \llvm -> 38 | withPassManager passSpec $ \passManager -> do 39 | void $ runPassManager passManager llvm 40 | moduleLLVMAssembly llvm 41 | where 42 | passSpec = 43 | defaultCuratedPassSetSpec 44 | { optLevel = Just 3 45 | } 46 | -------------------------------------------------------------------------------- /library/Amy/Codegen/Malloc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Amy.Codegen.Malloc 4 | ( callMalloc 5 | ) where 6 | 7 | import LLVM.AST 8 | import LLVM.AST.AddrSpace 9 | import qualified LLVM.AST.CallingConvention as CC 10 | import qualified LLVM.AST.Constant as C 11 | import LLVM.AST.Global as LLVM 12 | 13 | import Amy.Codegen.Monad 14 | 15 | mallocDefinition :: Global 16 | mallocDefinition = 17 | functionDefaults 18 | { name = mallocFunctionName 19 | , parameters = ([Parameter mallocArgType (UnName 0) []], False) 20 | , LLVM.returnType = mallocReturnType 21 | } 22 | 23 | mallocFunctionName :: Name 24 | mallocFunctionName = "GC_malloc" 25 | 26 | -- N.B. This only applies to 64 bit platforms. We probably need to get the 27 | -- exact malloc type for the target machine. 28 | mallocArgType :: Type 29 | mallocArgType = IntegerType 64 30 | 31 | mallocReturnType :: Type 32 | mallocReturnType = PointerType (IntegerType 8) (AddrSpace 0) 33 | 34 | mallocFunctionType :: Type 35 | mallocFunctionType = 36 | FunctionType 37 | { resultType = mallocReturnType 38 | , argumentTypes = [mallocArgType] 39 | , isVarArg = False 40 | } 41 | 42 | callMalloc :: Name -> Maybe Integer -> Type -> BlockGen Operand 43 | callMalloc ptrName mSize ty = do 44 | -- Make sure malloc definition is generated 45 | genExternalGlobal mallocDefinition 46 | 47 | -- Compute size of type 48 | size <- maybe (sizeOfType ty) (pure . ConstantOperand . C.Int 64) mSize 49 | 50 | -- Call malloc 51 | mallocName <- freshUnName 52 | let 53 | funcOp = ConstantOperand $ C.GlobalReference (PointerType mallocFunctionType (AddrSpace 0)) mallocFunctionName 54 | mallocOp = LocalReference mallocReturnType mallocName 55 | addInstruction $ mallocName := Call Nothing CC.C [] (Right funcOp) [(size, [])] [] [] 56 | 57 | -- Bitcast pointer to what caller intended 58 | let 59 | ptrTy = PointerType ty (AddrSpace 0) 60 | ptrOp = LocalReference ptrTy ptrName 61 | addInstruction $ ptrName := BitCast mallocOp ptrTy [] 62 | pure ptrOp 63 | 64 | -- | Uses getelemtnptr to compute the size of an LLVM type. See 65 | -- https://stackoverflow.com/a/30830445/1333514 66 | sizeOfType :: Type -> BlockGen Operand 67 | sizeOfType ty = do 68 | -- Compute size of type using getelementptr 69 | ptrName <- freshUnName 70 | let 71 | ptrTy = PointerType ty (AddrSpace 0) 72 | ptrOp = LocalReference ptrTy ptrName 73 | nullOp = ConstantOperand $ C.Null ptrTy 74 | addInstruction $ ptrName := GetElementPtr False nullOp [ConstantOperand (C.Int 32 1)] [] 75 | 76 | -- Convert pointer size to an int 77 | sizeName <- freshUnName 78 | let 79 | sizeTy = mallocArgType 80 | sizeOp = LocalReference sizeTy sizeName 81 | addInstruction $ sizeName := PtrToInt ptrOp sizeTy [] 82 | pure sizeOp 83 | -------------------------------------------------------------------------------- /library/Amy/Codegen/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Amy.Codegen.Monad 6 | ( runCodeGen 7 | , CodeGen 8 | , CodeGenState 9 | , runBlockGen 10 | , BlockGen 11 | , addInstruction 12 | , terminateBlock 13 | , currentBlockName 14 | , freshId 15 | , freshUnName 16 | , genExternalGlobal 17 | , genExternalType 18 | ) where 19 | 20 | import Control.Monad.State.Strict 21 | import qualified Control.Monad.Trans.State.Strict as TS 22 | import Data.Foldable (for_) 23 | import Data.Map.Strict (Map) 24 | import qualified Data.Map.Strict as Map 25 | import LLVM.AST as LLVM 26 | import qualified LLVM.AST.Global as G 27 | 28 | newtype CodeGen a = CodeGen (State CodeGenState a) 29 | deriving (Functor, Applicative, Monad, MonadState CodeGenState) 30 | 31 | runCodeGen :: CodeGen [Definition] -> [Definition] 32 | runCodeGen (CodeGen action) = 33 | let 34 | cgState = CodeGenState Map.empty 35 | (result, state') = runState action cgState 36 | externalDefs = fmap snd . Map.toAscList . codeGenStateExternalFunctions $ state' 37 | in externalDefs ++ result 38 | 39 | data CodeGenState 40 | = CodeGenState 41 | { codeGenStateExternalFunctions :: !(Map Name Definition) 42 | } 43 | 44 | newtype BlockGen a = BlockGen (StateT BlockGenState CodeGen a) 45 | deriving (Functor, Applicative, Monad, MonadState BlockGenState) 46 | 47 | runBlockGen :: BlockGen Operand -> CodeGen [BasicBlock] 48 | runBlockGen (BlockGen action) = do 49 | (operand, BlockGenState lastBlock blockStack _) <- runStateT action (blockGenState "entry") 50 | pure $ reverse $ makeBasicBlock lastBlock (Do $ Ret (Just operand) []) : blockStack 51 | 52 | data BlockGenState 53 | = BlockGenState 54 | { blockGenStateCurrentBlock :: !PartialBlock 55 | , blockGenStateBlockStack :: ![BasicBlock] 56 | -- TOOD: We need to make sure this last ID is higher than the max ID from 57 | -- the ANF AST. We also need to share this last ID across BlockGen 58 | -- invocations from different functions. 59 | , blockGenStateLastId :: !Word 60 | } deriving (Show, Eq) 61 | 62 | blockGenState :: LLVM.Name -> BlockGenState 63 | blockGenState name' = BlockGenState (partialBlock name') [] 0 64 | 65 | liftCodeGen :: CodeGen a -> BlockGen a 66 | liftCodeGen = BlockGen . lift 67 | 68 | -- | In-progress 'BasicBlock' without terminator 69 | data PartialBlock 70 | = PartialBlock 71 | { partialBlockName :: LLVM.Name 72 | , partialBlockInstructions :: [Named Instruction] -- NB: In reverse order 73 | } deriving (Show, Eq) 74 | 75 | partialBlock :: LLVM.Name -> PartialBlock 76 | partialBlock name' = PartialBlock name' [] 77 | 78 | makeBasicBlock :: PartialBlock -> Named Terminator -> BasicBlock 79 | makeBasicBlock (PartialBlock name' instructions) = BasicBlock name' (reverse instructions) 80 | 81 | addInstruction :: Named Instruction -> BlockGen () 82 | addInstruction instr = 83 | modify' $ \s -> s { blockGenStateCurrentBlock = addInstruction' (blockGenStateCurrentBlock s) } 84 | where 85 | addInstruction' block = block { partialBlockInstructions = instr : partialBlockInstructions block } 86 | 87 | terminateBlock :: Named Terminator -> LLVM.Name -> BlockGen () 88 | terminateBlock term newName = 89 | modify' 90 | (\s@(BlockGenState current stack _ ) -> 91 | s 92 | { blockGenStateCurrentBlock = partialBlock newName 93 | , blockGenStateBlockStack = makeBasicBlock current term : stack 94 | } 95 | ) 96 | 97 | currentBlockName :: BlockGen LLVM.Name 98 | currentBlockName = gets (partialBlockName . blockGenStateCurrentBlock) 99 | 100 | freshId :: BlockGen Word 101 | freshId = do 102 | id' <- gets blockGenStateLastId 103 | modify' (\s -> s { blockGenStateLastId = 1 + blockGenStateLastId s }) 104 | pure id' 105 | 106 | freshUnName :: BlockGen LLVM.Name 107 | freshUnName = UnName <$> freshId 108 | 109 | genExternalGlobal :: Global -> BlockGen () 110 | genExternalGlobal global = genExternalDefinition (G.name global) (GlobalDefinition global) 111 | 112 | genExternalType :: Name -> LLVM.Type -> BlockGen () 113 | genExternalType name ty = genExternalDefinition name (TypeDefinition name (Just ty)) 114 | 115 | genExternalDefinition :: Name -> Definition -> BlockGen () 116 | genExternalDefinition name def = liftCodeGen $ CodeGen $ do 117 | mExistingDef <- TS.gets (Map.lookup name . codeGenStateExternalFunctions) 118 | for_ mExistingDef $ \existingDef -> 119 | when (existingDef /= def) $ 120 | error $ "Definitions don't match! " ++ show (name, existingDef, def) 121 | TS.modify' $ \s -> 122 | s { codeGenStateExternalFunctions = Map.insert name def (codeGenStateExternalFunctions s) } 123 | -------------------------------------------------------------------------------- /library/Amy/Codegen/TypeConversion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Amy.Codegen.TypeConversion 4 | ( maybeConvertPointer 5 | , loadPointerToType 6 | , operandType 7 | , bindOpToName 8 | ) where 9 | 10 | import Data.Maybe (fromMaybe) 11 | import Data.Traversable (for) 12 | import LLVM.AST 13 | import LLVM.AST.AddrSpace 14 | import qualified LLVM.AST.Constant as C 15 | import LLVM.AST.Float as F 16 | 17 | import Amy.Codegen.Malloc 18 | import Amy.Codegen.Monad 19 | import Amy.Codegen.Utils 20 | 21 | maybeConvertPointer :: Maybe Name -> Operand -> Type -> BlockGen Operand 22 | maybeConvertPointer mName op targetTy = 23 | if operandType op == targetTy 24 | then 25 | fromMaybe op <$> for mName (\name' -> bindOpToName name' op) 26 | else 27 | case (operandType op, targetTy) of 28 | (PointerType _ _, PointerType _ _) -> maybeBitcast mName targetTy op 29 | (_, PointerType _ _) -> allocOp op >>= maybeBitcast mName targetTy 30 | (PointerType _ _, _) -> maybeBitcast Nothing (PointerType targetTy (AddrSpace 0)) op >>= loadPointerToType mName targetTy 31 | (_, _) -> error $ "Failed to maybeConvertToPointer " ++ show (op, targetTy) 32 | 33 | allocOp :: Operand -> BlockGen Operand 34 | allocOp op = do 35 | -- Store operand in a pointer 36 | storeName <- freshUnName 37 | let 38 | opTy = operandType op 39 | storeOp <- callMalloc storeName Nothing opTy 40 | addInstruction $ Do $ Store False storeOp op Nothing 0 [] 41 | pure storeOp 42 | 43 | loadPointerToType :: Maybe Name -> Type -> Operand -> BlockGen Operand 44 | loadPointerToType mName targetTy op = namedInstruction mName (Load False op Nothing 0 []) targetTy 45 | 46 | maybeBitcast :: Maybe Name -> Type -> Operand -> BlockGen Operand 47 | maybeBitcast mName ty op = 48 | -- Bitcast if we have to 49 | if operandType op == ty 50 | then 51 | fromMaybe op <$> for mName (\name' -> bindOpToName name' op) 52 | else namedInstruction mName (BitCast op ty []) ty 53 | 54 | operandType :: Operand -> Type 55 | operandType (LocalReference ty _) = ty 56 | operandType (ConstantOperand c) = constantType c 57 | operandType md@(MetadataOperand _) = error $ "Can't get operandType for MetadataOperand: " ++ show md 58 | 59 | constantType :: C.Constant -> Type 60 | constantType c = 61 | case c of 62 | C.GlobalReference ty _ -> ty 63 | C.Int bits _ -> IntegerType bits 64 | C.Float ft -> FloatingPointType (someFloatType ft) 65 | -- Text constant references 66 | C.GetElementPtr _ (C.GlobalReference (PointerType (ArrayType _ ty) _) _) _ -> PointerType ty (AddrSpace 0) 67 | _ -> error $ "Unknown type for constant: " ++ show c 68 | 69 | someFloatType :: SomeFloat -> FloatingPointType 70 | someFloatType = 71 | \case 72 | Half _ -> HalfFP 73 | Single _ -> FloatFP 74 | Double _ -> DoubleFP 75 | Quadruple _ _ -> FP128FP 76 | X86_FP80 _ _ -> X86_FP80FP 77 | PPC_FP128 _ _ -> PPC_FP128FP 78 | 79 | -- floatingPointBits :: FloatingPointType -> Int 80 | -- floatingPointBits = 81 | -- \case 82 | -- HalfFP -> 16 83 | -- FloatFP -> 32 84 | -- DoubleFP -> 64 85 | -- FP128FP -> 128 86 | -- X86_FP80FP -> 80 87 | -- PPC_FP128FP -> 128 88 | 89 | bindOpToName :: Name -> Operand -> BlockGen Operand 90 | bindOpToName name' op = do 91 | storeOp <- namedInstruction Nothing (Alloca (operandType op) Nothing 0 []) (PointerType (operandType op) (AddrSpace 0)) 92 | addInstruction $ Do $ Store False storeOp op Nothing 0 [] 93 | namedInstruction (Just name') (Load False storeOp Nothing 0 []) (operandType op) 94 | -------------------------------------------------------------------------------- /library/Amy/Codegen/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Amy.Codegen.Utils 4 | ( identToName 5 | , textToName 6 | , stringToName 7 | , textPointerType 8 | , textPointerName 9 | , textPointerConstant 10 | , namedInstruction 11 | ) where 12 | 13 | import qualified Data.ByteString.Char8 as BS8 14 | import qualified Data.ByteString.Short as BSS 15 | import Data.Char (ord) 16 | import Data.Text (Text, pack, unpack) 17 | import qualified Data.Text as T 18 | import Data.Text.Encoding (encodeUtf8) 19 | import LLVM.AST as LLVM 20 | import qualified LLVM.AST.Constant as C 21 | 22 | import Amy.ANF.AST as ANF 23 | import Amy.Codegen.Monad 24 | 25 | identToName :: IdentName -> LLVM.Name 26 | identToName (IdentName name') = textToName name' 27 | 28 | textToName :: Text -> Name 29 | textToName = Name . BSS.toShort . encodeUtf8 30 | 31 | stringToName :: String -> Name 32 | stringToName = Name . BSS.toShort . BS8.pack 33 | 34 | textPointerType :: TextPointer -> LLVM.Type 35 | textPointerType (TextPointer _ text) = 36 | -- Length of text plus one extra for null character string terminator 37 | LLVM.ArrayType (fromIntegral (T.length text) + 1) (LLVM.IntegerType 8) 38 | 39 | textPointerName :: TextPointer -> LLVM.Name 40 | textPointerName (TextPointer id' _) = textToName $ "$str." <> pack (show id') 41 | 42 | textPointerConstant :: TextPointer -> C.Constant 43 | textPointerConstant (TextPointer _ text) = C.Array (LLVM.IntegerType 8) array 44 | where 45 | chars = (fromIntegral . ord <$> unpack text) ++ [0] 46 | array = C.Int 8 <$> chars 47 | 48 | namedInstruction :: Maybe LLVM.Name -> Instruction -> LLVM.Type -> BlockGen Operand 49 | namedInstruction mName instruction ty = do 50 | name' <- maybe freshUnName pure mName 51 | let op = LocalReference ty name' 52 | addInstruction $ name' := instruction 53 | pure op 54 | -------------------------------------------------------------------------------- /library/Amy/Compile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Amy.Compile 4 | ( compileModule 5 | , linkModules 6 | , DumpFlags(..) 7 | , CompiledModule(..) 8 | ) where 9 | 10 | import Control.Monad (when) 11 | import Control.Monad.Except 12 | import Data.Bifunctor (first) 13 | import qualified Data.ByteString.Char8 as BS8 14 | import Data.List.NonEmpty (NonEmpty(..)) 15 | import qualified Data.List.NonEmpty as NE 16 | import Data.Text (Text, pack) 17 | import qualified Data.Text.Lazy.IO as TL 18 | import LLVM.Pretty (ppllvm) 19 | import System.FilePath.Posix ((), dropExtension, replaceExtension, takeDirectory, takeFileName) 20 | import System.Process (callProcess) 21 | import Text.Megaparsec 22 | 23 | import Amy.ANF as ANF 24 | import Amy.Codegen 25 | import Amy.Core as C 26 | import Amy.Environment 27 | import Amy.Errors 28 | import Amy.Syntax as S 29 | import Amy.TypeCheck as TC 30 | 31 | compileModule 32 | :: Environment 33 | -- ^ 'Environment' for any dependencies 34 | -> FilePath 35 | -- ^ Original module file path 36 | -> DumpFlags 37 | -- ^ Flags to control intermediate output 38 | -> Text 39 | -- ^ Module source code 40 | -> IO (Either [String] CompiledModule) 41 | -- ^ Return any possible errors or a compiled module 42 | compileModule depsEnv filePath DumpFlags{..} input = runExceptT $ do 43 | -- Parse 44 | tokens' <- liftEither $ first ((:[]) . parseErrorPretty) $ lexer filePath input 45 | parsed <- liftEither $ first ((:[]) . parseErrorPretty) $ parse (runAmyParser parseModule) filePath tokens' 46 | when dfDumpParsed $ 47 | lift $ writeFile (filePath `replaceExtension` ".amy-parsed") (show $ S.prettyModule parsed) 48 | 49 | -- Type checking 50 | (typeChecked, typeCheckedModuleEnv) <- liftEither $ first ((:[]) . showError) $ TC.inferModule depsEnv parsed 51 | when dfDumpTypeChecked $ 52 | lift $ writeFile (filePath `replaceExtension` ".amy-typechecked") (show $ S.prettyModule typeChecked) 53 | 54 | -- Desugar to Core 55 | let 56 | coreEnv = mergeEnvironments depsEnv typeCheckedModuleEnv 57 | core = desugarModule coreEnv typeChecked 58 | when dfDumpCore $ 59 | lift $ writeFile (filePath `replaceExtension` ".amy-core") (show $ C.prettyModule core) 60 | 61 | -- Prepare for ANF 62 | let lifted = lambdaLifting core 63 | when dfDumpCoreLifted $ 64 | lift $ writeFile (filePath `replaceExtension` ".amy-core-lifted") (show $ C.prettyModule lifted) 65 | 66 | -- Normalize to ANF 67 | let 68 | anfEnv = coreEnv 69 | (anf, anfModuleEnv) = normalizeModule lifted anfEnv 70 | when dfDumpANF $ 71 | lift $ writeFile (filePath `replaceExtension` ".amy-anf") (show $ ANF.prettyModule anf) 72 | 73 | -- Codegen to pure LLVM 74 | let llvmAST = codegenModule anf 75 | when dfDumpLLVMPretty $ 76 | lift $ TL.writeFile (filePath `replaceExtension` ".ll-pretty") (ppllvm llvmAST) 77 | 78 | -- Generate LLVM IR using C++ API 79 | let llvmFile = filePath `replaceExtension` ".ll" 80 | llvm <- lift $ generateLLVMIR llvmAST 81 | lift $ BS8.writeFile llvmFile llvm 82 | 83 | -- Construct CompiledModule 84 | let 85 | moduleName = ModuleName . pack . dropExtension . takeFileName $ filePath 86 | moduleEnv = typeCheckedModuleEnv `mergeEnvironments` anfModuleEnv 87 | compiledModule = CompiledModule moduleName moduleEnv llvmFile 88 | pure compiledModule 89 | 90 | linkModules :: NonEmpty CompiledModule -> FilePath -> IO () 91 | linkModules modules rtsLL = do 92 | let 93 | depModules = NE.init modules 94 | module' = NE.last modules 95 | depFiles = compiledModuleLLVM <$> depModules 96 | moduleFile = compiledModuleLLVM module' 97 | 98 | -- Link dependencies 99 | let linkedLL = dropExtension moduleFile ++ "-rts-linked.ll" 100 | linked <- linkModuleIRs (moduleFile :| rtsLL : depFiles) 101 | BS8.writeFile linkedLL linked 102 | 103 | -- Optimize LLVM 104 | -- TODO: This breaks some examples 105 | -- let optLL = dropExtension moduleFile ++ "-rts-opt.ll" 106 | -- opt <- optimizeLLVM linkedLL 107 | -- BS8.writeFile optLL opt 108 | 109 | -- Compile with clang 110 | let exeFile = takeDirectory moduleFile "a.out" 111 | callProcess "clang" ["-lgc", "-o", exeFile, linkedLL] 112 | 113 | data DumpFlags 114 | = DumpFlags 115 | { dfDumpParsed :: !Bool 116 | , dfDumpTypeChecked :: !Bool 117 | , dfDumpCore :: !Bool 118 | , dfDumpCoreLifted :: !Bool 119 | , dfDumpANF :: !Bool 120 | , dfDumpLLVMPretty :: !Bool 121 | } deriving (Show, Eq) 122 | 123 | data CompiledModule 124 | = CompiledModule 125 | { compiledModuleName :: !ModuleName 126 | , compiledModuleEnvironment :: !Environment 127 | , compiledModuleLLVM :: !FilePath 128 | } deriving (Show, Eq) 129 | -------------------------------------------------------------------------------- /library/Amy/Core.hs: -------------------------------------------------------------------------------- 1 | module Amy.Core 2 | ( module X 3 | ) where 4 | 5 | import Amy.Core.AST as X 6 | import Amy.Core.Desugar as X 7 | import Amy.Core.LambdaLift as X 8 | import Amy.Core.Pretty as X 9 | -------------------------------------------------------------------------------- /library/Amy/Core/Desugar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Amy.Core.Desugar 4 | ( desugarModule 5 | ) where 6 | 7 | import Data.List (foldl') 8 | import Data.List.NonEmpty (NonEmpty(..)) 9 | import qualified Data.List.NonEmpty as NE 10 | import qualified Data.Map.Strict as Map 11 | import Data.Maybe (maybeToList) 12 | 13 | import Amy.Core.AST as C 14 | import Amy.Core.Monad 15 | import Amy.Core.PatternCompiler as PC 16 | import Amy.Environment 17 | import Amy.Prim 18 | import Amy.Syntax.AST as S 19 | 20 | desugarModule :: Environment -> S.Module -> C.Module 21 | desugarModule env (S.Module _ typeDeclarations externs bindings) = 22 | runDesugar env $ do 23 | let 24 | typeDeclarations' = desugarTypeDeclaration <$> typeDeclarations 25 | externs' = desugarExtern <$> externs 26 | bindings' <- traverse (traverse desugarBinding) bindings 27 | pure $ C.Module bindings' externs' typeDeclarations' 28 | 29 | desugarExtern :: S.Extern -> C.Extern 30 | desugarExtern (S.Extern (Located _ ident) ty) = C.Extern ident (desugarType ty) 31 | 32 | desugarTypeDeclaration :: TypeDeclaration -> TypeDeclaration 33 | desugarTypeDeclaration (TypeDeclaration tyName cons) = 34 | TypeDeclaration tyName (desugarDataConDefinition <$> cons) 35 | 36 | desugarDataConDefinition :: DataConDefinition -> DataConDefinition 37 | desugarDataConDefinition (DataConDefinition conName mTyArg) = 38 | DataConDefinition 39 | { dataConDefinitionName = conName 40 | , dataConDefinitionArgument = desugarType <$> mTyArg 41 | } 42 | 43 | desugarBinding :: S.Binding -> Desugar C.Binding 44 | desugarBinding (S.Binding (Located _ ident) ty args retTy body) = 45 | C.Binding 46 | ident 47 | (desugarType ty) 48 | (desugarTypedIdent . fmap locatedValue <$> args) 49 | (desugarType retTy) 50 | <$> desugarExpr body 51 | 52 | desugarExpr :: S.Expr -> Desugar C.Expr 53 | desugarExpr (S.ELit (Located _ lit)) = pure $ C.ELit lit 54 | desugarExpr (S.ERecord _ rows) = 55 | C.ERecord 56 | . Map.mapKeys locatedValue 57 | <$> traverse (\(Typed ty expr) -> Typed (desugarType ty) <$> desugarExpr expr) rows 58 | desugarExpr (S.ERecordSelect expr (Located _ label) ty) = do 59 | expr' <- desugarExpr expr 60 | let ty' = desugarType ty 61 | pure $ C.ERecordSelect expr' label ty' 62 | desugarExpr (S.EVar ident) = pure $ C.EVar $ desugarTypedIdent $ locatedValue <$> ident 63 | desugarExpr (S.ECon (Typed ty (Located _ con))) = pure $ C.ECon $ Typed (desugarType ty) con 64 | desugarExpr (S.ECase (S.Case scrutinee matches _x)) = do 65 | -- Desugar the case expression 66 | scrutinee' <- desugarExpr scrutinee 67 | let scrutineeTy = desugarType $ S.expressionType scrutinee 68 | scrutineeIdent <- freshIdent "c" 69 | equations <- NE.toList <$> traverse matchToEquation matches 70 | caseExpr <- PC.match [Typed scrutineeTy scrutineeIdent] equations 71 | caseExpr' <- restoreCaseExpr caseExpr 72 | pure $ 73 | case caseExpr' of 74 | (C.ECase case') -> C.ECase $ case' { C.caseScrutinee = scrutinee' } 75 | e -> 76 | -- Bind the scrutinee to a variable 77 | let 78 | scrutineeBinding = 79 | C.Binding 80 | { C.bindingName = scrutineeIdent 81 | , C.bindingType = desugarType $ S.expressionType scrutinee 82 | , C.bindingArgs = [] 83 | , C.bindingReturnType = desugarType $ S.expressionType scrutinee 84 | , C.bindingBody = scrutinee' 85 | } 86 | in C.ELet $ C.Let (scrutineeBinding :| []) e 87 | desugarExpr (S.ELam (S.Lambda args body _ ty)) = do 88 | let args' = desugarTypedIdent . fmap locatedValue <$> args 89 | body' <- desugarExpr body 90 | let ty' = desugarType ty 91 | pure $ C.ELam $ C.Lambda args' body' ty' 92 | desugarExpr (S.EIf (S.If pred' then' else' _)) = 93 | let 94 | boolTyCon' = TyCon (notLocated boolTyCon) 95 | loc = mkSourceSpan "" 1 1 1 1 96 | mkBoolPatCons cons = S.PatCons (Located loc cons) Nothing boolTyCon' 97 | matches = 98 | NE.fromList 99 | [ S.Match (S.PCons $ mkBoolPatCons trueDataCon) then' 100 | , S.Match (S.PCons $ mkBoolPatCons falseDataCon) else' 101 | ] 102 | in desugarExpr (S.ECase (S.Case pred' matches loc)) 103 | desugarExpr (S.ELet (S.Let bindings body _)) = do 104 | bindings' <- traverse (traverse desugarBinding) bindings 105 | body' <- desugarExpr body 106 | -- N.B. Core only allows on binding group per let expression. 107 | pure $ foldl' (\bod binds -> C.ELet (C.Let binds bod)) body' (reverse bindings') 108 | desugarExpr (S.EApp (S.App func arg ty)) = do 109 | func' <- desugarExpr func 110 | arg' <- desugarExpr arg 111 | pure $ C.EApp (C.App func' arg' (desugarType ty)) 112 | desugarExpr (S.EParens expr) = C.EParens <$> desugarExpr expr 113 | 114 | desugarTypedIdent :: Typed IdentName -> Typed IdentName 115 | desugarTypedIdent (Typed ty ident) = Typed (desugarType ty) ident 116 | 117 | desugarType :: Type -> Type 118 | desugarType = removeTyExistVar . blowUpOnTyUnknown 119 | 120 | -- 121 | -- Case Expressions 122 | -- 123 | 124 | matchToEquation :: S.Match -> Desugar PC.Equation 125 | matchToEquation (S.Match pat body) = do 126 | pat' <- convertPattern pat 127 | body' <- desugarExpr body 128 | pure ([pat'], body') 129 | 130 | convertPattern :: S.Pattern -> Desugar PC.InputPattern 131 | convertPattern (S.PLit (Located _ lit)) = pure $ PC.PCon (PC.ConLit lit) [] 132 | convertPattern (S.PVar ident) = pure $ PC.PVar $ desugarTypedIdent (locatedValue <$> ident) 133 | convertPattern (S.PCons (S.PatCons (Located _ con) mArg _)) = do 134 | tyDecl <- lookupDataConType con 135 | argPats <- traverse convertPattern $ maybeToList mArg 136 | let 137 | argTys = maybeToList $ desugarType . patternType <$> mArg 138 | span' = length $ typeDeclarationConstructors tyDecl 139 | pure $ PC.PCon (PC.Con con argTys span') argPats 140 | convertPattern (S.PParens pat) = convertPattern pat 141 | 142 | restoreCaseExpr :: PC.CaseExpr -> Desugar C.Expr 143 | restoreCaseExpr (PC.CaseExpr scrutinee clauses mDefault) = do 144 | let 145 | scrutinee' = C.EVar scrutinee 146 | clauses' <- traverse restoreClause clauses 147 | defaultClause <- traverse restoreCaseExpr mDefault 148 | pure $ C.ECase $ C.Case scrutinee' scrutinee clauses' defaultClause 149 | restoreCaseExpr (PC.Expr expr) = pure expr 150 | restoreCaseExpr Error = error "Found inexhaustive pattern match" 151 | 152 | restoreClause :: PC.Clause -> Desugar C.Match 153 | restoreClause (PC.Clause (PC.ConLit lit) [] caseExpr) = 154 | C.Match (C.PLit lit) <$> restoreCaseExpr caseExpr 155 | restoreClause clause@(PC.Clause (PC.ConLit _) _ _) = 156 | error $ "Encountered literal clause with arguments! " ++ show clause 157 | restoreClause (PC.Clause (PC.Con con _ _) args caseExpr) = do 158 | tyDecl <- lookupDataConType con 159 | let 160 | patTy = TyCon $ fromLocated $ tyConDefinitionName $ typeDeclarationTypeName tyDecl 161 | arg = 162 | case args of 163 | [] -> Nothing 164 | [x] -> Just x 165 | xs -> error $ "Encountered too many arguments! " ++ show xs 166 | pat = C.PCons $ C.PatCons con arg patTy 167 | expr <- restoreCaseExpr caseExpr 168 | pure $ C.Match pat expr 169 | -------------------------------------------------------------------------------- /library/Amy/Core/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Amy.Core.Monad 4 | ( Desugar 5 | , runDesugar 6 | , freshId 7 | , freshIdent 8 | , lookupDataConType 9 | ) where 10 | 11 | import Control.Monad.Reader 12 | import Control.Monad.State.Strict 13 | import qualified Data.Map.Strict as Map 14 | import Data.Maybe (fromMaybe) 15 | import Data.Text (Text, pack) 16 | 17 | import Amy.Core.AST as C 18 | import Amy.Environment 19 | 20 | newtype Desugar a = Desugar (ReaderT Environment (State Int) a) 21 | deriving (Functor, Applicative, Monad, MonadReader Environment, MonadState Int) 22 | 23 | runDesugar :: Environment -> Desugar a -> a 24 | runDesugar env (Desugar action) = evalState (runReaderT action env) 0 25 | 26 | freshId :: Desugar Int 27 | freshId = do 28 | modify' (+ 1) 29 | get 30 | 31 | freshIdent :: Text -> Desugar IdentName 32 | freshIdent t = do 33 | id' <- freshId 34 | pure $ IdentName (t <> pack (show id')) 35 | 36 | lookupDataConType :: DataConName -> Desugar TypeDeclaration 37 | lookupDataConType con = 38 | asks 39 | $ dataConInfoTypeDeclaration 40 | . fromMaybe (error $ "No type definition for " ++ show con) 41 | . Map.lookup con 42 | . environmentDataConInfos 43 | -------------------------------------------------------------------------------- /library/Amy/Core/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Amy.Core.Pretty 4 | ( prettyModule 5 | , prettyExpr 6 | ) where 7 | 8 | import Data.Foldable (toList) 9 | import qualified Data.Map.Strict as Map 10 | 11 | import Amy.Core.AST 12 | import Amy.Literal 13 | import Amy.Pretty 14 | 15 | prettyModule :: Module -> Doc ann 16 | prettyModule (Module bindings externs typeDeclarations) = 17 | vcatTwoHardLines 18 | $ (prettyExtern' <$> externs) 19 | ++ (prettyTypeDeclaration' <$> typeDeclarations) 20 | ++ (prettyBinding' <$> concat (toList <$> bindings)) 21 | 22 | prettyExtern' :: Extern -> Doc ann 23 | prettyExtern' (Extern name ty) = 24 | prettyExtern (prettyIdent name) (prettyType ty) 25 | 26 | prettyTypeDeclaration' :: TypeDeclaration -> Doc ann 27 | prettyTypeDeclaration' (TypeDeclaration tyName cons) = 28 | prettyTypeDeclaration (prettyTyConDefinition tyName) (prettyConstructor <$> cons) 29 | where 30 | prettyConstructor (DataConDefinition (Located _ conName) mArg) = 31 | prettyDataConstructor (prettyDataConName conName) (prettyType <$> mArg) 32 | 33 | prettyTyConDefinition :: TyConDefinition -> Doc ann 34 | prettyTyConDefinition (TyConDefinition (Located _ name) args) = prettyTyConName name <> args' 35 | where 36 | args' = if null args then mempty else space <> sep (prettyTyVarName . locatedValue <$> args) 37 | 38 | prettyBinding' :: Binding -> Doc ann 39 | prettyBinding' (Binding ident ty args _ body) = 40 | prettyBindingType' ident ty <> 41 | hardline <> 42 | prettyBinding (prettyIdent ident) (prettyTypedIdent <$> args) (prettyExpr body) 43 | 44 | prettyBindingType' :: IdentName -> Type -> Doc ann 45 | prettyBindingType' ident ty = prettyBindingType (prettyIdent ident) (prettyType ty) 46 | 47 | prettyTypedIdent :: Typed IdentName -> Doc ann 48 | prettyTypedIdent (Typed ty ident) = parens $ prettyIdent ident <+> "::" <+> prettyType ty 49 | 50 | prettyExpr :: Expr -> Doc ann 51 | prettyExpr (ELit lit) = pretty $ showLiteral lit 52 | prettyExpr (ERecord rows) = bracketed $ uncurry prettyRow <$> Map.toList (typedValue <$> rows) 53 | prettyExpr (ERecordSelect expr field _) = prettyExpr expr <> "." <> prettyRowLabel field 54 | prettyExpr (EVar (Typed _ ident)) = prettyIdent ident 55 | prettyExpr (ECon (Typed _ con)) = prettyDataConName con 56 | prettyExpr (ECase (Case scrutinee bind matches mDefault)) = 57 | prettyCase 58 | (prettyExpr scrutinee) 59 | (Just $ prettyTypedIdent bind) 60 | (toList (mkMatch <$> matches) ++ defaultMatch) 61 | where 62 | mkMatch (Match pat body) = (prettyPattern pat, prettyExpr body) 63 | defaultMatch = 64 | case mDefault of 65 | Nothing -> [] 66 | Just def -> [("__DEFAULT", prettyExpr def)] 67 | prettyExpr (ELet (Let bindings body)) = 68 | prettyLet (prettyBinding' <$> toList bindings) (prettyExpr body) 69 | prettyExpr (ELam (Lambda args body _)) = prettyLambda (prettyTypedIdent <$> toList args) (prettyExpr body) 70 | prettyExpr (EApp (App f arg _)) = prettyExpr f <+> prettyExpr arg 71 | prettyExpr (EParens expr) = parens $ prettyExpr expr 72 | 73 | prettyRow :: RowLabel -> Expr -> Doc ann 74 | prettyRow label expr = prettyRowLabel label <> ":" <+> prettyExpr expr 75 | 76 | prettyPattern :: Pattern -> Doc ann 77 | prettyPattern (PLit lit) = pretty $ showLiteral lit 78 | prettyPattern (PCons (PatCons con mArg _)) = 79 | prettyDataConName con 80 | <> maybe mempty (\(Typed ty arg) -> space <> parens (prettyIdent arg <+> "::" <+> prettyType ty)) mArg 81 | -------------------------------------------------------------------------------- /library/Amy/Environment.hs: -------------------------------------------------------------------------------- 1 | module Amy.Environment 2 | ( Environment(..) 3 | , emptyEnvironment 4 | , mergeEnvironments 5 | , primEnvironment 6 | , DataConInfo(..) 7 | , dataConInfos 8 | ) where 9 | 10 | import Data.Bifunctor (first) 11 | import qualified Data.List.NonEmpty as NE 12 | import Data.Map.Strict (Map) 13 | import qualified Data.Map.Strict as Map 14 | import Data.Maybe (maybeToList) 15 | 16 | import qualified Amy.ANF.AST as ANF 17 | import Amy.ANF.TypeRep 18 | import Amy.Kind 19 | import Amy.Names 20 | import Amy.Prim 21 | import Amy.Syntax.AST 22 | 23 | data Environment 24 | = Environment 25 | { environmentIdentTypes :: !(Map IdentName Type) 26 | , environmentDataConInfos :: !(Map DataConName DataConInfo) 27 | , environmentTyConKinds :: !(Map TyConName Kind) 28 | , environmentANFTypeReps :: !(Map TyConName ANF.Type) 29 | , environmentANFFunctionTypes :: !(Map IdentName ([ANF.Type], ANF.Type)) 30 | } deriving (Show, Eq) 31 | 32 | emptyEnvironment :: Environment 33 | emptyEnvironment = 34 | Environment 35 | { environmentIdentTypes = Map.empty 36 | , environmentDataConInfos = Map.empty 37 | , environmentTyConKinds = Map.empty 38 | , environmentANFTypeReps = Map.empty 39 | , environmentANFFunctionTypes = Map.empty 40 | } 41 | 42 | mergeEnvironments :: Environment -> Environment -> Environment 43 | mergeEnvironments env1 env2 = 44 | Environment 45 | { environmentIdentTypes = environmentIdentTypes env1 <> environmentIdentTypes env2 46 | , environmentDataConInfos = environmentDataConInfos env1 <> environmentDataConInfos env2 47 | , environmentTyConKinds = environmentTyConKinds env1 <> environmentTyConKinds env2 48 | , environmentANFTypeReps = environmentANFTypeReps env1 <> environmentANFTypeReps env2 49 | , environmentANFFunctionTypes = environmentANFFunctionTypes env1 <> environmentANFFunctionTypes env2 50 | } 51 | 52 | primEnvironment :: Environment 53 | primEnvironment = 54 | let 55 | primFuncTypes = 56 | (\(PrimitiveFunction _ name ty) -> (name, foldTyFun $ TyCon . notLocated <$> ty)) 57 | <$> allPrimitiveFunctions 58 | primDataConInfos = concatMap dataConInfos (fst <$> allPrimTypeDefinitions) 59 | primTyConKinds = 60 | (\(decl, kind) -> (locatedValue . tyConDefinitionName . typeDeclarationTypeName $ decl, kind)) 61 | <$> allPrimTypeDefinitions 62 | primTypeReps = 63 | (\t -> (locatedValue . tyConDefinitionName . typeDeclarationTypeName $ t, typeRep t)) 64 | . fst 65 | <$> allPrimTypeDefinitions 66 | in 67 | Environment 68 | { environmentIdentTypes = Map.fromList primFuncTypes 69 | , environmentDataConInfos = Map.fromList $ first locatedValue <$> primDataConInfos 70 | , environmentTyConKinds = Map.fromList primTyConKinds 71 | , environmentANFTypeReps = Map.fromList primTypeReps 72 | , environmentANFFunctionTypes = Map.empty 73 | } 74 | 75 | data DataConInfo 76 | = DataConInfo 77 | { dataConInfoTypeDeclaration :: !TypeDeclaration 78 | , dataConInfoDataConDefinition :: !DataConDefinition 79 | , dataConInfoType :: !Type 80 | , dataConInfoANFType :: !ANF.Type 81 | , dataConInfoConstructorIndex :: !Int 82 | } deriving (Show, Eq) 83 | 84 | dataConInfos :: TypeDeclaration -> [(Located DataConName, DataConInfo)] 85 | dataConInfos tyDecl@(TypeDeclaration (TyConDefinition tyConName tyVars) dataConDefs) = mkDataConPair <$> zip [0..] dataConDefs 86 | where 87 | mkDataConPair (index, dataDef@(DataConDefinition name mTyArg)) = 88 | let 89 | tyVars' = TyVar . fromLocated <$> tyVars 90 | tyApp = foldTyApp $ NE.fromList $ TyCon (fromLocated tyConName) : tyVars' 91 | ty = foldTyFun (NE.fromList $ maybeToList mTyArg ++ [tyApp]) 92 | tyForall = maybe ty (\varsNE -> TyForall varsNE ty) (NE.nonEmpty $ fromLocated <$> tyVars) 93 | anfTy = typeRep tyDecl 94 | in (name, DataConInfo tyDecl dataDef tyForall anfTy index) 95 | -------------------------------------------------------------------------------- /library/Amy/Errors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | User facing errors. 5 | 6 | module Amy.Errors 7 | ( Error(..) 8 | , showError 9 | , ErrorMessage(..) 10 | ) where 11 | 12 | import Data.Text.Prettyprint.Doc.Render.String (renderString) 13 | import Text.Megaparsec.Pos 14 | 15 | import Amy.Kind 16 | import Amy.Pretty 17 | import Amy.Syntax.AST 18 | 19 | data Error 20 | = Error 21 | { errorMessage :: !ErrorMessage 22 | , errorLocation :: !SourceSpan 23 | } deriving (Show, Eq) 24 | 25 | showError :: Error -> String 26 | showError (Error message (SourceSpan start _)) = 27 | renderString . layoutPretty defaultLayoutOptions $ 28 | pretty (sourcePosPretty start) <> ":" <> groupOrHang (prettyErrorMessage message) 29 | 30 | data ErrorMessage 31 | = UnknownVariable !IdentName 32 | | UnknownDataCon !DataConName 33 | | UnknownTypeVariable !TyVarName 34 | | UnknownTypeConstructor !TyConName 35 | | VariableShadowed !IdentName 36 | | DuplicateDataConstructor !DataConName 37 | | DuplicateTypeConstructor !TyConName 38 | | UnificationFail !Type !Type 39 | | KindUnificationFail !Kind ! Kind 40 | | InfiniteType !TyExistVarName !Type 41 | | InfiniteKind !Int !Kind 42 | | TooManyBindingArguments !Int !Int 43 | deriving (Show, Eq) 44 | 45 | prettyErrorMessage :: ErrorMessage -> Doc ann 46 | prettyErrorMessage = \case 47 | UnknownVariable ident -> "Unknown variable:" <+> prettyIdent ident 48 | UnknownDataCon con -> "Unknown data constructor:" <+> prettyDataConName con 49 | UnknownTypeVariable tyvar -> "Unknown type variable:" <+> prettyTyVarName tyvar 50 | UnknownTypeConstructor tycon -> "Unknown type constructor:" <+> prettyTyConName tycon 51 | VariableShadowed x -> "Variable shadowed:" <+> prettyIdent x 52 | DuplicateDataConstructor con -> "Data constructor already exists:" <+> prettyDataConName con 53 | DuplicateTypeConstructor con -> "Type constructor already exists:" <+> prettyTyConName con 54 | UnificationFail t1 t2 -> 55 | "Could not match type" <> hardline <> indent 2 (prettyType t1) <> hardline <> "with type" <> hardline <> indent 2 (prettyType t2) 56 | KindUnificationFail k1 k2 -> 57 | "Could not match kind" <> hardline <> indent 2 (prettyKind k1) <> hardline <> "with kind" <> hardline <> indent 2 (prettyKind k2) 58 | InfiniteType _ t -> "Cannot infer infinite type:" <> prettyType t 59 | InfiniteKind _ k -> "Cannot infer infinite kind:" <> prettyKind k 60 | TooManyBindingArguments expected actual -> 61 | "Too many arguments to binding. Declared type implies a maximum of" <+> pretty expected <+> 62 | "arguments, but found" <+> pretty actual <+> "arguments." 63 | -------------------------------------------------------------------------------- /library/Amy/Kind.hs: -------------------------------------------------------------------------------- 1 | module Amy.Kind 2 | ( Kind(..) 3 | ) where 4 | 5 | data Kind 6 | = KStar 7 | | KUnknown !Int 8 | | KRow 9 | | KFun !Kind !Kind 10 | deriving (Show, Eq, Ord) 11 | 12 | infixr 0 `KFun` 13 | -------------------------------------------------------------------------------- /library/Amy/Literal.hs: -------------------------------------------------------------------------------- 1 | -- | Common AST components shared across various actual ASTs. 2 | 3 | module Amy.Literal 4 | ( Literal(..) 5 | , showLiteral 6 | ) where 7 | 8 | import Data.Text (Text) 9 | 10 | -- | A 'Literal' is any literal from the source code. This type is used in many 11 | -- ASTs since there is no need for renaming or annotating types to a literal. 12 | data Literal 13 | = LiteralInt !Int 14 | | LiteralDouble !Double 15 | | LiteralText !Text 16 | deriving (Show, Eq, Ord) 17 | 18 | showLiteral :: Literal -> String 19 | showLiteral (LiteralInt x) = show x 20 | showLiteral (LiteralDouble x) = show x 21 | showLiteral (LiteralText x) = show x 22 | -------------------------------------------------------------------------------- /library/Amy/Names.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Amy.Names 4 | ( IdentName(..) 5 | , DataConName(..) 6 | , TyConName(..) 7 | , TyVarName(..) 8 | , TyExistVarName(..) 9 | , RowLabel(..) 10 | , ModuleName(..) 11 | ) where 12 | 13 | import Data.Text (Text) 14 | import GHC.Exts (IsString) 15 | 16 | newtype IdentName = IdentName { unIdentName :: Text } 17 | deriving (Show, Eq, Ord, IsString) 18 | 19 | newtype DataConName = DataConName { unDataConName :: Text } 20 | deriving (Show, Eq, Ord, IsString) 21 | 22 | newtype TyConName = TyConName { unTyConName :: Text } 23 | deriving (Show, Eq, Ord, IsString) 24 | 25 | newtype TyVarName = TyVarName { unTyVarName :: Text } 26 | deriving (Show, Eq, Ord, IsString) 27 | 28 | newtype TyExistVarName = TyExistVarName { unTyExistVarName :: Int } 29 | deriving (Show, Eq, Ord) 30 | 31 | newtype RowLabel = RowLabel { unRowLabel :: Text } 32 | deriving (Show, Eq, Ord, IsString) 33 | 34 | newtype ModuleName = ModuleName { unModuleName :: Text } 35 | deriving (Show, Eq, Ord, IsString) 36 | -------------------------------------------------------------------------------- /library/Amy/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Helpers for pretty printing. 4 | 5 | module Amy.Pretty 6 | ( module X 7 | 8 | -- Helpers 9 | , parensIf 10 | , vcatHardLines 11 | , vcatTwoHardLines 12 | , groupOrHang 13 | , list 14 | , bracketed 15 | 16 | -- Names 17 | , prettyIdent 18 | , prettyDataConName 19 | , prettyTyConName 20 | , prettyTyVarName 21 | , prettyTyExistVarName 22 | , prettyRowLabel 23 | 24 | -- Kinds 25 | , prettyKind 26 | 27 | -- Types 28 | , prettyType 29 | 30 | -- General AST 31 | , prettyIf 32 | , prettyCase 33 | , prettyLet 34 | , prettyLetVal 35 | , prettyBinding 36 | , prettyLambda 37 | , prettyBindingType 38 | , prettyExtern 39 | , prettyTypeDeclaration 40 | , prettyDataConstructor 41 | , prettyTyRecord 42 | ) where 43 | 44 | import Data.Foldable (toList) 45 | import Data.Maybe (fromMaybe) 46 | import Data.Text.Prettyprint.Doc as X hiding (list) 47 | import qualified Data.Map.Strict as Map 48 | 49 | import Amy.Kind 50 | import Amy.Names 51 | import Amy.Syntax.Located 52 | import Amy.Type 53 | 54 | -- 55 | -- General helpers 56 | -- 57 | 58 | parensIf :: Bool -> Doc ann -> Doc ann 59 | parensIf True = parens 60 | parensIf False = id 61 | 62 | vcatHardLines :: [Doc ann] -> Doc ann 63 | vcatHardLines = concatWith (\x y -> x <> hardline <> y) 64 | 65 | vcatTwoHardLines :: [Doc ann] -> Doc ann 66 | vcatTwoHardLines = concatWith (\x y -> x <> hardline <> hardline <> y) 67 | 68 | groupOrHang :: Doc ann -> Doc ann 69 | groupOrHang doc = 70 | group ( 71 | flatAlt 72 | (line <> indent 2 doc) 73 | (space <> doc) 74 | ) 75 | 76 | list :: [Doc ann] -> Doc ann 77 | list = 78 | group 79 | . encloseSep 80 | (flatAlt "[ " "[") 81 | (flatAlt "\n]" "]") 82 | ", " 83 | 84 | bracketed :: [Doc ann] -> Doc ann 85 | bracketed = 86 | group 87 | . encloseSep 88 | "{ " 89 | (flatAlt "\n}" " }") 90 | ", " 91 | 92 | punctuatePrefix 93 | :: Doc ann -- ^ Punctuation, e.g. 'comma' 94 | -> [Doc ann] 95 | -> [Doc ann] 96 | punctuatePrefix _ [] = [] 97 | punctuatePrefix p (d:ds) = d : ((\d' -> p <> d') <$> ds) 98 | 99 | -- 100 | -- Names 101 | -- 102 | prettyIdent :: IdentName -> Doc ann 103 | prettyIdent = pretty . unIdentName 104 | 105 | prettyDataConName :: DataConName -> Doc ann 106 | prettyDataConName = pretty . unDataConName 107 | 108 | prettyTyConName :: TyConName -> Doc ann 109 | prettyTyConName = pretty . unTyConName 110 | 111 | prettyTyVarName :: TyVarName -> Doc ann 112 | prettyTyVarName = pretty . unTyVarName 113 | 114 | prettyTyExistVarName :: TyExistVarName -> Doc ann 115 | prettyTyExistVarName = ("$t" <>) . pretty . unTyExistVarName 116 | 117 | prettyRowLabel :: RowLabel -> Doc ann 118 | prettyRowLabel = pretty . unRowLabel 119 | 120 | -- 121 | -- Kinds 122 | -- 123 | 124 | prettyKind :: Kind -> Doc ann 125 | prettyKind KStar = "*" 126 | prettyKind (KUnknown i) = "k" <> pretty i 127 | prettyKind KRow = "#row" 128 | prettyKind (KFun k1 k2) = parensIf (isKFun k1) (prettyKind k1) <+> "->" <+> prettyKind k2 129 | 130 | isKFun :: Kind -> Bool 131 | isKFun KFun{} = True 132 | isKFun _ = False 133 | 134 | -- 135 | -- Types 136 | -- 137 | 138 | prettyType :: Type -> Doc ann 139 | prettyType TyUnknown = "TyUnknown" 140 | prettyType (TyFun ty1 ty2) = parensIf (isTyFun ty1) (prettyType ty1) <+> "->" <+> prettyType ty2 141 | prettyType (TyCon (MaybeLocated _ con)) = prettyTyConName con 142 | prettyType (TyExistVar var) = prettyTyExistVarName var 143 | prettyType (TyVar (MaybeLocated _ var)) = prettyTyVarName var 144 | prettyType (TyRecord rows mVar) = prettyTyRecord (uncurry prettyTyRow <$> Map.toList rows) (prettyType <$> mVar) 145 | where 146 | prettyTyRow (MaybeLocated _ label) ty = prettyRowLabel label <+> "::" <+> prettyType ty 147 | prettyType (TyApp f arg) = prettyType f <+> parensIf (isTyApp arg) (prettyType arg) 148 | prettyType (TyForall vars ty) = "forall" <+> hcat (punctuate space $ prettyTyVarName . maybeLocatedValue <$> toList vars) <> "." <+> prettyType ty 149 | 150 | isTyApp :: Type -> Bool 151 | isTyApp TyApp{} = True 152 | isTyApp TyFun{} = True 153 | isTyApp _ = False 154 | 155 | isTyFun :: Type -> Bool 156 | isTyFun TyFun{} = True 157 | isTyFun _ = False 158 | 159 | -- 160 | -- General AST Helpers 161 | -- 162 | 163 | prettyIf :: Doc ann -> Doc ann -> Doc ann -> Doc ann 164 | prettyIf pred' then' else' = 165 | align $ 166 | vsep 167 | [ "if" <> groupOrHang pred' 168 | , "then" <> groupOrHang then' 169 | , "else" <> groupOrHang else' 170 | ] 171 | 172 | prettyCase :: Doc ann -> Maybe (Doc ann) -> [(Doc ann, Doc ann)] -> Doc ann 173 | prettyCase scrutinee mBinder matches = 174 | "case" <+> scrutinee <+> "of" <> maybe mempty (space <>) mBinder <> 175 | groupOrHang (vcatHardLines matches') 176 | where 177 | prettyMatch pat body = pat <+> "->" <> groupOrHang body 178 | matches' = uncurry prettyMatch <$> matches 179 | 180 | prettyLet :: [Doc ann] -> Doc ann -> Doc ann 181 | prettyLet = prettyLet' Nothing 182 | 183 | prettyLetVal :: [Doc ann] -> Doc ann -> Doc ann 184 | prettyLetVal = prettyLet' (Just "val") 185 | 186 | prettyLet' :: Maybe (Doc ann) -> [Doc ann] -> Doc ann -> Doc ann 187 | prettyLet' mSuffix bindings body = 188 | "let" <> fromMaybe mempty mSuffix <> 189 | line <> 190 | indent 2 (vcatHardLines bindings) <> 191 | line <> 192 | indent (-2) "in" <> 193 | groupOrHang body 194 | 195 | prettyBinding :: Doc ann -> [Doc ann] -> Doc ann -> Doc ann 196 | prettyBinding name args body = 197 | sep (name : args) <+> "=" <> groupOrHang body 198 | 199 | prettyLambda :: [Doc ann] -> Doc ann -> Doc ann 200 | prettyLambda args body = 201 | "\\" <> sep args <+> "->" <> groupOrHang body 202 | 203 | prettyBindingType :: Doc ann -> Doc ann -> Doc ann 204 | prettyBindingType name ty = name <+> "::" <> groupOrHang ty 205 | 206 | prettyExtern :: Doc ann -> Doc ann -> Doc ann 207 | prettyExtern name ty = "extern" <+> prettyBindingType name ty 208 | 209 | prettyTypeDeclaration :: Doc ann -> [Doc ann] -> Doc ann 210 | prettyTypeDeclaration tyName dataCons = 211 | tyName <> groupOrHang (encloseSep "= " mempty (flatAlt "| " " | ") dataCons) 212 | 213 | prettyDataConstructor :: Doc ann -> Maybe (Doc ann) -> Doc ann 214 | prettyDataConstructor tyConName mArg = tyConName <> maybe mempty (space <>) mArg 215 | 216 | prettyTyRecord :: [Doc ann] -> Maybe (Doc ann) -> Doc ann 217 | prettyTyRecord fields mVar = 218 | group $ "{" <+> cat fieldsWithVar <> flatAlt "\n}" " }" 219 | where 220 | fieldsWithVar = punctuatePrefix ", " fields ++ maybe [] (\v -> [flatAlt "| " " | " <> v]) mVar 221 | -------------------------------------------------------------------------------- /library/Amy/Prim.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | Encode primitive types operations for the compiler. Primitive types are 5 | -- types that map directly to raw values on the stack, like machine integers 6 | -- and doubles. Primitive operations are functions that are generated with a 7 | -- machine instruction, and the code generator needs to know about them to 8 | -- generate the machine code. Because of this, these types/operations need to 9 | -- be included in the compiler and not in a standard library. 10 | 11 | module Amy.Prim 12 | ( -- * Types 13 | allPrimTypeDefinitions 14 | , literalType 15 | 16 | , intTypeDefinition 17 | , intTyCon 18 | , doubleTypeDefinition 19 | , doubleTyCon 20 | , textTypeDefinition 21 | , textTyCon 22 | , boolTypeDefinition 23 | , boolTyCon 24 | , falseDataCon 25 | , trueDataCon 26 | 27 | -- * Functions 28 | , PrimitiveFunctionName(..) 29 | , PrimitiveFunction(..) 30 | , allPrimitiveFunctions 31 | , primitiveFunctionsByName 32 | ) where 33 | 34 | import Data.List.NonEmpty (NonEmpty) 35 | import Data.Map.Strict (Map) 36 | import qualified Data.Map.Strict as Map 37 | import Data.Text (Text) 38 | import Text.Megaparsec.Pos 39 | 40 | import Amy.Literal 41 | import Amy.Kind 42 | import Amy.Names 43 | import Amy.Type 44 | import Amy.Syntax.Located 45 | 46 | -- 47 | -- Wired-in Type Definitions 48 | -- 49 | 50 | mkPrimTypeDef :: TyConName -> [DataConName] -> TypeDeclaration 51 | mkPrimTypeDef tyConName dataConNames = 52 | let 53 | pos = SourcePos "" (mkPos 1) (mkPos 1) 54 | span' = SourceSpan pos pos 55 | tyConDef = TyConDefinition (Located span' tyConName) [] 56 | mkDataConDef con = DataConDefinition (Located span' con) Nothing 57 | dataCons = mkDataConDef <$> dataConNames 58 | in TypeDeclaration tyConDef dataCons 59 | 60 | -- Int 61 | intTypeDefinition :: TypeDeclaration 62 | intTypeDefinition = mkPrimTypeDef intTyCon [] 63 | 64 | intTyCon :: TyConName 65 | intTyCon = "Int" 66 | 67 | -- Double 68 | doubleTypeDefinition :: TypeDeclaration 69 | doubleTypeDefinition = mkPrimTypeDef doubleTyCon [] 70 | 71 | doubleTyCon :: TyConName 72 | doubleTyCon = "Double" 73 | 74 | -- Text 75 | textTypeDefinition :: TypeDeclaration 76 | textTypeDefinition = mkPrimTypeDef textTyCon [] 77 | 78 | textTyCon :: TyConName 79 | textTyCon = "Text" 80 | 81 | -- Bool 82 | 83 | boolTypeDefinition :: TypeDeclaration 84 | boolTypeDefinition = mkPrimTypeDef boolTyCon [falseDataCon, trueDataCon] 85 | 86 | boolTyCon :: TyConName 87 | boolTyCon = "Bool" 88 | 89 | falseDataCon, trueDataCon :: DataConName 90 | falseDataCon = "False" 91 | trueDataCon = "True" 92 | 93 | allPrimTypeDefinitions :: [(TypeDeclaration, Kind)] 94 | allPrimTypeDefinitions = 95 | [ (intTypeDefinition, KStar) 96 | , (doubleTypeDefinition, KStar) 97 | , (textTypeDefinition, KStar) 98 | , (boolTypeDefinition, KStar) 99 | ] 100 | 101 | literalType :: Literal -> Type 102 | literalType = TyCon . notLocated . literalTyCon 103 | 104 | literalTyCon :: Literal -> TyConName 105 | literalTyCon (LiteralInt _) = intTyCon 106 | literalTyCon (LiteralDouble _) = doubleTyCon 107 | literalTyCon (LiteralText _) = textTyCon 108 | 109 | -- 110 | -- Primitive Functions 111 | -- 112 | 113 | data PrimitiveFunctionName 114 | -- Int 115 | = PrimIAdd 116 | | PrimISub 117 | | PrimIEquals 118 | | PrimIGreaterThan 119 | | PrimILessThan 120 | 121 | -- Double 122 | | PrimDAdd 123 | | PrimDSub 124 | 125 | -- Conversion 126 | | PrimIntToDouble 127 | | PrimDoubleToInt 128 | deriving (Show, Eq, Enum, Bounded, Ord) 129 | 130 | allPrimitiveFunctionNames :: [PrimitiveFunctionName] 131 | allPrimitiveFunctionNames = [minBound..maxBound] 132 | 133 | showPrimitiveFunctionName :: PrimitiveFunctionName -> Text 134 | showPrimitiveFunctionName name = 135 | case name of 136 | PrimIAdd -> "iAdd#" 137 | PrimISub -> "iSub#" 138 | PrimIEquals -> "iEquals#" 139 | PrimIGreaterThan -> "iGreaterThan#" 140 | PrimILessThan -> "iLessThan#" 141 | PrimDAdd -> "dAdd#" 142 | PrimDSub -> "dSub#" 143 | PrimIntToDouble -> "intToDouble#" 144 | PrimDoubleToInt -> "doubleToInt#" 145 | 146 | primitiveFunctionType' :: PrimitiveFunctionName -> NonEmpty TyConName 147 | primitiveFunctionType' name = 148 | case name of 149 | PrimIAdd -> [intTyCon, intTyCon, intTyCon] 150 | PrimISub -> [intTyCon, intTyCon, intTyCon] 151 | PrimIEquals -> [intTyCon, intTyCon, boolTyCon] 152 | PrimIGreaterThan -> [intTyCon, intTyCon, boolTyCon] 153 | PrimILessThan -> [intTyCon, intTyCon, boolTyCon] 154 | PrimDAdd -> [doubleTyCon, doubleTyCon, doubleTyCon] 155 | PrimDSub -> [doubleTyCon, doubleTyCon, doubleTyCon] 156 | PrimIntToDouble -> [intTyCon, doubleTyCon] 157 | PrimDoubleToInt -> [doubleTyCon, intTyCon] 158 | 159 | data PrimitiveFunction 160 | = PrimitiveFunction 161 | { primitiveFunctionName :: !PrimitiveFunctionName 162 | , primitiveFunctionNameText :: !IdentName 163 | , primitiveFunctionType :: !(NonEmpty TyConName) 164 | } deriving (Show, Eq) 165 | 166 | allPrimitiveFunctions :: [PrimitiveFunction] 167 | allPrimitiveFunctions = 168 | (\prim -> PrimitiveFunction prim (IdentName $ showPrimitiveFunctionName prim) (primitiveFunctionType' prim)) 169 | <$> allPrimitiveFunctionNames 170 | 171 | primitiveFunctionsByName :: Map IdentName PrimitiveFunction 172 | primitiveFunctionsByName = 173 | Map.fromList 174 | $ (\prim -> (IdentName $ showPrimitiveFunctionName $ primitiveFunctionName prim, prim)) <$> allPrimitiveFunctions 175 | -------------------------------------------------------------------------------- /library/Amy/Syntax.hs: -------------------------------------------------------------------------------- 1 | module Amy.Syntax 2 | ( module X 3 | ) where 4 | 5 | import Amy.Syntax.Lexer as X (lexer) 6 | import Amy.Syntax.Monad as X 7 | import Amy.Syntax.Parser as X 8 | import Amy.Syntax.Pretty as X 9 | -------------------------------------------------------------------------------- /library/Amy/Syntax/AST.hs: -------------------------------------------------------------------------------- 1 | module Amy.Syntax.AST 2 | ( Module(..) 3 | , Binding(..) 4 | , Extern(..) 5 | , Expr(..) 6 | , If(..) 7 | , Case(..) 8 | , Match(..) 9 | , Pattern(..) 10 | , PatCons(..) 11 | , Let(..) 12 | , Lambda(..) 13 | , App(..) 14 | 15 | , expressionSpan 16 | , matchSpan 17 | , patternSpan 18 | 19 | , expressionType 20 | , matchType 21 | , patternType 22 | 23 | , freeBindingVars 24 | , freeExprVars 25 | 26 | -- Re-export 27 | , module Amy.Literal 28 | , module Amy.Names 29 | , module Amy.Syntax.Located 30 | , module Amy.Type 31 | ) where 32 | 33 | import Data.Foldable (toList) 34 | import Data.List.NonEmpty (NonEmpty(..)) 35 | import Data.Map.Strict (Map) 36 | import qualified Data.Map.Strict as Map 37 | import Data.Set (Set) 38 | import qualified Data.Set as Set 39 | 40 | import Amy.Literal 41 | import Amy.Names 42 | import Amy.Prim 43 | import Amy.Syntax.Located 44 | import Amy.Type 45 | 46 | data Module 47 | = Module 48 | { moduleFile :: !FilePath 49 | , moduleTypeDeclarations :: ![TypeDeclaration] 50 | , moduleExterns :: ![Extern] 51 | , moduleBindings :: ![NonEmpty Binding] 52 | } deriving (Show, Eq) 53 | 54 | data Binding 55 | = Binding 56 | { bindingName :: !(Located IdentName) 57 | , bindingType :: !Type 58 | , bindingArgs :: ![Typed (Located IdentName)] 59 | , bindingReturnType :: !Type 60 | , bindingBody :: !Expr 61 | } deriving (Show, Eq) 62 | 63 | data Extern 64 | = Extern 65 | { externName :: !(Located IdentName) 66 | , externType :: !Type 67 | } deriving (Show, Eq) 68 | 69 | data Expr 70 | = ELit !(Located Literal) 71 | | ERecord !SourceSpan !(Map (Located RowLabel) (Typed Expr)) 72 | | ERecordSelect !Expr !(Located RowLabel) !Type 73 | | EVar !(Typed (Located IdentName)) 74 | | ECon !(Typed (Located DataConName)) 75 | | EIf !If 76 | | ECase !Case 77 | | ELet !Let 78 | | ELam !Lambda 79 | | EApp !App 80 | | EParens !Expr 81 | deriving (Show, Eq) 82 | 83 | data If 84 | = If 85 | { ifPredicate :: !Expr 86 | , ifThen :: !Expr 87 | , ifElse :: !Expr 88 | , ifSpan :: !SourceSpan 89 | } deriving (Show, Eq) 90 | 91 | data Case 92 | = Case 93 | { caseScrutinee :: !Expr 94 | , caseAlternatives :: !(NonEmpty Match) 95 | , caseSpan :: !SourceSpan 96 | } deriving (Show, Eq) 97 | 98 | data Match 99 | = Match 100 | { matchPattern :: !Pattern 101 | , matchBody :: !Expr 102 | } deriving (Show, Eq) 103 | 104 | data Pattern 105 | = PLit !(Located Literal) 106 | | PVar !(Typed (Located IdentName)) 107 | | PCons !PatCons 108 | | PParens !Pattern 109 | deriving (Show, Eq) 110 | 111 | data PatCons 112 | = PatCons 113 | { patConsConstructor :: !(Located DataConName) 114 | , patConsArg :: !(Maybe Pattern) 115 | , patConsType :: !Type 116 | } deriving (Show, Eq) 117 | 118 | data Let 119 | = Let 120 | { letBindings :: ![NonEmpty Binding] 121 | , letExpression :: !Expr 122 | , letSpan :: !SourceSpan 123 | } deriving (Show, Eq) 124 | 125 | data Lambda 126 | = Lambda 127 | { lambdaArgs :: !(NonEmpty (Typed (Located IdentName))) 128 | , lambdaBody :: !Expr 129 | , lambdaSpan :: !SourceSpan 130 | , lambdaType :: !Type 131 | } deriving (Show, Eq) 132 | 133 | data App 134 | = App 135 | { appFunction :: !Expr 136 | , appArg :: !Expr 137 | , appReturnType :: !Type 138 | } deriving (Show, Eq) 139 | 140 | expressionSpan :: Expr -> SourceSpan 141 | expressionSpan (ELit (Located s _)) = s 142 | expressionSpan (ERecord s _) = s 143 | expressionSpan (ERecordSelect expr (Located end _) _) = mergeSpans (expressionSpan expr) end 144 | expressionSpan (EVar (Typed _ (Located s _))) = s 145 | expressionSpan (ECon (Typed _ (Located s _))) = s 146 | expressionSpan (EIf (If _ _ _ s)) = s 147 | expressionSpan (ECase (Case _ _ s)) = s 148 | expressionSpan (ELet (Let _ _ s)) = s 149 | expressionSpan (ELam (Lambda _ _ s _)) = s 150 | expressionSpan (EApp (App e1 e2 _)) = mergeSpans (expressionSpan e1) (expressionSpan e2) 151 | expressionSpan (EParens e) = expressionSpan e 152 | 153 | matchSpan :: Match -> SourceSpan 154 | matchSpan (Match pat expr) = mergeSpans (patternSpan pat) (expressionSpan expr) 155 | 156 | patternSpan :: Pattern -> SourceSpan 157 | patternSpan (PLit (Located s _)) = s 158 | patternSpan (PVar (Typed _ (Located s _))) = s 159 | patternSpan (PCons (PatCons (Located s _) mPat _)) = 160 | case mPat of 161 | Nothing -> s 162 | Just pat -> mergeSpans s (patternSpan pat) 163 | patternSpan (PParens pat) = patternSpan pat 164 | 165 | expressionType :: Expr -> Type 166 | expressionType (ELit (Located _ lit)) = literalType lit 167 | expressionType (ERecord _ rows) = TyRecord (Map.mapKeys (notLocated . locatedValue) $ typedType <$> rows) Nothing 168 | expressionType (ERecordSelect _ _ ty) = ty 169 | expressionType (EVar (Typed ty _)) = ty 170 | expressionType (ECon (Typed ty _)) = ty 171 | expressionType (EIf if') = expressionType (ifThen if') -- Checker ensure "then" and "else" types match 172 | expressionType (ECase (Case _ (match :| _) _)) = matchType match 173 | expressionType (ELet let') = expressionType (letExpression let') 174 | expressionType (ELam (Lambda _ _ _ ty)) = ty 175 | expressionType (EApp app) = appReturnType app 176 | expressionType (EParens expr) = expressionType expr 177 | 178 | matchType :: Match -> Type 179 | matchType (Match _ expr) = expressionType expr 180 | 181 | patternType :: Pattern -> Type 182 | patternType (PLit (Located _ lit)) = literalType lit 183 | patternType (PVar (Typed ty _)) = ty 184 | patternType (PCons (PatCons _ _ ty)) = ty 185 | patternType (PParens pat) = patternType pat 186 | 187 | freeBindingVars :: Binding -> Set IdentName 188 | freeBindingVars (Binding (Located _ name) _ args _ body) = 189 | freeExprVars body `Set.difference` Set.fromList (name : (locatedValue . typedValue <$> args)) 190 | 191 | freeExprVars :: Expr -> Set IdentName 192 | freeExprVars ELit{} = Set.empty 193 | freeExprVars (ERecord _ rows) = Set.unions $ freeExprVars . typedValue <$> Map.elems rows 194 | freeExprVars (ERecordSelect expr _ _) = freeExprVars expr 195 | freeExprVars (EVar (Typed _ (Located _ ident))) = Set.singleton ident 196 | freeExprVars ECon{} = Set.empty 197 | freeExprVars (EIf (If pred' then' else' _)) = freeExprVars pred' `Set.union` freeExprVars then' `Set.union` freeExprVars else' 198 | freeExprVars (ECase (Case scrutinee matches _)) = Set.unions (freeExprVars scrutinee : toList (freeMatchVars <$> matches)) 199 | where 200 | freeMatchVars (Match pat expr) = freeExprVars expr `Set.difference` patternVars pat 201 | freeExprVars (ELam (Lambda args body _ _)) = 202 | freeExprVars body `Set.difference` Set.fromList (toList $ locatedValue . typedValue <$> args) 203 | freeExprVars (ELet (Let bindings expr _)) = 204 | Set.unions (freeExprVars expr : (freeBindingVars <$> concatMap toList bindings)) 205 | freeExprVars (EApp (App f arg _)) = freeExprVars f `Set.union` freeExprVars arg 206 | freeExprVars (EParens expr) = freeExprVars expr 207 | 208 | patternVars :: Pattern -> Set IdentName 209 | patternVars PLit{} = Set.empty 210 | patternVars (PVar (Typed _ (Located _ ident))) = Set.singleton ident 211 | patternVars (PCons (PatCons _ mPat _)) = maybe Set.empty patternVars mPat 212 | patternVars (PParens pat) = patternVars pat 213 | -------------------------------------------------------------------------------- /library/Amy/Syntax/BindingGroups.hs: -------------------------------------------------------------------------------- 1 | module Amy.Syntax.BindingGroups 2 | ( bindingGroups 3 | ) where 4 | 5 | import Data.Graph 6 | import Data.List.NonEmpty (NonEmpty(..)) 7 | import qualified Data.List.NonEmpty as NE 8 | import Data.Maybe (fromMaybe) 9 | import qualified Data.Set as Set 10 | 11 | import Amy.Syntax.AST 12 | 13 | bindingGroups :: [Binding] -> [NonEmpty Binding] 14 | bindingGroups bindings = 15 | let 16 | bindingNames = Set.fromList $ locatedValue . bindingName <$> bindings 17 | mkNode binding = 18 | ( binding 19 | , locatedValue (bindingName binding) 20 | , Set.toList $ freeBindingVars binding `Set.intersection` bindingNames 21 | ) 22 | nodes = mkNode <$> bindings 23 | components' = stronglyConnComp nodes 24 | in makeBindingGroup <$> components' 25 | 26 | makeBindingGroup :: SCC Binding -> NonEmpty Binding 27 | makeBindingGroup (AcyclicSCC binding) = binding :| [] 28 | makeBindingGroup (CyclicSCC bindings) = 29 | fromMaybe (error "Found empty CyclicSCC while computing binding groups") 30 | $ NE.nonEmpty bindings 31 | -------------------------------------------------------------------------------- /library/Amy/Syntax/Located.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DeriveTraversable #-} 4 | 5 | module Amy.Syntax.Located 6 | ( Located(..) 7 | , MaybeLocated(..) 8 | , fromLocated 9 | , notLocated 10 | , SourceSpan(..) 11 | , mergeSpans 12 | , mkSourcePos 13 | , mkSourceSpan 14 | , module Text.Megaparsec.Pos 15 | ) where 16 | 17 | import Text.Megaparsec.Pos 18 | 19 | -- | Location of something in source code. 20 | data Located a 21 | = Located 22 | { locatedSpan :: !SourceSpan 23 | , locatedValue :: !a 24 | } deriving (Show, Eq, Ord, Functor, Foldable, Traversable) 25 | 26 | -- | Possible location of something in source code. 27 | data MaybeLocated a 28 | = MaybeLocated 29 | { maybeLocatedSpan :: !(Maybe SourceSpan) 30 | , maybeLocatedValue :: !a 31 | } deriving (Show, Eq, Ord, Functor, Foldable, Traversable) 32 | 33 | fromLocated :: Located a -> MaybeLocated a 34 | fromLocated (Located span' x) = MaybeLocated (Just span') x 35 | 36 | notLocated :: a -> MaybeLocated a 37 | notLocated = MaybeLocated Nothing 38 | 39 | -- | A file path along with a start and end 'SourcePos'. 40 | data SourceSpan 41 | = SourceSpan 42 | { sourceSpanStart :: !SourcePos 43 | , sourceSpanEnd :: !SourcePos 44 | } deriving (Show, Eq, Ord) 45 | 46 | mergeSpans :: SourceSpan -> SourceSpan -> SourceSpan 47 | mergeSpans (SourceSpan start _) (SourceSpan _ end) = SourceSpan start end 48 | 49 | mkSourcePos :: FilePath -> Int -> Int -> SourcePos 50 | mkSourcePos fp line col = SourcePos fp (mkPos line) (mkPos col) 51 | 52 | mkSourceSpan :: FilePath -> Int -> Int -> Int -> Int -> SourceSpan 53 | mkSourceSpan fp startLine startCol endLine endCol = SourceSpan (mkSourcePos fp startLine startCol) (mkSourcePos fp endLine endCol) 54 | -------------------------------------------------------------------------------- /library/Amy/Syntax/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Amy.Syntax.Monad 5 | ( AmyParser 6 | , runAmyParser 7 | , withBlockIndentation 8 | , currentIndentation 9 | , assertIndented 10 | , assertSameIndentation 11 | , indentedBlock 12 | , indentedBlockNonEmpty 13 | ) where 14 | 15 | import Control.Applicative (Alternative) 16 | import qualified Control.Applicative.Combinators.NonEmpty as CNE 17 | import Control.Monad.State.Strict 18 | import Data.List.NonEmpty (NonEmpty) 19 | import Data.Monoid ((<>)) 20 | import Data.Text (Text, pack, unpack) 21 | import Data.Void (Void) 22 | import Text.Megaparsec hiding (State) 23 | 24 | import Amy.Syntax.Lexer 25 | 26 | newtype AmyParser a = AmyParser (StateT Int (Parsec Void AmyTokens) a) 27 | deriving (Functor, Applicative, Alternative, MonadPlus, Monad, MonadState Int, MonadParsec Void AmyTokens) 28 | 29 | runAmyParser :: AmyParser a -> Parsec Void AmyTokens a 30 | runAmyParser (AmyParser action) = evalStateT action 0 31 | 32 | withBlockIndentation :: AmyParser a -> AmyParser a 33 | withBlockIndentation action = do 34 | originalIndent <- currentIndentation 35 | nextIndent <- maybe (unexpected EndOfInput) (pure . unPos . sourceColumn) =<< getNextTokenPosition 36 | setIndentation nextIndent 37 | result <- action 38 | setIndentation originalIndent 39 | pure result 40 | 41 | currentIndentation :: AmyParser Int 42 | currentIndentation = get 43 | 44 | setIndentation :: Int -> AmyParser () 45 | setIndentation x = modify' (const x) 46 | 47 | -- | Check that the current indentation level is past the stored indentation 48 | assertIndented :: AmyParser () 49 | assertIndented = checkIndentation "indentation past column" (>) 50 | 51 | -- | Check that the current indentation level is the same as the stored indentation 52 | assertSameIndentation :: AmyParser () 53 | assertSameIndentation = checkIndentation "indentation at column" (==) 54 | 55 | -- | Check that the current identation level matches a predicate 56 | checkIndentation 57 | :: Text 58 | -> (Int -> Int -> Bool) 59 | -> AmyParser () 60 | checkIndentation msg rel = do 61 | currentIndent <- currentIndentation 62 | nextIndent <- maybe (unexpected EndOfInput) (pure . unPos . sourceColumn) =<< getNextTokenPosition 63 | guard (nextIndent `rel` currentIndent) unpack (msg <> " " <> pack (show currentIndent)) 64 | 65 | -- A block is defined as a group of things that are at the same indentation 66 | -- level. Block items can also be separated by semicolons. 67 | indentedBlock 68 | :: AmyParser a 69 | -> AmyParser [a] 70 | indentedBlock p = 71 | fmap concat $ withBlockIndentation $ many $ 72 | assertSameIndentation *> p `sepBy1` semiColon 73 | 74 | indentedBlockNonEmpty 75 | :: AmyParser a 76 | -> AmyParser (NonEmpty a) 77 | indentedBlockNonEmpty p = 78 | fmap join $ withBlockIndentation $ CNE.some $ 79 | assertSameIndentation *> p `CNE.sepBy1` semiColon 80 | -------------------------------------------------------------------------------- /library/Amy/Syntax/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Amy.Syntax.Pretty 4 | ( prettyModule 5 | , prettyTypeDeclaration 6 | , prettyExpr 7 | , prettyType 8 | ) where 9 | 10 | import Data.Foldable (toList) 11 | import qualified Data.Map.Strict as Map 12 | 13 | import Amy.Pretty 14 | import Amy.Syntax.AST 15 | 16 | prettyModule :: Module -> Doc ann 17 | prettyModule (Module _ typeDecls externs bindings) = 18 | vcatTwoHardLines 19 | $ (prettyTypeDeclaration' <$> typeDecls) 20 | ++ (prettyExtern' <$> externs) 21 | ++ (prettyBinding' <$> concatMap toList bindings) 22 | 23 | prettyTypeDeclaration' :: TypeDeclaration -> Doc ann 24 | prettyTypeDeclaration' (TypeDeclaration info cons) = 25 | prettyTypeDeclaration (prettyTyConDefinition info) (prettyConstructor <$> cons) 26 | where 27 | prettyConstructor (DataConDefinition (Located _ conName) mArg) = 28 | prettyDataConstructor (prettyDataConName conName) (prettyType <$> mArg) 29 | 30 | prettyTyConDefinition :: TyConDefinition -> Doc ann 31 | prettyTyConDefinition (TyConDefinition (Located _ name) args) = prettyTyConName name <> args' 32 | where 33 | args' = if null args then mempty else space <> sep (prettyTyVarName . locatedValue <$> args) 34 | 35 | prettyExtern' :: Extern -> Doc ann 36 | prettyExtern' (Extern (Located _ name) ty) = 37 | prettyExtern (prettyIdent name) (prettyType ty) 38 | 39 | prettyBinding' :: Binding -> Doc ann 40 | prettyBinding' (Binding (Located _ name) ty args _ body) = tyDoc <> bindingDoc 41 | where 42 | tyDoc = 43 | case ty of 44 | TyUnknown -> mempty 45 | _ -> prettyBindingType (prettyIdent name) (prettyType ty) <> hardline 46 | bindingDoc = 47 | prettyBinding (prettyIdent name) (prettyIdent . locatedValue . typedValue <$> args) (prettyExpr body) 48 | 49 | prettyExpr :: Expr -> Doc ann 50 | prettyExpr (ELit (Located _ lit)) = pretty $ showLiteral lit 51 | prettyExpr (ERecord _ rows) = bracketed $ uncurry prettyRow <$> Map.toList rows 52 | where 53 | prettyRow (Located _ label) (Typed _ expr) = prettyRowLabel label <> ":" <+> prettyExpr expr 54 | prettyExpr (ERecordSelect expr (Located _ field) _) = prettyExpr expr <> "." <> prettyRowLabel field 55 | prettyExpr (EVar (Typed _ (Located _ ident))) = prettyIdent ident 56 | prettyExpr (ECon (Typed _ (Located _ dataCon))) = prettyDataConName dataCon 57 | prettyExpr (EIf (If pred' then' else' _)) = 58 | prettyIf (prettyExpr pred') (prettyExpr then') (prettyExpr else') 59 | prettyExpr (ECase (Case scrutinee matches _)) = 60 | prettyCase (prettyExpr scrutinee) Nothing (toList $ mkMatch <$> matches) 61 | where 62 | mkMatch (Match pat body) = (prettyPattern pat, prettyExpr body) 63 | prettyExpr (ELet (Let bindings body _)) = 64 | prettyLet (prettyBinding' <$> concatMap toList bindings) (prettyExpr body) 65 | prettyExpr (ELam (Lambda args body _ _)) = prettyLambda (prettyIdent . locatedValue . typedValue <$> toList args) (prettyExpr body) 66 | prettyExpr (EApp (App f arg _)) = prettyExpr f <+> prettyExpr arg 67 | prettyExpr (EParens expr) = parens $ prettyExpr expr 68 | 69 | prettyPattern :: Pattern -> Doc ann 70 | prettyPattern (PLit (Located _ lit)) = pretty $ showLiteral lit 71 | prettyPattern (PVar (Typed _ (Located _ var))) = prettyIdent var 72 | prettyPattern (PParens pat) = parens (prettyPattern pat) 73 | prettyPattern (PCons (PatCons (Located _ con) mArg _)) = 74 | prettyDataConName con <> maybe mempty prettyArg mArg 75 | where 76 | prettyArg = (space <>) . prettyArg' 77 | prettyArg' arg@PCons{} = parens (prettyPattern arg) 78 | prettyArg' arg = prettyPattern arg 79 | -------------------------------------------------------------------------------- /library/Amy/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Amy.Type 5 | ( -- * Type 6 | Type(..) 7 | , Typed(..) 8 | , unfoldTyApp 9 | , foldTyApp 10 | , unfoldTyFun 11 | , foldTyFun 12 | 13 | -- * Type Traversals 14 | , traverseType 15 | , traverseTypeM 16 | , everywhereOnType 17 | , everywhereOnTypeM 18 | , typeTyCons 19 | , removeTyExistVar 20 | , blowUpOnTyUnknown 21 | 22 | -- * Type Declarations 23 | , TypeDeclaration(..) 24 | , TyConDefinition(..) 25 | , DataConDefinition(..) 26 | ) where 27 | 28 | import Control.Monad.Identity (Identity(..), runIdentity) 29 | import Data.List.NonEmpty (NonEmpty(..)) 30 | import qualified Data.List.NonEmpty as NE 31 | import Data.Map.Strict (Map) 32 | import qualified Data.Map.Strict as Map 33 | import Data.Maybe (fromMaybe) 34 | import Data.Set (Set) 35 | import qualified Data.Set as Set 36 | import Data.Text (pack) 37 | 38 | import Amy.Names 39 | import Amy.Syntax.Located 40 | 41 | -- 42 | -- Type 43 | -- 44 | 45 | data Type 46 | = TyUnknown 47 | | TyCon !(MaybeLocated TyConName) 48 | | TyVar !(MaybeLocated TyVarName) 49 | | TyExistVar !TyExistVarName 50 | | TyApp !Type !Type 51 | | TyRecord !(Map (MaybeLocated RowLabel) Type) !(Maybe Type) 52 | | TyFun !Type !Type 53 | | TyForall !(NonEmpty (MaybeLocated TyVarName)) !Type 54 | deriving (Show, Eq, Ord) 55 | 56 | infixr 0 `TyFun` 57 | 58 | data Typed a 59 | = Typed 60 | { typedType :: !Type 61 | , typedValue :: !a 62 | } deriving (Show, Eq, Ord, Functor) 63 | 64 | unfoldTyApp :: Type -> NonEmpty Type 65 | unfoldTyApp (TyApp app@(TyApp _ _) arg) = unfoldTyApp app <> (arg :| []) 66 | unfoldTyApp (TyApp f arg) = f :| [arg] 67 | unfoldTyApp t = t :| [] 68 | 69 | foldTyApp :: NonEmpty Type -> Type 70 | foldTyApp = foldl1 TyApp 71 | 72 | unfoldTyFun :: Type -> NonEmpty Type 73 | unfoldTyFun (TyForall _ t) = unfoldTyFun t 74 | unfoldTyFun (t1 `TyFun` t2) = NE.cons t1 (unfoldTyFun t2) 75 | unfoldTyFun ty = ty :| [] 76 | 77 | foldTyFun :: NonEmpty Type -> Type 78 | foldTyFun = foldr1 TyFun 79 | 80 | -- 81 | -- Type Traversals 82 | -- 83 | 84 | traverseType :: (Type -> Type) -> Type -> Type 85 | traverseType f = runIdentity . traverseTypeM (Identity . f) 86 | 87 | -- | Single step of a traversal through a 'Type'. 88 | -- 89 | -- This function doesn't traverse the entire 'Type'. It applies a function to 90 | -- all the immediate sub nodes of a single node. This is most useful when 91 | -- paired with another mutually recursive function (@f@) that singles out the 92 | -- nodes it cares about, and leaves this function to traverse the ones it 93 | -- doesn't. 94 | -- 95 | traverseTypeM :: (Monad m) => (Type -> m Type) -> Type -> m Type 96 | traverseTypeM f = go 97 | where 98 | go t@TyUnknown{} = pure t 99 | go t@TyCon{} = pure t 100 | go t@TyVar{} = pure t 101 | go t@TyExistVar{} = pure t 102 | go (TyApp t1 t2) = TyApp <$> f t1 <*> f t2 103 | go (TyRecord rows mTail) = TyRecord <$> traverse f rows <*> traverse f mTail 104 | go (TyFun t1 t2) = TyFun <$> f t1 <*> f t2 105 | go (TyForall vars ty) = TyForall vars <$> f ty 106 | 107 | everywhereOnType :: (Monoid a) => (Type -> a) -> Type -> a 108 | everywhereOnType f = runIdentity . everywhereOnTypeM (Identity . f) 109 | 110 | -- | Computes a 'Monoid'al value from a 'Type'. 111 | -- 112 | -- This function traverses the 'Type' without modifying it, and accumulates 113 | -- results using 'mappend' from the 'Monoid' type class. 114 | -- 115 | everywhereOnTypeM :: (Monad m, Monoid a) => (Type -> m a) -> Type -> m a 116 | everywhereOnTypeM f = go 117 | where 118 | go t@TyUnknown{} = f t 119 | go t@TyCon{} = f t 120 | go t@TyVar{} = f t 121 | go t@TyExistVar{} = f t 122 | go (TyApp t1 t2) = go2 t1 t2 123 | go (TyRecord rows mTail) = do 124 | xRows <- traverse go (Map.elems rows) 125 | xTail <- traverse go mTail 126 | pure $ mconcat xRows <> fromMaybe mempty xTail 127 | go (TyFun t1 t2) = go2 t1 t2 128 | go (TyForall _ ty) = go ty 129 | 130 | go2 t1 t2 = do 131 | x1 <- go t1 132 | x2 <- go t2 133 | pure $ x1 <> x2 134 | 135 | -- | Compute all 'TyConName's in a 'Type' 136 | typeTyCons :: Type -> Set TyConName 137 | typeTyCons = everywhereOnType go 138 | where 139 | go (TyCon (MaybeLocated _ con)) = Set.singleton con 140 | go _ = Set.empty 141 | 142 | -- | Replace any 'TyExistVar' nodes with 'TyVar' nodes. 143 | removeTyExistVar :: Type -> Type 144 | removeTyExistVar = go 145 | where 146 | go (TyExistVar (TyExistVarName i)) = TyVar $ notLocated $ TyVarName $ "$t" <> pack (show i) 147 | go t = traverseType go t 148 | 149 | -- | Sanity check to run after type checking to make sure all 'TyUnknown' 150 | -- values are gone. 151 | blowUpOnTyUnknown :: Type -> Type 152 | blowUpOnTyUnknown = go 153 | where 154 | go TyUnknown = error "TyUnknowns still exist!" 155 | go t = traverseType go t 156 | 157 | -- 158 | -- Type Declarations 159 | -- 160 | 161 | data TypeDeclaration 162 | = TypeDeclaration 163 | { typeDeclarationTypeName :: !TyConDefinition 164 | , typeDeclarationConstructors :: ![DataConDefinition] 165 | } deriving (Show, Eq) 166 | 167 | data TyConDefinition 168 | = TyConDefinition 169 | { tyConDefinitionName :: !(Located TyConName) 170 | , tyConDefinitionArgs :: ![Located TyVarName] 171 | } deriving (Show, Eq) 172 | 173 | data DataConDefinition 174 | = DataConDefinition 175 | { dataConDefinitionName :: !(Located DataConName) 176 | , dataConDefinitionArgument :: !(Maybe Type) 177 | } deriving (Show, Eq) 178 | -------------------------------------------------------------------------------- /library/Amy/TypeCheck.hs: -------------------------------------------------------------------------------- 1 | module Amy.TypeCheck 2 | ( module X 3 | ) where 4 | 5 | import Amy.TypeCheck.TypeCheck as X 6 | -------------------------------------------------------------------------------- /library/Amy/TypeCheck/KindInference.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module Amy.TypeCheck.KindInference 4 | ( inferTypeDeclarationKind 5 | , checkTypeKind 6 | , inferTypeKind 7 | ) where 8 | 9 | import Control.Monad (when) 10 | import Data.Foldable (traverse_) 11 | import Data.Map.Strict (Map) 12 | import qualified Data.Map.Strict as Map 13 | import Data.Maybe (fromMaybe, mapMaybe, maybeToList) 14 | import Data.Set (Set) 15 | import qualified Data.Set as Set 16 | import Data.Traversable (for) 17 | 18 | import Amy.Errors 19 | import Amy.Kind 20 | import Amy.Syntax.Located 21 | import Amy.Type 22 | import Amy.TypeCheck.Monad 23 | 24 | -- 25 | -- Kind Inference 26 | -- 27 | 28 | -- TODO: Infer the kinds of mutually recursive type declaration groups at the 29 | -- same time instead of one by one. 30 | 31 | inferTypeDeclarationKind :: TypeDeclaration -> Checker Kind 32 | inferTypeDeclarationKind (TypeDeclaration (TyConDefinition (Located _ tyCon) tyArgs) constructors) = 33 | withNewLexicalScope $ do 34 | -- Generate unknown kind variables for the type constructor and all type 35 | -- variables. 36 | tyConKindVar <- addUnknownTyConKindToScope tyCon 37 | tyVarKindVars <- traverse (addUnknownTyVarKindToScope . locatedValue) tyArgs 38 | let 39 | tyConConstraint = Constraint (KUnknown tyConKindVar, foldr1 KFun $ (KUnknown <$> tyVarKindVars) ++ [KStar]) 40 | 41 | -- Traverse constructors to collect constraints. 42 | (_, constructorCons) <- unzip <$> traverse inferTypeKind' (mapMaybe dataConDefinitionArgument constructors) 43 | 44 | -- Solve constraints 45 | (Subst subst) <- solver (emptySubst, tyConConstraint : concat constructorCons) 46 | 47 | -- Substitute into tyConKindVar and return 48 | let kind = fromMaybe (error "Lost the input kind") $ Map.lookup tyConKindVar subst 49 | pure $ starIfUnknown kind 50 | 51 | checkTypeKind :: Type -> Checker () 52 | checkTypeKind ty = do 53 | kind <- inferTypeKind ty 54 | when (kind /= KStar) $ 55 | error $ "Somehow kind unification passed but we don't have KStar " ++ show (ty, kind) 56 | 57 | inferTypeKind :: Type -> Checker Kind 58 | inferTypeKind ty = do 59 | (kind, cons) <- inferTypeKind' ty 60 | subst <- solver (emptySubst, cons) 61 | pure $ starIfUnknown $ substituteKind subst kind 62 | 63 | inferTypeKind' :: Type -> Checker (Kind, [Constraint]) 64 | inferTypeKind' TyUnknown = error "Encountered TyUnknown in inferTypeKind" 65 | inferTypeKind' (TyCon (MaybeLocated _ name)) = do 66 | kind <- lookupTyConKind name 67 | pure (kind, []) 68 | inferTypeKind' (TyVar (MaybeLocated _ name)) = do 69 | kind <- lookupTyVarKind name 70 | pure (kind, []) 71 | inferTypeKind' (TyApp t1 t2) = do 72 | (k1, cons1) <- inferTypeKind' t1 73 | (k2, cons2) <- inferTypeKind' t2 74 | retKind <- KUnknown <$> freshId 75 | let constraint = Constraint (k1, k2 `KFun` retKind) 76 | pure (retKind, cons1 ++ cons2 ++ [constraint]) 77 | inferTypeKind' (TyFun t1 t2) = do 78 | (k1, cons1) <- inferTypeKind' t1 79 | (k2, cons2) <- inferTypeKind' t2 80 | kind <- KUnknown <$> freshId 81 | let 82 | constraints = 83 | [ Constraint (k1, KStar) 84 | , Constraint (k2, KStar) 85 | , Constraint (kind, KStar) 86 | ] 87 | pure (kind, cons1 ++ cons2 ++ constraints) 88 | inferTypeKind' (TyRecord fields mTail) = do 89 | fieldCons <- for (Map.elems fields) $ \ty -> do 90 | (fieldKind, fieldCons) <- inferTypeKind' ty 91 | pure $ fieldCons ++ [Constraint (fieldKind, KStar)] 92 | varCons <- for (maybeToList mTail) $ \tail' -> do 93 | (kind, cons) <- inferTypeKind' tail' 94 | pure $ cons ++ [Constraint (kind, KRow)] 95 | kind <- KUnknown <$> freshId 96 | pure (kind, concat fieldCons ++ concat varCons ++ [Constraint (kind, KStar)]) 97 | inferTypeKind' (TyForall vars ty) = withNewLexicalScope $ do 98 | traverse_ addUnknownTyVarKindToScope (maybeLocatedValue <$> vars) 99 | inferTypeKind' ty 100 | inferTypeKind' v@(TyExistVar _) = error $ "Found existential variable in kind inference " ++ show v 101 | 102 | -- | If we have any unknown kinds left, just call them KStar. 103 | starIfUnknown :: Kind -> Kind 104 | starIfUnknown KStar = KStar 105 | starIfUnknown (KUnknown _) = KStar 106 | starIfUnknown KRow = KRow 107 | starIfUnknown (KFun k1 k2) = KFun (starIfUnknown k1) (starIfUnknown k2) 108 | 109 | -- 110 | -- Unification 111 | -- 112 | 113 | newtype Constraint = Constraint (Kind, Kind) 114 | deriving (Show, Eq) 115 | 116 | solver :: (Subst, [Constraint]) -> Checker Subst 117 | solver (su, cs) = 118 | case cs of 119 | [] -> return su 120 | (Constraint (t1, t2): cs0) -> do 121 | su1 <- unifyKinds t1 t2 122 | solver (su1 `composeSubst` su, substituteConstraint su1 <$> cs0) 123 | 124 | unifyKinds :: Kind -> Kind -> Checker Subst 125 | unifyKinds k1 k2 | k1 == k2 = pure emptySubst 126 | unifyKinds (KUnknown i) k = i `bind` k 127 | unifyKinds k (KUnknown i) = i `bind` k 128 | unifyKinds (KFun k1 k2) (KFun k3 k4) = do 129 | su1 <- unifyKinds k1 k3 130 | su2 <- unifyKinds (substituteKind su1 k2) (substituteKind su1 k4) 131 | pure (su2 `composeSubst` su1) 132 | unifyKinds k1 k2 = throwAmyError $ KindUnificationFail k1 k2 133 | 134 | bind :: Int -> Kind -> Checker Subst 135 | bind i k 136 | | k == KUnknown i = pure emptySubst 137 | | occursCheck i k = throwAmyError $ InfiniteKind i k 138 | | otherwise = pure (singletonSubst i k) 139 | 140 | occursCheck :: Int -> Kind -> Bool 141 | occursCheck i k = i `Set.member` unknownKindVariables k 142 | 143 | unknownKindVariables :: Kind -> Set Int 144 | unknownKindVariables KStar = Set.empty 145 | unknownKindVariables (KUnknown i) = Set.singleton i 146 | unknownKindVariables KRow = Set.empty 147 | unknownKindVariables (KFun k1 k2) = unknownKindVariables k1 `Set.union` unknownKindVariables k2 148 | 149 | -- 150 | -- Substitutions 151 | -- 152 | 153 | newtype Subst = Subst (Map Int Kind) 154 | deriving (Eq, Show, Semigroup, Monoid) 155 | 156 | emptySubst :: Subst 157 | emptySubst = Subst Map.empty 158 | 159 | singletonSubst :: Int -> Kind -> Subst 160 | singletonSubst a t = Subst $ Map.singleton a t 161 | 162 | composeSubst :: Subst -> Subst -> Subst 163 | (Subst s1) `composeSubst` (Subst s2) = Subst $ Map.map (substituteKind (Subst s1)) s2 `Map.union` s1 164 | 165 | substituteKind :: Subst -> Kind -> Kind 166 | substituteKind _ KStar = KStar 167 | substituteKind (Subst subst) k@(KUnknown i) = Map.findWithDefault k i subst 168 | substituteKind _ KRow = KRow 169 | substituteKind subst (KFun k1 k2) = KFun (substituteKind subst k1) (substituteKind subst k2) 170 | 171 | substituteConstraint :: Subst -> Constraint -> Constraint 172 | substituteConstraint subst (Constraint (k1, k2)) = Constraint (substituteKind subst k1, substituteKind subst k2) 173 | -------------------------------------------------------------------------------- /library/Amy/Utils/SolveSetEquations.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | 3 | -- | Solve set equations based on unions. 4 | -- 5 | -- This is algorithm is needed for lambda lifting a la "Lambda Lifting: 6 | -- Transforming Programs into Recursive Equations (Johnsson 1985)" 7 | -- 8 | module Amy.Utils.SolveSetEquations 9 | ( SetEquation(..) 10 | , solveSetEquations 11 | ) where 12 | 13 | import Control.Applicative ((<|>)) 14 | import Data.List (find) 15 | import Data.Maybe (fromMaybe) 16 | import Data.Set (Set) 17 | import qualified Data.Set as Set 18 | 19 | -- | Description of a set equation. 20 | -- 21 | -- A @'SetEquation' eq a@ is of the form: 22 | -- 23 | -- @ 24 | -- eq = Set a ∪ Set eq 25 | -- @ 26 | -- 27 | -- For example, here are three equations: 28 | -- 29 | -- @ 30 | -- X = {a, b} ∪ Y ∪ Z 31 | -- Y = {c} ∪ X 32 | -- Z = {d} ∪ Y 33 | -- @ 34 | -- 35 | -- These would be represented as: 36 | -- 37 | -- @ 38 | -- [ SetEquation X [a, b] [Y, Z] 39 | -- , SetEquation Y [c] [X] 40 | -- , SetEquation Z [d] [Y] 41 | -- ] 42 | -- @ 43 | -- 44 | data SetEquation eq a 45 | = SetEquation 46 | { setEquationName :: !eq 47 | , setEquationVars :: !(Set a) 48 | , setEquationOthers :: !(Set eq) 49 | } deriving (Show, Eq) 50 | 51 | -- | Solve a set of @'SetEquation'@s via repeated substitution. 52 | solveSetEquations :: (Eq eq, Ord eq, Ord a) => [SetEquation eq a] -> [(eq, Set a)] 53 | solveSetEquations = solveSetEquations' [] 54 | 55 | solveSetEquations' :: (Eq eq, Ord eq, Ord a) => [(eq, Set a)] -> [SetEquation eq a] -> [(eq, Set a)] 56 | solveSetEquations' solutions [] = reverse solutions 57 | solveSetEquations' solutions (SetEquation name vars others : eqs) = 58 | let 59 | (newVars, newOthers) = unzip $ lookupEquation solutions eqs <$> Set.toList others 60 | vars' = vars `Set.union` Set.unions newVars 61 | others' = Set.unions newOthers `Set.difference` (name `Set.insert` others) 62 | in 63 | if Set.null others' 64 | then solveSetEquations' ((name, vars') : solutions) eqs 65 | else solveSetEquations' solutions (eqs ++ [SetEquation name vars' others']) 66 | 67 | lookupEquation :: (Eq eq) => [(eq, Set a)] -> [SetEquation eq a] -> eq -> (Set a, Set eq) 68 | lookupEquation solved unsolved name = 69 | fromMaybe (error "Internal error: Couldn't find set equation!") 70 | $ lookupSolvedEquation name solved <|> lookupUnsolvedEquation name unsolved 71 | 72 | lookupSolvedEquation :: (Eq eq) => eq -> [(eq, Set a)] -> Maybe (Set a, Set eq) 73 | lookupSolvedEquation name = fmap (, Set.empty) . lookup name 74 | 75 | lookupUnsolvedEquation :: (Eq eq) => eq -> [SetEquation eq a] -> Maybe (Set a, Set eq) 76 | lookupUnsolvedEquation name = 77 | fmap (\(SetEquation _ vars others) -> (vars, others)) 78 | . find ((== name) . setEquationName) 79 | -------------------------------------------------------------------------------- /llvm-playground/closures.c: -------------------------------------------------------------------------------- 1 | /* This program demonstrates closures in C, partial application, and 2 | application of closures. */ 3 | 4 | #include 5 | #include 6 | #include 7 | 8 | /* Generic closure struct. The function pointer and environment are both void 9 | * because they are meant to be casted to the correct types. */ 10 | typedef struct Closure { 11 | int arity; 12 | void (*func_ptr)(); 13 | size_t numargs; 14 | union EnvVal* env; 15 | } Closure; 16 | 17 | /* All values are casted to this union so environments are generic. */ 18 | union EnvVal { 19 | int as_int; 20 | double as_double; 21 | char* as_string; 22 | Closure* as_closure; 23 | }; 24 | 25 | union EnvVal* realloc_env(size_t numargs, union EnvVal* env, size_t newargs) { 26 | union EnvVal* new_env = malloc((numargs + newargs) * sizeof *new_env); 27 | if (numargs > 0) { 28 | memcpy(new_env, env, numargs * sizeof *new_env); 29 | } 30 | return new_env; 31 | } 32 | 33 | union EnvVal* extend_env(size_t env1_size, union EnvVal* env1, size_t env2_size, union EnvVal* env2) { 34 | union EnvVal* newenv = realloc_env(env1_size, env1, env2_size); 35 | memcpy(newenv + env1_size, env2, env2_size * sizeof *env2); 36 | return newenv; 37 | } 38 | 39 | Closure* make_closure(int arity, void (*f)(), size_t numargs, union EnvVal* env) { 40 | struct Closure* closure = (struct Closure*)malloc(sizeof *closure); 41 | closure->arity = arity; 42 | closure->func_ptr = f; 43 | closure->numargs = numargs; 44 | closure->env = realloc_env(numargs, env, 0); 45 | return closure; 46 | } 47 | 48 | Closure* copy_closure(Closure* closure) { 49 | struct Closure* new_closure = (struct Closure*)malloc(sizeof *closure); 50 | new_closure->arity = closure->arity; 51 | new_closure->func_ptr = closure->func_ptr; 52 | new_closure->numargs = closure->numargs; 53 | new_closure->env = closure->env; 54 | return new_closure; 55 | } 56 | 57 | Closure* extend_closure(Closure* closure, size_t env_size, union EnvVal* env) { 58 | struct Closure* new_closure = copy_closure(closure); 59 | new_closure->env = extend_env(new_closure->numargs, new_closure->env, env_size, env); 60 | new_closure->numargs += env_size; 61 | return new_closure; 62 | } 63 | 64 | Closure* call_closure(Closure* closure) { 65 | int arity = closure->arity; 66 | size_t numargs = closure->numargs; 67 | Closure* (*f)() = (Closure* (*)(union EnvVal* env, union EnvVal, union EnvVal))closure->func_ptr; 68 | union EnvVal* env = closure -> env; 69 | Closure* result; 70 | 71 | size_t arity_diff = (size_t)arity - numargs; 72 | if (arity_diff < 0) { 73 | /* Too many arguments, call then call again with extra arguments tacked on */ 74 | result = f(env); // f shouldn't use extra arguments, so we just leave them on 75 | return call_closure(extend_closure(result, -arity_diff, env - arity_diff)); 76 | } else if (arity_diff == 0) { 77 | /* Proper number of args, just call */ 78 | return f(env); 79 | } else { 80 | /* Not enough arguments, partial application */ 81 | return closure; 82 | } 83 | } 84 | 85 | Closure* call_closure_1(Closure* closure, union EnvVal x1) { 86 | return call_closure(extend_closure(closure, 1, (union EnvVal[1]){x1})); 87 | } 88 | 89 | Closure* call_closure_2(Closure* closure, union EnvVal x1, union EnvVal x2) { 90 | return call_closure(extend_closure(closure, 2, (union EnvVal[2]){x1, x2})); 91 | } 92 | 93 | Closure* call_closure_3(Closure* closure, union EnvVal x1, union EnvVal x2, union EnvVal x3) { 94 | return call_closure(extend_closure(closure, 3, (union EnvVal[3]){x1, x2, x3})); 95 | } 96 | 97 | void my_print(int x, int y, int z) { 98 | printf("my_print: x: %d, y: %d, z: %d\n", x, y, z); 99 | } 100 | 101 | void my_print_wrapper_1(union EnvVal* env) { 102 | int x = env[0].as_int; 103 | int y = env[1].as_int; 104 | int z = env[2].as_int; 105 | my_print(x, y, z); 106 | } 107 | 108 | struct Closure* make_my_print_closure_1(int x) 109 | { 110 | union EnvVal xe; 111 | xe.as_int = x; 112 | union EnvVal env[] = {xe}; 113 | 114 | return make_closure(3, &my_print_wrapper_1, 1, env); 115 | } 116 | 117 | void my_print_wrapper_2(union EnvVal* env) { 118 | int x = env[0].as_int; 119 | int y = env[1].as_int; 120 | int z = env[2].as_int; 121 | my_print(x, y, z); 122 | } 123 | 124 | struct Closure* make_my_print_closure_2(int x, int y) 125 | { 126 | union EnvVal xe, ye; 127 | xe.as_int = x; 128 | ye.as_int = y; 129 | union EnvVal env[] = {xe, ye}; 130 | 131 | return make_closure(3, &my_print_wrapper_2, 2, env); 132 | } 133 | 134 | void my_other(int x, int y, double a, char* z) { 135 | printf("my_other: x: %d, y: %d, a: %f, z: %s\n", x, y, a, z); 136 | } 137 | 138 | void my_other_wrapper(union EnvVal* env) { 139 | int x = env[0].as_int; 140 | int y = env[1].as_int; 141 | double a = env[2].as_double; 142 | char* z = env[3].as_string; 143 | my_other(x, y, a, z); 144 | } 145 | 146 | struct Closure* make_my_other_closure(int x, int y, double a) 147 | { 148 | union EnvVal xe, ye, ae; 149 | xe.as_int = x; 150 | ye.as_int = y; 151 | ae.as_double = a; 152 | union EnvVal env[] = {xe, ye, ae}; 153 | 154 | return make_closure(4, &my_other_wrapper, 3, env); 155 | } 156 | 157 | int main() { 158 | /* Allocate closures */ 159 | Closure* my_print_closure_1 = make_my_print_closure_1(100); 160 | Closure* my_print_closure_2 = make_my_print_closure_2(5, 1); 161 | Closure* my_other_closure = make_my_other_closure(-1, -2, -3.45); 162 | 163 | union EnvVal one_thousand, five_hundred, hello; 164 | five_hundred.as_int = 500; 165 | one_thousand.as_int = 1000; 166 | hello.as_string = "hello"; 167 | call_closure_2(my_print_closure_1, five_hundred, one_thousand); 168 | call_closure_1(my_print_closure_2, one_thousand); 169 | call_closure_1(my_other_closure, hello); 170 | 171 | printf("\nNow we are going nested\n"); 172 | Closure* nested_1 = call_closure_1(my_print_closure_1, five_hundred); 173 | call_closure_1(nested_1, one_thousand); 174 | 175 | union EnvVal one, two, three; 176 | one.as_int = 1; 177 | two.as_int = 2; 178 | three.as_double = 3.3333; 179 | Closure* nested_3 = call_closure_1(make_closure(4, &my_other_wrapper, 0, NULL), one); 180 | call_closure_3(nested_3, two, three, hello); 181 | } 182 | -------------------------------------------------------------------------------- /llvm-playground/foo-bar.ll: -------------------------------------------------------------------------------- 1 | define double @foo(double %a, double %b) { 2 | entry: 3 | %multmp = fmul double %a, %a 4 | %multmp1 = fmul double 2.000000e+00, %a 5 | %multmp2 = fmul double %multmp1, %b 6 | %addtmp = fadd double %multmp, %multmp2 7 | %multmp3 = fmul double %b, %b 8 | %addtmp4 = fadd double %addtmp, %multmp3 9 | ret double %addtmp4 10 | } 11 | 12 | define double @bar(double %a) { 13 | entry: 14 | %calltmp = call double @foo(double %a, double 4.000000e+00) 15 | ; %calltmp1 = call double @bar(double 3.133700e+04) 16 | %addtmp = fadd double %calltmp, 1.112 17 | ret double %addtmp 18 | } 19 | 20 | @formatString = private constant [4 x i8] c"%f\0A\00" 21 | 22 | declare i32 @printf(i8*, ...) 23 | 24 | define i32 @main() { 25 | entry: 26 | %res = call double @bar(double 1.234000e+00) 27 | call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([4 x i8], [4 x i8]* @formatString , i32 0, i32 0), double %res) 28 | ret i32 0 29 | } 30 | 31 | 32 | ; define i32 @main() { 33 | ; entry: 34 | ; %d = shl i32 2, 3 35 | ; %pt = getelementptr [2 x i8], [2 x i8]* @formatString, i32 0, i32 0 36 | ; call i32 (i8*, ...) @printf(i8* %pt, i32 %d) 37 | ; ret i32 1 38 | ; } -------------------------------------------------------------------------------- /llvm-playground/func_pointer.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int add(int i, int j) 4 | { 5 | return (i + j); 6 | } 7 | 8 | int sub(int i, int j) 9 | { 10 | return (i - j); 11 | } 12 | 13 | void print(int x, int y, int (*func)()) 14 | { 15 | printf("value is: %d\n", (*func)(x, y)); 16 | } 17 | 18 | int main() 19 | { 20 | int x=100, y=200; 21 | print(x,y,add); 22 | print(x,y,sub); 23 | 24 | return 0; 25 | } 26 | -------------------------------------------------------------------------------- /llvm-playground/func_pointer.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'func_pointer.c' 2 | source_filename = "func_pointer.c" 3 | target datalayout = "e-m:e-i64:64-f80:128-n8:16:32:64-S128" 4 | target triple = "x86_64-pc-linux-gnu" 5 | 6 | @.str = private unnamed_addr constant [14 x i8] c"value is: %d\0A\00", align 1 7 | 8 | ; Function Attrs: norecurse nounwind readnone sspstrong uwtable 9 | define i32 @add(i32, i32) #0 { 10 | %3 = add nsw i32 %1, %0 11 | ret i32 %3 12 | } 13 | 14 | ; Function Attrs: norecurse nounwind readnone sspstrong uwtable 15 | define i32 @sub(i32, i32) #0 { 16 | %3 = sub nsw i32 %0, %1 17 | ret i32 %3 18 | } 19 | 20 | ; Function Attrs: nounwind sspstrong uwtable 21 | define void @print(i32, i32, i32 (...)* nocapture) local_unnamed_addr #1 { 22 | %4 = bitcast i32 (...)* %2 to i32 (i32, i32, ...)* 23 | %5 = tail call i32 (i32, i32, ...) %4(i32 %0, i32 %1) #3 24 | %6 = tail call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([14 x i8], [14 x i8]* @.str, i64 0, i64 0), i32 %5) 25 | ret void 26 | } 27 | 28 | ; Function Attrs: nounwind 29 | declare i32 @printf(i8* nocapture readonly, ...) local_unnamed_addr #2 30 | 31 | ; Function Attrs: nounwind sspstrong uwtable 32 | define i32 @main() local_unnamed_addr #1 { 33 | tail call void @print(i32 100, i32 200, i32 (...)* bitcast (i32 (i32, i32)* @add to i32 (...)*)) 34 | tail call void @print(i32 100, i32 200, i32 (...)* bitcast (i32 (i32, i32)* @sub to i32 (...)*)) 35 | ret i32 0 36 | } 37 | 38 | attributes #0 = { norecurse nounwind readnone sspstrong uwtable "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "less-precise-fpmad"="false" "no-frame-pointer-elim"="false" "no-infs-fp-math"="false" "no-jump-tables"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" } 39 | attributes #1 = { nounwind sspstrong uwtable "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "less-precise-fpmad"="false" "no-frame-pointer-elim"="false" "no-infs-fp-math"="false" "no-jump-tables"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" } 40 | attributes #2 = { nounwind "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "less-precise-fpmad"="false" "no-frame-pointer-elim"="false" "no-infs-fp-math"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" } 41 | attributes #3 = { nounwind } 42 | 43 | !llvm.module.flags = !{!0, !1, !2} 44 | !llvm.ident = !{!3} 45 | 46 | !0 = !{i32 1, !"wchar_size", i32 4} 47 | !1 = !{i32 7, !"PIC Level", i32 2} 48 | !2 = !{i32 7, !"PIE Level", i32 2} 49 | !3 = !{!"clang version 6.0.0 (tags/RELEASE_600/final)"} 50 | -------------------------------------------------------------------------------- /llvm-playground/func_pointer_manual.ll: -------------------------------------------------------------------------------- 1 | ; I manually modified func_pointer.ll and func_pointer.c to simplify the 2 | ; clang-optimized code. It is much clearer because there aren't arbitrary 3 | ; bitcasts everywhere. 4 | 5 | @.str = private unnamed_addr constant [14 x i8] c"value is: %d\0A\00" 6 | 7 | define private i32 @add(i32, i32) { 8 | %3 = add nsw i32 %1, %0 9 | ret i32 %3 10 | } 11 | 12 | define private i32 @sub(i32, i32) { 13 | %3 = sub nsw i32 %0, %1 14 | ret i32 %3 15 | } 16 | 17 | define private void @print(i32, i32, i32 (i32, i32)* nocapture) { 18 | %4 = call i32 (i32, i32) %2(i32 %0, i32 %1) #3 19 | %5 = call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([14 x i8], [14 x i8]* @.str, i64 0, i64 0), i32 %4) 20 | ret void 21 | } 22 | 23 | declare i32 @printf(i8* nocapture readonly, ...) 24 | 25 | define i32 @main() local_unnamed_addr #1 { 26 | call void @print(i32 100, i32 200, i32 (i32, i32)* @add) 27 | call void @print(i32 100, i32 200, i32 (i32, i32)* @sub) 28 | ret i32 0 29 | } 30 | -------------------------------------------------------------------------------- /llvm-playground/hello.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int main() { 4 | puts("Hello, world!"); 5 | puts("Another string"); 6 | return 0; 7 | } 8 | -------------------------------------------------------------------------------- /llvm-playground/hello.ll: -------------------------------------------------------------------------------- 1 | ; ModuleID = 'hello.c' 2 | source_filename = "hello.c" 3 | target datalayout = "e-m:e-i64:64-f80:128-n8:16:32:64-S128" 4 | target triple = "x86_64-unknown-linux-gnu" 5 | 6 | @.str = private unnamed_addr constant [14 x i8] c"Hello, world!\00", align 1 7 | @.str.1 = private unnamed_addr constant [15 x i8] c"Another string\00", align 1 8 | 9 | ; Function Attrs: nounwind sspstrong uwtable 10 | define i32 @main() local_unnamed_addr #0 { 11 | %1 = tail call i32 @puts(i8* getelementptr inbounds ([14 x i8], [14 x i8]* @.str, i64 0, i64 0)) 12 | %2 = tail call i32 @puts(i8* getelementptr inbounds ([15 x i8], [15 x i8]* @.str.1, i64 0, i64 0)) 13 | ret i32 0 14 | } 15 | 16 | ; Function Attrs: nounwind 17 | declare i32 @puts(i8* nocapture readonly) local_unnamed_addr #1 18 | 19 | attributes #0 = { nounwind sspstrong uwtable "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "less-precise-fpmad"="false" "no-frame-pointer-elim"="false" "no-infs-fp-math"="false" "no-jump-tables"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" } 20 | attributes #1 = { nounwind "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "less-precise-fpmad"="false" "no-frame-pointer-elim"="false" "no-infs-fp-math"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="false" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" } 21 | 22 | !llvm.module.flags = !{!0, !1, !2} 23 | !llvm.ident = !{!3} 24 | 25 | !0 = !{i32 1, !"wchar_size", i32 4} 26 | !1 = !{i32 7, !"PIC Level", i32 2} 27 | !2 = !{i32 7, !"PIE Level", i32 2} 28 | !3 = !{!"clang version 5.0.1 (tags/RELEASE_501/final)"} 29 | -------------------------------------------------------------------------------- /llvm-playground/if.ll: -------------------------------------------------------------------------------- 1 | define i32 @main() { 2 | entry: 3 | %0 = icmp eq i1 0, 1 4 | br i1 %0, label %if.then.0, label %if.else.0 5 | 6 | if.then.0: 7 | br label %if.end.0 8 | 9 | if.else.0: 10 | br label %if.end.0 11 | 12 | if.end.0: 13 | %1 = phi i32 [2, %if.then.0], [3, %if.else.0] 14 | ret i32 %1 15 | } 16 | -------------------------------------------------------------------------------- /llvm-playground/struct.ll: -------------------------------------------------------------------------------- 1 | %struct.MyStruct = type { i32, i32 } 2 | 3 | define i32 @main() { 4 | entry: 5 | ; Allocate struct 6 | %0 = call %struct.MyStruct* @makeStruct() 7 | 8 | ; Get struct fields back and add them 9 | %1 = getelementptr %struct.MyStruct, %struct.MyStruct* %0, i32 0, i32 0 10 | %2 = load i32, i32* %1 11 | %3 = getelementptr %struct.MyStruct, %struct.MyStruct* %0, i32 0, i32 1 12 | %4 = load i32, i32* %3 13 | 14 | ; Compute result and return 15 | %5 = add nsw i32 %2, %4 16 | ret i32 %5 17 | } 18 | 19 | define %struct.MyStruct* @makeStruct() { 20 | entry: 21 | ; Allocate struct 22 | %0 = alloca %struct.MyStruct 23 | %1 = getelementptr %struct.MyStruct, %struct.MyStruct* %0, i32 0, i32 0 24 | store i32 15, i32* %1 25 | %2 = getelementptr %struct.MyStruct, %struct.MyStruct* %0, i32 0, i32 1 26 | store i32 75, i32* %2 27 | 28 | ret %struct.MyStruct* %0 29 | } -------------------------------------------------------------------------------- /misc/interesting-haskell.hs: -------------------------------------------------------------------------------- 1 | --{-# LANGUAGE MonoLocalBinds, NoMonomorphismRestriction #-} 2 | 3 | -- | Interesting Haskell examples for parsing, type inference, etc 4 | 5 | main = pure () 6 | 7 | f y z = 8 | y (g z) True 9 | 10 | g x = (1 :: Int) 11 | 12 | h :: a -> (Bool, Int, a) 13 | h k = 14 | let 15 | id' x = x 16 | y = id' True 17 | z = id' (1 :: Int) 18 | in (id' y, id' z, id' k) 19 | 20 | m = 21 | let 22 | x = 1 23 | in let 24 | y = 5 25 | z = 7 26 | in x + y + z 27 | 28 | 29 | l = do 30 | print "hi" 31 | pure () 32 | pure $ 33 | let 34 | x = 1 35 | in x 36 | 37 | -- a :: Int -> Int 38 | -- a _ _ = 1 39 | 40 | prefix :: a -> [[a]] -> [[a]] 41 | prefix x yss = 42 | let 43 | -- xcons :: [a] -> [a] 44 | xcons ys = x : ys 45 | in 46 | map xcons yss 47 | 48 | 49 | data Seq a 50 | = Nil 51 | | Zero (Seq (a,a)) 52 | | One a (Seq (a,a)) 53 | deriving (Show, Eq) 54 | 55 | -- If type signature for cons is left off, we get this error: 56 | -- 57 | -- • Occurs check: cannot construct the infinite type: b ~ (b, b) 58 | -- Expected type: (b, b) -> Seq (b, b) -> Seq (b, b) 59 | -- Actual type: b -> Seq b -> Seq b 60 | -- • Relevant bindings include 61 | -- cons :: (b, b) -> Seq (b, b) -> Seq (b, b) 62 | cons :: a -> Seq a -> Seq a 63 | cons x Nil = One x Nil 64 | cons x (Zero ps) = One x ps 65 | cons x (One y ps) = Zero (cons (x,y) ps) 66 | 67 | -- • Couldn't match expected type ‘Bool’ with actual type ‘Char’ 68 | -- • In the first argument of ‘g’, namely ‘'a'’ 69 | -- In the expression: g 'a' 70 | -- In the expression: (g True, g 'a') 71 | -- | 72 | -- 62 | f' g = (g True, g 'a') 73 | -- | ^^^ 74 | -- 75 | -- f' g = (g True, g 'a') 76 | 77 | 78 | data BalancedTree a 79 | = Zero' a 80 | | Succ (BalancedTree (a,a)) 81 | 82 | zig :: BalancedTree a -> a 83 | zig (Zero' a) = a 84 | zig (Succ t) = fst (zag t) 85 | 86 | -- zag :: BalancedTree a -> a 87 | zag (Zero' a) = a 88 | zag (Succ t) = snd (zig t) 89 | 90 | 91 | f' x = x + 1 92 | g' x = let h y = f' y * 2 93 | k z = z+x 94 | in h x + k x 95 | 96 | 97 | -- Fails to type check if {-# LANGUAGE MonoLocalBinds, 98 | -- NoMonomorphismRestriction #-} is set. The function @b@ will be assumed to be 99 | -- of type b :: a -> Bool -> (a, Bool) instead of the more general b :: a -> b 100 | -- -> (a, b) 101 | a x = 102 | let 103 | --b :: _ 104 | b y = (x,y) 105 | in (b 3, b False) 106 | 107 | -- This takes a really, really long time to type check! I got it from Types and 108 | -- Programming Languages, which cites Mairson (1990) as the source. 109 | -- fun = 110 | -- let f0 = \x -> (x, x) in 111 | -- let f1 = \y -> f0 (f0 y) in 112 | -- let f2 = \y -> f1 (f1 y) in 113 | -- let f3 = \y -> f2 (f2 y) in 114 | -- let f4 = \y -> f3 (f3 y) in 115 | -- let f5 = \y -> f4 (f4 y) in 116 | -- f5 (\z -> z) 117 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: amy 2 | 3 | ghc-options: -Wall 4 | 5 | library: 6 | source-dirs: library 7 | dependencies: 8 | - base 9 | - bytestring 10 | - containers 11 | - filepath 12 | - groom 13 | - llvm-hs 14 | - llvm-hs-pretty 15 | - llvm-hs-pure 16 | - megaparsec 17 | - mtl 18 | - parser-combinators 19 | - prettyprinter 20 | - process 21 | - scientific 22 | - text 23 | - transformers 24 | 25 | tests: 26 | spec: 27 | main: Spec.hs 28 | source-dirs: 29 | - tests 30 | dependencies: 31 | - amy 32 | - base 33 | - containers 34 | - hspec 35 | - hspec-megaparsec 36 | - megaparsec 37 | - text 38 | 39 | executables: 40 | amy: 41 | source-dirs: executables 42 | main: Main.hs 43 | dependencies: 44 | - amy 45 | - base 46 | - bytestring 47 | - haskeline 48 | - megaparsec 49 | - mtl 50 | - optparse-applicative 51 | - text 52 | -------------------------------------------------------------------------------- /rts/.gitignore: -------------------------------------------------------------------------------- 1 | rts.ll 2 | -------------------------------------------------------------------------------- /rts/README.md: -------------------------------------------------------------------------------- 1 | # Runtime System 2 | 3 | Amy compiles to LLVM. One of the main goals is to take advantage of LLVM 4 | optimizations, and we can do that by using idiomatic LLVM. That means we 5 | shouldn't go crazy writing a ton of runtime system code to handle stacks, the 6 | heap, registers, etc. Code not written is code not maintained! 7 | 8 | Of course, we inevitably need _some_ runtime code. This document describes it. 9 | 10 | ## Garbage collection 11 | 12 | We currently punt this to the [Boehm Garbage 13 | Collector](http://www.hboehm.info/gc/). Using this garbage collector is just 14 | too easy: 15 | 16 | * Link it into compiled programs with Clang via `-lgc` 17 | * Replace any uses of `malloc` with `GC_malloc` 18 | 19 | In the future we will need much more sophisticated accurate garbage collection, 20 | but this should do for now. 21 | 22 | Luckily Amy is strict. We will certainly do a lot less heap allocation than 23 | e.g. GHC/Haskell, which needs to do tons of allocations for thunks. Some 24 | allocation is totally unavoidable, as long as the language supports partial 25 | application and closures. Ideally the compiler can minimize the amount of heap 26 | allocation it has to do. 27 | 28 | ## Closure conversion, eval/apply 29 | 30 | The closure conversion algorithm is inspired by the great paper [How to make a 31 | fast curry: push/enter vs eval/apply (Marlow/SPJ 32 | 2004)](https://www.microsoft.com/en-us/research/publication/make-fast-curry-pushenter-vs-evalapply/). 33 | 34 | The key takeaways from this paper and how they apply to our closure conversion 35 | system are: 36 | 37 | * You can't look at a function type signature and know its arity. A function of 38 | type `Int -> Int -> Int` could very well take two `Int`s and return another. 39 | Or, it could take one `Int` and return a function that takes an `Int` and 40 | returns an `Int`. It could even take zero arguments and just return a 41 | function of `Int -> Int -> Int`! 42 | * You can't look at a function's type and know if it is partially applied or 43 | not. 44 | * With the two previous points in mind, if we are applying arguments to an 45 | unknown function (i.e. a function where we only know the type, like when a 46 | function is passed as an argument to another function), **we can't know 47 | exactly how many arguments to apply.** 48 | 49 | We use the eval/apply model of closure evaluation. In this model, we wrap up 50 | all closures in a struct that holds a pointer to the function, the function's 51 | arity, and already-applied arguments to the function (if any). When applying an 52 | unknown function, we first add all the arguments to the closure's array of 53 | arguments. Then, we check the length of the argument array against the arity: 54 | 55 | * If there are too many arguments, then we first apply the correct amount to 56 | the function, and then we apply the remaining arguments to the function's 57 | return value. 58 | * If there are just enough arguments, call the function and return the result. 59 | * If there are not enough arguments, then just return the closure as-is since 60 | it is partially applied. 61 | 62 | There are some key implementation points to be made: 63 | 64 | * Known function calls can be optimized as a normal LLVM `call` to a known 65 | global address. However, pretty much every other use of a function is assumed 66 | to be working with a closure. In particular, every time we use a function as 67 | an argument or return a function from a function, we wrap that sucker up in a 68 | closure. 69 | * All values need to fit in however many bits we allocate for each element of 70 | the argument array in closures (currently 64 bits via `int64_t` in C). This 71 | might be made much more complicated once we have precise garbage collection. 72 | * It is very possible packing arguments into arrays and then unpacking them is 73 | orders of magnitudes slower than keeping the latest arguments in registers 74 | like GHC does. 75 | 1. The main strategy here is to hopefully optimize away closures in 76 | performance sensitive code. 77 | 2. The current implementation is extremely simple, and we don't need to 78 | generate dozens of premade functions for different call patterns like GHC 79 | does. For now simplicity wins. 80 | 3. Once we have a respectable benchmark suite and regression tests, we can 81 | optimize this much more. 82 | -------------------------------------------------------------------------------- /rts/rts.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "gc.h" 4 | 5 | /* Closure struct. Packs in a function with known arity and an array of 6 | arguments to apply (called the environment, or env). */ 7 | typedef struct Closure { 8 | int8_t arity; 9 | struct Closure* (*func_ptr)(int64_t* env); 10 | int8_t numargs; 11 | int64_t* env; // N.B. Using int64_t everywhere probably only works well on 64 bit archs 12 | } Closure; 13 | 14 | /* Create an empty closure with the given function pointer. */ 15 | Closure* create_closure(int8_t arity, Closure* (*f)(int64_t* env)) { 16 | struct Closure* closure = (struct Closure*)GC_malloc(sizeof *closure); 17 | closure->arity = arity; 18 | closure->func_ptr = f; 19 | closure->numargs = 0; 20 | closure->env = NULL; 21 | return closure; 22 | } 23 | 24 | /* Extends an environment by concatenating the new environment to the end of 25 | the old one. */ 26 | int64_t* extend_env(int8_t env1_size, int64_t* env1, int8_t env2_size, int64_t* env2) { 27 | int64_t* newenv = GC_malloc((size_t)(env1_size + env2_size) * sizeof *newenv); 28 | if (env1_size > 0) { 29 | memcpy(newenv, env1, (size_t)env1_size * sizeof *newenv); 30 | } 31 | memcpy(newenv + env1_size, env2, (size_t)env2_size * sizeof *env2); 32 | return newenv; 33 | } 34 | 35 | Closure* copy_closure(Closure* closure) { 36 | struct Closure* new_closure = (struct Closure*)GC_malloc(sizeof *closure); 37 | new_closure->arity = closure->arity; 38 | new_closure->func_ptr = closure->func_ptr; 39 | new_closure->numargs = closure->numargs; 40 | new_closure->env = closure->env; 41 | return new_closure; 42 | } 43 | 44 | /* Extends a closure's environment with the given environment. */ 45 | Closure* extend_closure(Closure* closure, int8_t env_size, int64_t* env) { 46 | struct Closure* new_closure = copy_closure(closure); 47 | new_closure->env = extend_env(new_closure->numargs, new_closure->env, env_size, env); 48 | new_closure->numargs += env_size; 49 | return new_closure; 50 | } 51 | 52 | /* Recursive function to evaluate a closure and return the result. 53 | 54 | This function uses the eval/apply model of closure application. The closure 55 | function is first inspected to get its arity and the number of arguments 56 | applied to it. Then we consider 3 cases: too many arguments, exactly the 57 | right amount of arguments, and not enough arguments. 58 | 59 | This function has a return type of Closure* so we don't do a bunch of casts 60 | here, but in reality the final result of a closure application could be any 61 | arbitrary result if called with the correct number of arguments. 62 | */ 63 | Closure* eval_closure(Closure* closure) { 64 | int8_t arity = closure->arity; 65 | int8_t numargs = closure->numargs; 66 | Closure* (*f)(int64_t* env) = closure->func_ptr; 67 | int64_t* env = closure->env; 68 | Closure* result; 69 | 70 | int8_t arity_diff = arity - numargs; 71 | if (arity_diff < 0) { 72 | /* Too many arguments. Call, then call result with remaining arguments. 73 | 74 | N.B. This relies on f returning a closure. Any time a function is 75 | returned from another function, it must be a closure, even if it isn't 76 | partially applied. */ 77 | 78 | result = f(env); // f shouldn't use extra arguments, so we just leave them on 79 | 80 | /* N.B. we offset the environment by the arity because that is how many 81 | arguments the previous function call used. */ 82 | return eval_closure(extend_closure(result, -arity_diff, env + arity)); 83 | 84 | } else if (arity_diff == 0) { 85 | /* Proper number of args, just call the function and return the result. */ 86 | return f(env); 87 | 88 | } else { 89 | /* Not enough arguments. This is a partial application, and we just return 90 | the result. */ 91 | return closure; 92 | } 93 | } 94 | 95 | /* Calls a closure with the given array of arguments. 96 | 97 | N.B. We can probably pre-generate lots of tiny call_closure_1, 98 | call_closure_2 etc. functions with the exact number of arguments to make 99 | the caller's life easier. */ 100 | Closure* call_closure(Closure* closure, int8_t numargs, int64_t* args) { 101 | return eval_closure(extend_closure(closure, numargs, args)); 102 | } 103 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2018-09-06 2 | 3 | packages: 4 | - '.' 5 | - integration-tests 6 | -------------------------------------------------------------------------------- /stdlib/.gitignore: -------------------------------------------------------------------------------- 1 | Prelude.ll 2 | -------------------------------------------------------------------------------- /stdlib/Prelude.amy: -------------------------------------------------------------------------------- 1 | Maybe a = Nothing | Just a 2 | 3 | maybe :: forall a b. b -> (a -> b) -> Maybe a -> b 4 | maybe default f mValue = 5 | case mValue of 6 | Nothing -> default 7 | Just a -> f a 8 | 9 | Either a b = Left a | Right b 10 | 11 | either :: forall a b c. (a -> c) -> (b -> c) -> Either a b -> c 12 | either f g e = 13 | case e of 14 | Left a -> f a 15 | Right b -> g b 16 | 17 | id :: forall a. a -> a 18 | id x = x 19 | 20 | const :: forall a b. a -> b -> a 21 | const x y = x 22 | -------------------------------------------------------------------------------- /tests/Amy/Syntax/ParserSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Amy.Syntax.ParserSpec 5 | ( spec 6 | ) where 7 | 8 | import Data.Text (Text) 9 | import Data.Void (Void) 10 | import Test.Hspec 11 | import Test.Hspec.Megaparsec 12 | import Text.Megaparsec 13 | 14 | import Amy.Syntax.AST 15 | import Amy.Syntax.Lexer 16 | import Amy.Syntax.Monad 17 | import Amy.Syntax.Parser 18 | 19 | parse' :: AmyParser a -> Text -> Either (ParseError (Located AmyToken) Void) a 20 | parse' parser input = 21 | let (Right tokens') = lexer "" input 22 | in parse (runAmyParser parser) "" tokens' 23 | 24 | mkSpan :: Int -> Int -> Int -> Int -> SourceSpan 25 | mkSpan = mkSourceSpan "" 26 | 27 | mkLocated :: Int -> Int -> Int -> Int -> a -> MaybeLocated a 28 | mkLocated startLine startCol endLine endCol x = MaybeLocated (Just $ mkSpan startLine startCol endLine endCol) x 29 | 30 | spec :: Spec 31 | spec = do 32 | 33 | describe "externDecl" $ do 34 | it "parses extern declaration" $ do 35 | parse' externDecl "extern f :: Int" 36 | `shouldParse` 37 | Extern 38 | (Located (mkSpan 1 8 1 9) "f") 39 | (TyCon (mkLocated 1 13 1 16 "Int")) 40 | parse' externDecl "extern f :: Int -> Double" 41 | `shouldParse` 42 | Extern 43 | (Located (mkSpan 1 8 1 9) "f") 44 | ( TyCon (mkLocated 1 13 1 16 "Int") 45 | `TyFun` 46 | TyCon (mkLocated 1 20 1 26 "Double") 47 | ) 48 | 49 | describe "bindingType" $ do 50 | it "parses binding types" $ do 51 | parse' parseBindingType "f :: Int" 52 | `shouldParse` 53 | ( Located (mkSpan 1 1 1 2) "f" 54 | , TyCon (mkLocated 1 6 1 9 "Int") 55 | ) 56 | parse' parseBindingType "f :: Int -> Double" 57 | `shouldParse` 58 | ( Located (mkSpan 1 1 1 2) "f" 59 | , TyCon (mkLocated 1 6 1 9 "Int") 60 | `TyFun` 61 | TyCon (mkLocated 1 13 1 19 "Double") 62 | ) 63 | 64 | it "parses polymorphic types" $ do 65 | parse' parseBindingType "f :: forall a. a" 66 | `shouldParse` 67 | ( Located (mkSpan 1 1 1 2) "f" 68 | , TyForall [mkLocated 1 13 1 14 "a"] $ TyVar (mkLocated 1 16 1 17 "a") 69 | ) 70 | parse' parseBindingType "f :: forall a b. a -> b -> a" 71 | `shouldParse` 72 | ( Located (mkSpan 1 1 1 2) "f" 73 | , TyForall 74 | [ mkLocated 1 13 1 14 "a" 75 | , mkLocated 1 15 1 16 "b" 76 | ] $ 77 | TyVar (mkLocated 1 18 1 19 "a") 78 | `TyFun` 79 | TyVar (mkLocated 1 23 1 24 "b") 80 | `TyFun` 81 | TyVar (mkLocated 1 28 1 29 "a") 82 | ) 83 | 84 | describe "parseType" $ do 85 | it "handles simple terms" $ do 86 | parse' parseType "A" `shouldParse` TyCon (mkLocated 1 1 1 2 "A") 87 | parse' parseType "a" `shouldParse` TyVar (mkLocated 1 1 1 2 "a") 88 | 89 | it "handles terms with args" $ do 90 | parse' parseType "A a" `shouldParse` 91 | (TyCon (mkLocated 1 1 1 2 "A") `TyApp` TyVar (mkLocated 1 3 1 4 "a")) 92 | 93 | it "tightly binds constructor applications" $ do 94 | parse' parseType "A B C" `shouldParse` 95 | TyApp 96 | ( TyApp 97 | (TyCon (mkLocated 1 1 1 2 "A")) 98 | (TyCon (mkLocated 1 3 1 4 "B")) 99 | ) 100 | (TyCon (mkLocated 1 5 1 6 "C")) 101 | 102 | it "handles terms with args and parens" $ do 103 | parse' parseType "A (B b) a" `shouldParse` 104 | TyApp 105 | ( TyApp 106 | (TyCon (mkLocated 1 1 1 2 "A")) 107 | ( TyApp 108 | (TyCon (mkLocated 1 4 1 5 "B")) 109 | (TyVar (mkLocated 1 6 1 7 "b")) 110 | ) 111 | ) 112 | (TyVar (mkLocated 1 9 1 10 "a")) 113 | 114 | describe "parseType" $ do 115 | it "handles simple types" $ do 116 | parse' parseType "A" `shouldParse` TyCon (mkLocated 1 1 1 2 "A") 117 | parse' parseType "A -> B" 118 | `shouldParse` ( 119 | TyCon (mkLocated 1 1 1 2 "A") 120 | `TyFun` 121 | TyCon (mkLocated 1 6 1 7 "B") 122 | ) 123 | parse' parseType "A -> B -> C" 124 | `shouldParse` ( 125 | TyCon (mkLocated 1 1 1 2 "A") 126 | `TyFun` 127 | TyCon (mkLocated 1 6 1 7 "B") 128 | `TyFun` 129 | TyCon (mkLocated 1 11 1 12 "C") 130 | ) 131 | 132 | it "handles parens" $ do 133 | parse' parseType "(A)" `shouldParse` TyCon (mkLocated 1 2 1 3 "A") 134 | parse' parseType "((X))" `shouldParse` TyCon (mkLocated 1 3 1 4 "X") 135 | 136 | it "handles parens with functions" $ do 137 | parse' parseType "((A)) -> ((B))" 138 | `shouldParse` ( 139 | TyCon (mkLocated 1 3 1 4 "A") 140 | `TyFun` 141 | TyCon (mkLocated 1 12 1 13 "B") 142 | ) 143 | parse' parseType "(A -> B) -> C" 144 | `shouldParse` ( 145 | ( TyCon (mkLocated 1 2 1 3 "A") 146 | `TyFun` 147 | TyCon (mkLocated 1 7 1 8 "B") 148 | ) 149 | `TyFun` 150 | TyCon (mkLocated 1 13 1 14 "C") 151 | ) 152 | parse' parseType "A -> (B -> C) -> D" 153 | `shouldParse` ( 154 | TyCon (mkLocated 1 1 1 2 "A") 155 | `TyFun` 156 | ( TyCon (mkLocated 1 7 1 8 "B") 157 | `TyFun` 158 | TyCon (mkLocated 1 12 1 13 "C") 159 | ) 160 | `TyFun` 161 | TyCon (mkLocated 1 18 1 19 "D") 162 | ) 163 | 164 | it "should fail gracefully without infinite loops" $ do 165 | parse' parseType `shouldFailOn` "" 166 | parse' parseType `shouldFailOn` "()" 167 | parse' parseType `shouldFailOn` "(())" 168 | parse' parseType `shouldFailOn` "A ->" 169 | 170 | describe "expressionParens" $ do 171 | it "parses expressions in parens" $ do 172 | parse' expressionParens "(x)" `shouldParse` EParens (EVar (Typed TyUnknown (Located (mkSpan 1 2 1 3) "x"))) 173 | parse' expressionParens "(f x)" 174 | `shouldParse` 175 | EParens 176 | (EApp $ App 177 | (EVar (Typed TyUnknown (Located (mkSpan 1 2 1 3) "f"))) 178 | (EVar (Typed TyUnknown (Located (mkSpan 1 4 1 5) "x"))) 179 | TyUnknown 180 | ) 181 | 182 | describe "ifExpression" $ do 183 | it "parses if expressions" $ do 184 | parse' ifExpression "if True then 1 else 2" 185 | `shouldParse` 186 | If 187 | (ECon (Typed TyUnknown (Located (mkSpan 1 4 1 8) "True"))) 188 | (ELit (Located (mkSpan 1 14 1 15) (LiteralInt 1))) 189 | (ELit (Located (mkSpan 1 21 1 22) (LiteralInt 2))) 190 | (mkSpan 1 1 1 22) 191 | parse' ifExpression "if f x then f y else g 2" 192 | `shouldParse` 193 | If 194 | (EApp $ App (EVar (Typed TyUnknown (Located (mkSpan 1 4 1 5) "f"))) (EVar (Typed TyUnknown (Located (mkSpan 1 6 1 7) "x"))) TyUnknown) 195 | (EApp $ App (EVar (Typed TyUnknown (Located (mkSpan 1 13 1 14) "f"))) (EVar (Typed TyUnknown (Located (mkSpan 1 15 1 16) "y"))) TyUnknown) 196 | (EApp $ App (EVar (Typed TyUnknown (Located (mkSpan 1 22 1 23) "g"))) (ELit (Located (mkSpan 1 24 1 25) (LiteralInt 2))) TyUnknown) 197 | (mkSpan 1 1 1 25) 198 | 199 | describe "literal" $ do 200 | it "can discriminate between integer and double" $ do 201 | parse' literal "1" `shouldParse` Located (mkSpan 1 1 1 2) (LiteralInt 1) 202 | -- TODO: Trailing decimals? 203 | -- parse (literal <* eof) "" "2." `shouldParse` Located (mkSpan 1 1 1 2) (LiteralInt 2) 204 | parse' literal "1.5" `shouldParse` Located (mkSpan 1 1 1 4) (LiteralDouble 1.5) 205 | -------------------------------------------------------------------------------- /tests/Amy/Utils/SolveSetEquationsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Amy.Utils.SolveSetEquationsSpec 4 | ( spec 5 | ) where 6 | 7 | import Data.Set (Set) 8 | import Test.Hspec 9 | 10 | import Amy.Utils.SolveSetEquations 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "solveSetEquations" $ do 15 | it "handles no equations" $ 16 | solveSetEquations [] `shouldBe` ([] :: [(String, Set String)]) 17 | 18 | it "handles a single equation" $ 19 | solveSetEquations [SetEquation "1" ["a", "b"] []] `shouldBe` [("1", ["a", "b"])] 20 | 21 | it "handles multiple equation" $ 22 | solveSetEquations 23 | [ SetEquation "1" ["a", "b"] [] 24 | , SetEquation "2" ["b", "c"] ["1"] 25 | ] 26 | `shouldBe` 27 | [ ("1", ["a", "b"]) 28 | , ("2", ["a", "b", "c"]) 29 | ] 30 | 31 | it "handles multiple recursive equations" $ 32 | solveSetEquations 33 | [ SetEquation "1" ["a", "b"] ["2"] 34 | , SetEquation "2" ["b", "c"] ["1"] 35 | ] 36 | `shouldBe` 37 | [ ("1", ["a", "b", "c"]) 38 | , ("2", ["a", "b", "c"]) 39 | ] 40 | 41 | it "handles a lot of recursive equations" $ 42 | solveSetEquations 43 | [ SetEquation "1" ["a", "b"] ["2", "3"] 44 | , SetEquation "2" ["b", "c"] ["1", "3"] 45 | , SetEquation "3" ["d"] ["1", "2"] 46 | ] 47 | `shouldBe` 48 | [ ("1", ["a", "b", "c", "d"]) 49 | , ("2", ["a", "b", "c", "d"]) 50 | , ("3", ["a", "b", "c", "d"]) 51 | ] 52 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------