git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
swap
355eb9b116 ahead, 0 behind
32 files changed+2255−2213
since splitsnapshots
unifiedsplit
.gitignore+2 README-go.md+48 README.md+25−54 app/Main.hs+168−83 default.nix+23 package.yaml+17−14 psgo.cabal+145 runtime/dictionary.h−91 runtime/functions.h−58 runtime/purescript.cpp−59 runtime/purescript.h−242 runtime/recursion.h−92 src/CodeGen/Cpp.hs−421 src/CodeGen/Cpp/Common.hs−222 src/CodeGen/Cpp/Optimizer.hs−140 src/CodeGen/Cpp/Printer.hs−515 src/CodeGen/IL.hs+321 src/CodeGen/IL/Common.hs+196 src/CodeGen/IL/Optimizer.hs+81 src/CodeGen/IL/Optimizer/Common.hs+18 src/CodeGen/IL/Optimizer/Inliner.hs+435 src/CodeGen/IL/Optimizer/MagicDo.hs+146 src/CodeGen/Cpp/Optimizer/TCO.hs → src/CodeGen/IL/Optimizer/TCO.hs+16−18 src/CodeGen/IL/Printer.hs+527 src/Tests.hs+11−12 stack.nix+23 stack.yaml+18−63 support/Makefile−129 support/ffi-loader.go+30 support/go.mod.ffi-loader+2 support/go.mod.output+2 support/go.mod.working+1
.gitignore+2
@@ -14,8 +14,10 @@ bower_components/
1414node_modules
1515tmp/
1616.stack-work/
17+stack.yaml.lock
1718output
1819examples/docs/docs/
1920core-tests/full-core-docs.md
2021.psc-ide-port
2122.vscode/
23+result
README-go.mdnew file+48
@@ -0,0 +1,48 @@
1+
2+### psgo
3+
4+#### Performance
5+
6+* No runtime system beyond some support types and functions
7+* Uses PureScript's normal tail call optimization techniques for generated Go code
8+
9+#### Differences from PureScript:
10+
11+* Foreign imports/exports are Go instead of JavaScript – see [standard library foreign implementations](https://github.com/andyarvanitis/purescript-native-go-ffi)
12+* No Go-specific REPL
13+
14+#### Other notes:
15+
16+* The provided `Any` type is just an alias for `interface{}`
17+* PureScript types are represented in Go with:
18+
19+ | PureScript | Go |
20+ |------------|----|
21+ |`Array` | `[]Any`|
22+ |`String` | `string`|
23+ |`Number` | `float64`|
24+ |`Int` | `int`|
25+ |`Char` | `string` (single UTF-8 entity)|
26+ |`Boolean` | `bool`|
27+ |Records | `map[string]Any`|
28+
29+#### Future ideas:
30+
31+* Nice facilities (modules) for concurrency/parallelism, using goroutines
32+
33+
34+#### Getting Started
35+This assumes you are running macOS (OS X) or a Unix-like system (Linux, *BSD, etc.).
36+
37+1. Choose a working directory wherever you like. Then create a `src` subdirectory under it, which will be where you will place your own PureScript source files.
38+
39+1. Initialize your project with `spago init`, and install any dependencies with `spago install` (please see their instructions if you haven't used it before).
40+
41+1. Add the `backend = "psgo"` option to your `spago.dhall` file. That way `spago` will use the psgo backend when compiling.
42+
43+1. You should now be ready to build a PureScript program:
44+ * As stated above, place your source file(s) in the working directory's `src` subdirectory and execute `spago build`.
45+
46+ * This will generate the Go source tree for your program and then build an executable binary. The resulting executable will be in your working directory and will be named `Main`. The generated source files will be under `output/`.
47+
48+---
README.md+25−54
@@ -1,70 +1,41 @@
11[![PureScript](https://raw.githubusercontent.com/purescript/purescript/master/logo.png)](http://purescript.org)
22
3−This is an experimental C++11 (or later) compiler backend for [PureScript](https://github.com/purescript/purescript). It attempts to generate "sane", debuggable, and portable C++ code as an intermediate language, which is then compiled to a native executable binary. This enables easy interoperability with existing C/C++ frameworks and libraries on a number of platforms.
3+This is a platform-native compiler backend for [PureScript](https://github.com/purescript/purescript). It attempts to generate "sane", debuggable, and portable [C++11](https://isocpp.org/wiki/faq/cpp11) (or later) or [Go](https://golang.org/) code as an intermediate language, which is then compiled to a native executable binary. This also enables easy interoperability with existing C/C++ or Go frameworks and libraries on a number of platforms.
44
5−---
6−
7−### **Please note that this project supersedes [pure11](https://github.com/pure11/pure11) (they are no longer the same)**
8−
9−#### Please see [changes](https://github.com/andyarvanitis/purescript-native/wiki/changes) for more details.
10−
11−---
5+There are two utilities in the purescript-native "suite": `pscpp` and `psgo`. The source code in this branch is for `psgo`, the purescript-to-Go transpiler. For the source code of the `pscpp` purescript-to-C++ transpiler, please see the [cpp branch](https://github.com/andyarvanitis/purescript-native/tree/cpp).
126
137#### Platforms
14−* Generated C++ code and resulting binary executables tested (to at least some extent) on:
15− * macOS Mojave, Xcode 10.1's clang (full test suite)
16− * Windows 10 x64 and x86, Visual Studio 2017
17− * Linux Debian 9.5 amd64, default versions of clang and gcc/g++ (full test suite)
18− * Raspberry Pi 3 B+ Raspbian official build (ARM), default versions of clang and gcc/g++
19−
20−#### Performance
21−
22−* No runtime system beyond some support classes and the standard C++11 (or later) runtime library
23−* For automatic memory management, uses native C++11 reference counting (`std::shared_ptr`)
24−* Uses PureScript's normal tail call optimization techniques for generated C++ code
25−
26−#### Differences from PureScript:
27−
28−* Foreign imports/exports are C++ instead of JavaScript – see [FFI notes](https://github.com/andyarvanitis/purescript-native/wiki/FFI) and [standard library foreign implementations](https://github.com/andyarvanitis/purescript-native-ffi)
29−* No C++-specific REPL
30−
31−#### Other notes:
32−
33−* PureScript arrays are implemented using [`std::vector`](http://en.cppreference.com/w/cpp/container/vector)
34−* `String` types are implemented with C++11 `u8` literals (UTF-8) and `std::string`
35−* `Number` is C++ `double`, `Int` is C++ `int`, `Char` is `std::string` (single UTF-8 entity), `Boolean` is `bool`
36−
37−#### Future ideas:
38−
39−* Nice facilities (modules) for concurrency/parallelism, using `std::thread`, `std::async`, etc. under the hood (output is already generally thread-safe for immutable values, thanks to `std::shared_ptr`)
40−
41−#### Requirements for building the compiler itself
42−
43−* [Haskell Stack](https://docs.haskellstack.org/en/stable/README/) (if you're running macOS 10.13+, you can use pre-built binaries from [here](https://github.com/andyarvanitis/purescript-native/releases/))
44−
45−#### Requirements for using it
46−
47−* A recent version (0.12+) of [purescript](https://github.com/purescript/purescript/releases).
8+* Although purescript-native should work on any platform supporting PureScript and modern C++ or Go, the generated code and resulting binary executables have been tested on:
9+ * macOS Mojave 10.14.5 – full test suite
10+ * For C++, Xcode 10.2.1's `clang` was used
11+ * For Go, `go` version 1.12.7 was used
12+ * Windows 10 x64 – full test suite
13+ * C++: Visual Studio 2017 and `clang`
14+ * Go: `go` version 1.12.7
15+ * Linux Debian 9.5 amd64 – full test suite (C++)
16+ * Default versions of `clang` and `gcc`
17+ * Linux Debian 10 amd64 – full test suite (Go)
18+ * Default version of `go`
19+ * Raspberry Pi 3 B+ Raspbian official build (ARM), default versions of `clang` and `gcc`
4820
49−* A C++11-capable toolchain, e.g. recent versions of clang, gcc, Microsoft Visual Studio
50−* GNU Make is the default supported build tool, but you should be able to use your favorite C++ build system, tools, debuggers, etc.
5121
52−#### Getting Started
53−This assumes you are running macOS (OS X) or a Unix-like system (Linux, *BSD, etc.).
22+#### Requirements for building `pscpp` and `psgo`
5423
55−1. Make sure you have developer tools for your system installed. For macOS, you'll need a recent version of Xcode. For Linux, etc., you can use clang 3.5 or later, or gcc/g++ 4.9.2 or later.
24+* [Haskell Stack](https://docs.haskellstack.org/en/stable/README/) (if you're running macOS 10.14.5+, you can use pre-built binaries from [here](https://github.com/andyarvanitis/purescript-native/releases/))
5625
57−2. Create a working directory wherever you like, and a `src` subdirectory under it, which will be where you will place your own PureScript source files.
26+#### Requirements for using PureScript + purescript-native
5827
59−3. Under your working directory, also create an `ffi` subdirectory, which will be where you will place C/C++ FFI source files. You should at least add the contents of [purescript-native-ffi](https://github.com/andyarvanitis/purescript-native-ffi) into this directory, in addition to any of your own foreign implementations.
28+* A recent version (0.13+) of [purescript](https://github.com/purescript/purescript/releases).
6029
61−4. Generate the default GNU `Makefile` in your working directory by running `pscpp --makefile`.
30+* For `pscpp`, a C++11-capable toolchain, e.g. recent versions of clang, gcc, Microsoft Visual Studio
31+ * GNU Make + `psc-package` is the default supported build tool, but you should be able to use your favorite package manager, C++ build system, tools, debuggers, etc.
32+* For `psgo`, the [Go toolchain](https://golang.org) for your system
33+ * You can use your favorite PureScript package manager and build tools – but for simplicity, [`spago`](https://github.com/spacchetti/spago) is recommended.
6234
63−5. Use PureScript's standard [`psc-package`](https://psc-package.readthedocs.io/en/latest/) utility to add and manage package dependencies.
6435
65−6. You should now be ready to build a PureScript program:
66− * As stated above, place your source file(s) in the working directory's `src` subdirectory and execute `make debug` or `make release`. If your build machine has multiple cores, you might want to append `-jN` to your *make* command, where `N` is the number of cores.
36+#### For more information and a Getting Started guide, please see
37+* [`pscpp`](https://github.com/andyarvanitis/purescript-native/blob/cpp/README-cpp.md)
38+* [`psgo`](https://github.com/andyarvanitis/purescript-native/blob/golang/README-go.md)
6739
68− * This will generate the C++ source tree for your program and then build an executable binary. The resulting executable will be in the `bin` subdirectory under the output directory and called `main` (so `output/bin/main`, by default). Source files will be under `src` (`output/src/` by default).
6940
7041---
app/Main.hs+168−83
@@ -10,7 +10,7 @@ import Data.Aeson
1010import Data.Aeson.Types
1111import Data.Char
1212import Data.FileEmbed (embedFile)
13−import Data.List (delete, isPrefixOf, partition)
13+import Data.List (delete, intercalate, isPrefixOf, nub, partition, (\\))
1414import Data.Maybe
1515import Data.Monoid ((<>))
1616import Data.Version
@@ -19,26 +19,32 @@ import Control.Monad.Supply.Class
1919import Text.Printf
2020
2121import System.Environment
22−import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getModificationTime)
22+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, getModificationTime)
2323import System.FilePath ((</>), joinPath, splitDirectories, takeDirectory)
24+import System.FilePath.Find
25+import System.Process
2426
2527import Data.Text (Text)
2628import qualified Data.Text as T
2729import qualified Data.Text.Encoding as T
28−import qualified Data.Text.IO as T
2930import qualified Data.Text.Lazy as L
3031import qualified Data.Text.Lazy.Encoding as L
32+import qualified Data.ByteString as B
33+
34+import Development.GitRev
3135
3236import Language.PureScript.AST.Literals
3337import Language.PureScript.CoreFn
3438import Language.PureScript.CoreFn.FromJSON
3539
36−import CodeGen.Cpp
37−import CodeGen.Cpp.Common
38−import CodeGen.Cpp.Printer
40+import CodeGen.IL
41+import CodeGen.IL.Common
42+import CodeGen.IL.Printer
3943
4044import Tests
4145
46+data Command = Build | Run (Maybe String)
47+
4248parseJson :: Text -> Value
4349parseJson text
4450 | Just fileJson <- decode . L.encodeUtf8 $ L.fromStrict text = fileJson
@@ -48,118 +54,197 @@ jsonToModule :: Value -> Module Ann
4854jsonToModule value =
4955 case parse moduleFromJSON value of
5056 Success (_, r) -> r
51− _ -> error "failed"
57+ _ -> error "Failed parsing corefn. Psgo currently supports purescript <= 0.13.8"
58+
59+splitArgs :: [String] -> ([String], Maybe String, [String])
60+splitArgs args =
61+ let (opts, files) = partition (isPrefixOf "--") args
62+ opts' = (map . map) toLower opts
63+ (moduleName, files') =
64+ if null files
65+ then (Nothing, files)
66+ else
67+ if "--run" `elem` opts' && length (files) >= 1
68+ then do
69+ let file0 = head files
70+ files' = tail files
71+ case file0 of
72+ "Main.main" -> (Just "Main", files')
73+ "Test.Main.main" -> (Just "Test.Main", files')
74+ _ -> (Nothing, files)
75+ else (Nothing, files)
76+ in (opts, moduleName, files')
5277
5378main :: IO ()
5479main = do
5580 args <- getArgs
56− if null args
57− then return ()
81+ -- let (opts, files) = partition (isPrefixOf "--") args
82+ let (opts, moduleName, files) = splitArgs args
83+ opts' = (map . map) toLower opts
84+ if "--tests" `elem` opts'
85+ then runTests
5886 else do
59− let (opts, files) = partition (isPrefixOf "--") args
60− opts' = (map . map) toLower opts
61− if "--tests" `elem` opts'
62− then runTests
63− else do
64− when ("--makefile" `elem` opts') $
65− T.writeFile "Makefile" $ T.decodeUtf8 $(embedFile "support/Makefile")
66− when ("--help" `elem` opts') $
87+ if "--help" `elem` opts' || "--version" `elem` opts'
88+ then do
89+ when ("--help" `elem` opts') $ do
6790 putStrLn help
68− when (not $ null files) $ do
69− let filepath = takeDirectory (head files)
70− baseOutpath = joinPath $ (init $ splitDirectories filepath) ++ [outdir]
71− writeRuntimeFiles baseOutpath
72− Par.mapM (generateCode opts' baseOutpath) files
73− return ()
74− return ()
91+ when ("--version" `elem` opts') $ do
92+ let branch = $(gitBranch)
93+ details | branch == "golang" = "master, commit " ++ $(gitHash)
94+ | otherwise = branch
95+ putStrLn $ details ++ if $(gitDirty) then " (DIRTY)" else ""
96+ else do
97+ if null files
98+ then do
99+ currentDir <- getCurrentDirectory
100+ processFiles opts' [currentDir]
101+ else
102+ processFiles opts' files
103+ if "--run" `elem` opts
104+ then runBuildTool $ Run moduleName
105+ else when ("--no-build" `notElem` opts) $
106+ runBuildTool Build
107+ return ()
108+ where
109+ processFiles :: [String] -> [FilePath] -> IO ()
110+ processFiles opts [file] = do
111+ isDir <- doesDirectoryExist file
112+ if isDir then do
113+ files <- find always (fileName ==? corefn) file
114+ if null files
115+ then errorNoCorefnFiles
116+ else generateFiles opts files
117+ else generateFiles opts [file]
118+ processFiles opts files = do
119+ generateFiles opts files
120+ basePath :: [FilePath] -> FilePath
121+ basePath files =
122+ let filepath = takeDirectory (head files) in
123+ joinPath $ (init $ splitDirectories filepath)
124+ generateFiles :: [String] -> [FilePath] -> IO ()
125+ generateFiles opts files = do
126+ let baseOutpath = basePath files
127+ writeSupportFiles baseOutpath
128+ Par.mapM (generateCode opts baseOutpath) files
129+ return ()
130+ runBuildTool :: Command -> IO ()
131+ runBuildTool cmd = do
132+ project <- projectEnv
133+ case cmd of
134+ Build -> do
135+ callProcess "go" ["build", T.unpack project </> modPrefix' </> "Main"]
136+ Run moduleName -> do
137+ callProcess "go" ["run", T.unpack project </> modPrefix' </> fromMaybe "Main" moduleName]
138+ return ()
75139
76140generateCode :: [String] -> FilePath -> FilePath -> IO ()
77141generateCode opts baseOutpath jsonFile = do
78142 jsonModTime <- getModificationTime jsonFile
79143 let filepath = takeDirectory jsonFile
80144 dirparts = splitDirectories $ filepath
81− mname = (\c -> if c == '.' then '_' else c) <$> last dirparts
145+ mname = last dirparts
82146 basedir = joinPath $ init dirparts
83− possInterfaceFilename = basedir </> outdir </> mname </> interfaceFileName mname
84− exists <- doesFileExist possInterfaceFilename
147+ mname' = T.pack mname
148+ possibleFileName = basedir </> (T.unpack mname') </> implFileName mname'
149+ exists <- doesFileExist possibleFileName
85150 if exists
86151 then do
87− modTime <- getModificationTime possInterfaceFilename
152+ modTime <- getModificationTime possibleFileName
88153 when (modTime < jsonModTime) $
89154 transpile opts baseOutpath jsonFile
90155 else transpile opts baseOutpath jsonFile
91156
92157transpile :: [String] -> FilePath -> FilePath -> IO ()
93158transpile opts baseOutpath jsonFile = do
94− jsonText <- T.readFile jsonFile
159+ jsonText <- T.decodeUtf8 <$> B.readFile jsonFile
160+ project <- projectEnv
95161 let module' = jsonToModule $ parseJson jsonText
96− ((interface, foreigns, asts, implHeader, implFooter), _) <- runSupplyT 5 (moduleToCpp module' Nothing)
97− let mn = moduleNameToCpp $ moduleName module'
98− implementation = prettyPrintCpp asts
162+ ((_, foreigns, asts, implHeader, implFooter), _) <- runSupplyT 5 (moduleToIL module' project)
163+ let mn = moduleNameToIL' $ moduleName module'
164+ implementation = prettyPrintIL asts
99165 outpath = joinPath [baseOutpath, T.unpack mn]
100− interfacePath = outpath </> interfaceFileName (T.unpack mn)
101166 implPath = outpath </> implFileName mn
102− putStrLn interfacePath
103167 createDirectoryIfMissing True outpath
104− T.writeFile interfacePath $ conv interface
105168 putStrLn implPath
106− T.writeFile implPath $ conv (implHeader <> implementation <> implFooter)
107− where
108− conv :: Text -> Text
109− conv
110− | "--ucns" `elem` opts = toUCNs
111− | otherwise = id
169+ B.writeFile implPath $ T.encodeUtf8 (implHeader <> implementation <> implFooter)
112170
113−writeRuntimeFiles :: FilePath -> IO ()
114−writeRuntimeFiles baseOutpath = do
171+writeSupportFiles :: FilePath -> IO ()
172+writeSupportFiles baseOutpath = do
173+ currentDir <- getCurrentDirectory
174+ let outputdir = T.pack $ baseOutpath \\ currentDir
175+ ffiOutpath = currentDir </> subdir
115176 createDirectoryIfMissing True baseOutpath
116− let runtimeHeader = baseOutpath </> "purescript.h"
117− runtimeSource = baseOutpath </> "purescript.cpp"
118− fn = baseOutpath </> "functions.h"
119− dict = baseOutpath </> "dictionary.h"
120− recur = baseOutpath </> "recursion.h"
121− runtimeExists <- doesFileExist runtimeHeader
122− when (not runtimeExists) $ do
123− T.writeFile runtimeHeader $ T.decodeUtf8 $(embedFile "runtime/purescript.h")
124− T.writeFile runtimeSource $ T.decodeUtf8 $(embedFile "runtime/purescript.cpp")
125− T.writeFile fn $ T.decodeUtf8 $(embedFile "runtime/functions.h")
126− T.writeFile dict $ T.decodeUtf8 $(embedFile "runtime/dictionary.h")
127− T.writeFile recur $ T.decodeUtf8 $(embedFile "runtime/recursion.h")
128−
129−outdir :: FilePath
130−outdir = "src"
131−
132−interfaceFileName :: String -> FilePath
133−interfaceFileName mn = mn <> ".h"
134−
135−implFileName :: Text -> FilePath
136−implFileName mn = T.unpack $ mn <> ".cpp"
137−
138−escape :: Text -> Text
139−escape = T.concatMap go
177+ createDirectoryIfMissing True ffiOutpath
178+ writeModuleFile outputdir currentDir $(embedFile "support/go.mod.working")
179+ writeModuleFile outputdir baseOutpath $(embedFile "support/go.mod.output")
180+ writeModuleFile outputdir ffiOutpath $(embedFile "support/go.mod.ffi-loader")
181+ writeLoaderFile ffiOutpath $(embedFile "support/ffi-loader.go")
140182 where
141− go :: Char -> Text
142− go c = T.pack $ printf "0x%04x," (ord c)
143−
183+ writeModuleFile :: Text -> FilePath -> B.ByteString -> IO ()
184+ writeModuleFile outputdir path modText = do
185+ let goModSource = path </> "go.mod"
186+ goModSourceExists <- doesFileExist goModSource
187+ when (not goModSourceExists) $ do
188+ project <- projectEnv
189+ let project' = T.unpack project
190+ outputdir' = tail $ T.unpack outputdir
191+ modText' = T.replace "$PROJECT" project $ T.decodeUtf8 modText
192+ replaceLoader = project' </> ffiLoader' <> "=." </> subdir
193+ replaceOutput = project' </> modPrefix' <> "=." </> outputdir'
194+ B.writeFile goModSource $ T.encodeUtf8 modText'
195+ callProcess "go" ["mod", "edit", "-replace", replaceLoader]
196+ callProcess "go" ["mod", "edit", "-replace", replaceOutput]
197+ callProcess "go" ["clean", "-modcache"]
198+ writeLoaderFile :: FilePath -> B.ByteString -> IO ()
199+ writeLoaderFile ffiOutpath loaderText = do
200+ let loaderSource = ffiOutpath </> "ffi_loader.go"
201+ loaderSourceExists <- doesFileExist loaderSource
202+ when (not loaderSourceExists) $ do
203+ B.writeFile loaderSource loaderText
144204
145−toUCNs :: Text -> Text
146−toUCNs = T.pack . concatMap toUCN . T.unpack
205+implFileName :: Text -> FilePath
206+implFileName mn = ((\c -> if c == '.' then '_' else c) <$> T.unpack mn) <> ".go"
147207
148−toUCN :: Char -> String
149−toUCN c | isAscii c = [c]
150−toUCN c = printf "\\U%08x" $ ord c
208+projectEnv :: IO Text
209+projectEnv = do
210+ T.pack . fromMaybe defaultProject <$> lookupEnv goproject
151211
152212help :: String
153−help = "Usage: pscpp OPTIONS COREFN-FILES\n\
154− \ PureScript-to-C++ compiler\n\n\
213+help = "Usage: psgo OPTIONS COREFN-FILES\n\
214+ \ PureScript to native (via go) compiler\n\n\
155215 \Available options:\n\
156216 \ --help Show this help text\n\n\
157− \ --makefile Generate a GNU Makefile which can be used for compiling\n\
158− \ a PureScript program and libraries to a native binary via\n\
159− \ purs corefn output and C++\n\n\
160− \ --ucns Use UCN encoding of unicode characters in literals and\n\
161− \ strings in generated C++ code (for compilers that do not\n\
162− \ support unicode literals, such as gcc)\n\n\
217+ \ --version Show the version number\n\n\
218+ \ --run Run the generated go code directly, without building an\n\
219+ \ executable\n\
220+ \ --no-build Generate go source files, but do not build an executable\n\
163221 \ --tests Run test cases (under construction)\n\n\
164222 \See also:\n\
165223 \ purs compile --help\n"
224+
225+corefn :: String
226+corefn = "corefn.json"
227+
228+goSrc :: String
229+goSrc = ".go"
230+
231+goproject :: String
232+goproject = "GOPROJECT"
233+
234+defaultProject :: String
235+defaultProject = "project.localhost"
236+
237+modPrefix' :: String
238+modPrefix' = T.unpack modPrefix
239+
240+ffiLoader' :: String
241+ffiLoader' = T.unpack ffiLoader
242+
243+subdir :: String
244+subdir = T.unpack modLabel
245+
246+errorNoCorefnFiles :: IO ()
247+errorNoCorefnFiles = do
248+ ioError . userError $ "no compiled purescript '" <> corefn <> "' files found –\n" <>
249+ " make sure to use the '--codegen corefn' option with your purs\n" <>
250+ " project build tool"
default.nixnew file+23
@@ -0,0 +1,23 @@
1+let
2+ haskellNix = import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz) {};
3+ nixpkgsSrc = haskellNix.sources.nixpkgs-1903; # has hsc2hs-0.68.4
4+
5+ hsc2hsOverlay = self: super: {
6+ buildPackages = super.buildPackages // {
7+ hsc2hs = super.haskellPackages.hsc2hs;
8+ };
9+ };
10+
11+ nixpkgsArgs = haskellNix.nixpkgsArgs // {
12+ overlays = haskellNix.nixpkgsArgs.overlays ++ [ hsc2hsOverlay ];
13+ };
14+in
15+{ pkgs ? import nixpkgsSrc nixpkgsArgs
16+}:
17+
18+pkgs.haskell-nix.stackProject {
19+ src = pkgs.haskell-nix.haskellLib.cleanGit {
20+ name = "purescript-native";
21+ src = ./.;
22+ };
23+}
package.yaml+17−14
@@ -1,6 +1,6 @@
1−name: pscpp
1+name: psgo
22version: 0.1.0.0
3−github: "andyarvanitis/purescript-cpp"
3+github: "andyarvanitis/purescript-native"
44license: BSD3
55author: "Andy Arvanitis"
66maintainer: "example@example.com"
@@ -9,8 +9,8 @@ copyright: "2018 Andy Arvanitis"
99extra-source-files:
1010- README.md
1111- ChangeLog.md
12−- runtime/*.h
13−- runtime/*.cpp
12+- stack.yaml
13+- support/*
1414
1515# Metadata used when publishing your package
1616# synopsis: Short description of your package
@@ -19,11 +19,12 @@ extra-source-files:
1919# To avoid duplicated efforts in documentation and dealing with the
2020# complications of embedding Haddock markup inside cabal files, it is
2121# common to point users to the README.md file.
22−description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-cpp#readme>
22+description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>
2323
2424dependencies:
2525- base >= 4.7 && < 5
26−- purescript -any
26+- bytestring >= 0.10.8.2 && < 0.11
27+- purescript
2728- base-compat >=0.6.0
2829- protolude >=0.1.6
2930- text
@@ -34,10 +35,12 @@ dependencies:
3435- safe >=0.3.9 && <0.4
3536- transformers >=0.3.0 && <0.6
3637- mtl >=2.1.0 && <2.3.0
37−- aeson >=1.0 && <1.4
38−- directory -any
39−- process -any
40−- file-embed -any
38+- aeson >=1.0 && <1.5
39+- directory
40+- process
41+- file-embed
42+- filemanip
43+- gitrev
4144
4245library:
4346 source-dirs: src
@@ -61,7 +64,7 @@ library:
6164 - ViewPatterns
6265
6366executables:
64− pscpp:
67+ psgo:
6568 main: Main.hs
6669 source-dirs: app
6770 ghc-options:
@@ -69,10 +72,10 @@ executables:
6972 - -rtsopts
7073 - -with-rtsopts=-N
7174 dependencies:
72− - pscpp
75+ - psgo
7376
7477tests:
75− pscpp-test:
78+ psgo-test:
7679 main: Spec.hs
7780 source-dirs: test
7881 ghc-options:
@@ -80,4 +83,4 @@ tests:
8083 - -rtsopts
8184 - -with-rtsopts=-N
8285 dependencies:
83− - pscpp
86+ - psgo
psgo.cabalnew file+145
@@ -0,0 +1,145 @@
1+cabal-version: 1.12
2+
3+-- This file has been generated from package.yaml by hpack version 0.35.0.
4+--
5+-- see: https://github.com/sol/hpack
6+
7+name: psgo
8+version: 0.1.0.0
9+description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>
10+homepage: https://github.com/andyarvanitis/purescript-native#readme
11+bug-reports: https://github.com/andyarvanitis/purescript-native/issues
12+author: Andy Arvanitis
13+maintainer: example@example.com
14+copyright: 2018 Andy Arvanitis
15+license: BSD3
16+license-file: LICENSE
17+build-type: Simple
18+extra-source-files:
19+ README.md
20+ ChangeLog.md
21+ stack.yaml
22+ support/ffi-loader.go
23+ support/go.mod.ffi-loader
24+ support/go.mod.output
25+ support/go.mod.working
26+
27+source-repository head
28+ type: git
29+ location: https://github.com/andyarvanitis/purescript-native
30+
31+library
32+ exposed-modules:
33+ CodeGen.IL
34+ CodeGen.IL.Common
35+ CodeGen.IL.Optimizer
36+ CodeGen.IL.Optimizer.Common
37+ CodeGen.IL.Optimizer.Inliner
38+ CodeGen.IL.Optimizer.MagicDo
39+ CodeGen.IL.Optimizer.TCO
40+ CodeGen.IL.Printer
41+ Tests
42+ other-modules:
43+ Paths_psgo
44+ hs-source-dirs:
45+ src
46+ default-extensions:
47+ ConstraintKinds
48+ DataKinds
49+ DeriveFunctor
50+ EmptyDataDecls
51+ FlexibleContexts
52+ KindSignatures
53+ LambdaCase
54+ MultiParamTypeClasses
55+ NoImplicitPrelude
56+ PatternGuards
57+ PatternSynonyms
58+ RankNTypes
59+ RecordWildCards
60+ OverloadedStrings
61+ ScopedTypeVariables
62+ TupleSections
63+ ViewPatterns
64+ build-depends:
65+ aeson >=1.0 && <1.5
66+ , base >=4.7 && <5
67+ , base-compat >=0.6.0
68+ , bytestring >=0.10.8.2 && <0.11
69+ , containers
70+ , directory
71+ , file-embed
72+ , filemanip
73+ , filepath
74+ , gitrev
75+ , monad-parallel >=0.7.2.2 && <0.8
76+ , mtl >=2.1.0 && <2.3.0
77+ , pattern-arrows >=0.0.2 && <0.1
78+ , process
79+ , protolude >=0.1.6
80+ , purescript
81+ , safe >=0.3.9 && <0.4
82+ , text
83+ , transformers >=0.3.0 && <0.6
84+ default-language: Haskell2010
85+
86+executable psgo
87+ main-is: Main.hs
88+ other-modules:
89+ Paths_psgo
90+ hs-source-dirs:
91+ app
92+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
93+ build-depends:
94+ aeson >=1.0 && <1.5
95+ , base >=4.7 && <5
96+ , base-compat >=0.6.0
97+ , bytestring >=0.10.8.2 && <0.11
98+ , containers
99+ , directory
100+ , file-embed
101+ , filemanip
102+ , filepath
103+ , gitrev
104+ , monad-parallel >=0.7.2.2 && <0.8
105+ , mtl >=2.1.0 && <2.3.0
106+ , pattern-arrows >=0.0.2 && <0.1
107+ , process
108+ , protolude >=0.1.6
109+ , psgo
110+ , purescript
111+ , safe >=0.3.9 && <0.4
112+ , text
113+ , transformers >=0.3.0 && <0.6
114+ default-language: Haskell2010
115+
116+test-suite psgo-test
117+ type: exitcode-stdio-1.0
118+ main-is: Spec.hs
119+ other-modules:
120+ Paths_psgo
121+ hs-source-dirs:
122+ test
123+ ghc-options: -threaded -rtsopts -with-rtsopts=-N
124+ build-depends:
125+ aeson >=1.0 && <1.5
126+ , base >=4.7 && <5
127+ , base-compat >=0.6.0
128+ , bytestring >=0.10.8.2 && <0.11
129+ , containers
130+ , directory
131+ , file-embed
132+ , filemanip
133+ , filepath
134+ , gitrev
135+ , monad-parallel >=0.7.2.2 && <0.8
136+ , mtl >=2.1.0 && <2.3.0
137+ , pattern-arrows >=0.0.2 && <0.1
138+ , process
139+ , protolude >=0.1.6
140+ , psgo
141+ , purescript
142+ , safe >=0.3.9 && <0.4
143+ , text
144+ , transformers >=0.3.0 && <0.6
145+ default-language: Haskell2010
runtime/dictionary.hdeleted−91
@@ -1,91 +0,0 @@
1−///////////////////////////////////////////////////////////////////////////////
2−//
3−// Module : dictionary.h
4−// Copyright : (c) Andy Arvanitis 2018
5−// License : BSD
6−//
7−// Maintainer : Andy Arvanitis
8−// Stability : experimental
9−// Portability :
10−//
11−// A simple dictionary optimized for this runtime's particular use –
12−// *not* intended for general use or as a replacement for containers
13−// such as std::map or std::unordered_map. It relies on the following
14−// assumptions:
15−//
16−// 1) Keys are C-type string literals. No copying or (memory management)
17−// of the keys occurs
18−// 2) The number of elements in the container is generally small – say,
19−// under 20. There is no sorting and a linear search is used to
20−// locate elements
21−//
22−///////////////////////////////////////////////////////////////////////////////
23−//
24−#ifndef purescript_dictionary_H
25−#define purescript_dictionary_H
26−
27−#include <cstring>
28−#include <vector>
29−#include <utility>
30−#if !defined(NDEBUG)
31−#include <string>
32−#endif
33−
34−namespace purescript {
35− namespace _template_ {
36−
37− template <typename T>
38− class dict_t : public std::vector<std::pair<const char *, T>> {
39−
40− static auto null() -> const T& {
41− static const T value;
42− return value;
43− }
44−
45− public:
46− using std::vector<std::pair<const char *, T>>::vector;
47−
48− auto operator[](const char key[]) const -> const T& {
49− for (auto it = this->cbegin(), end=this->cend(); it != end; it++) {
50− const auto& elem_key = it->first;
51− if (elem_key == key || !std::strcmp(elem_key, key)) {
52− return it->second;
53− }
54− }
55−#if !defined(NDEBUG) && !defined(PURESCRIPT_DISABLE_EXCEPTIONS)
56− throw std::runtime_error("dictionary key \"" + std::string(key) + "\" not found");
57−#endif
58− return null();
59− }
60−
61− auto at(const char key[]) const -> const T& {
62− return (*this)[key];
63− }
64−
65− auto operator[](const char key[]) -> T& {
66− const auto end = this->end();
67− for (auto it = this->begin(); it != end; it++) {
68− const auto& elem_key = it->first;
69− if (elem_key == key || !std::strcmp(elem_key, key)) {
70− return it->second;
71− }
72− }
73− return this->emplace(end, key, T())->second;
74− }
75−
76− auto contains(const char key[]) const -> bool {
77− for (auto it = this->cbegin(), end=this->cend(); it != end; it++) {
78− const auto& elem_key = it->first;
79− if (elem_key == key || !std::strcmp(elem_key, key)) {
80− return true;
81− }
82− }
83− return false;
84− }
85−
86− };
87−
88− } // namespace _template_
89−} // namespace purescript
90−
91−#endif // purescript_dictionary_H
runtime/functions.hdeleted−58
@@ -1,58 +0,0 @@
1−///////////////////////////////////////////////////////////////////////////////
2−//
3−// Module : functions.h
4−// Copyright : (c) Andy Arvanitis 2019
5−// License : BSD
6−//
7−// Maintainer : Andy Arvanitis
8−// Stability : experimental
9−// Portability :
10−//
11−// Runtime function types (for regular functions and lambdas)
12−//
13−///////////////////////////////////////////////////////////////////////////////
14−//
15−#ifndef purescript_functions_H
16−#define purescript_functions_H
17−
18−namespace purescript {
19− namespace _template_ {
20−
21− template <typename T>
22− class fn_t {
23− public:
24− virtual ~fn_t() {}
25− virtual auto operator ()(const T&) const -> T = 0;
26− };
27−
28− template <typename T, typename U>
29− class fn_T : public fn_t<T> {
30− U fn;
31− public:
32− fn_T(U f) noexcept : fn(std::move(f)) {}
33− auto operator ()(const T& arg) const -> T override {
34− return fn(arg);
35− }
36− };
37−
38− template <typename T>
39− class eff_fn_t {
40− public:
41− virtual ~eff_fn_t() {}
42− virtual auto operator ()() const -> T = 0;
43− };
44−
45− template <typename T, typename U>
46− class eff_fn_T : public eff_fn_t<T> {
47− U fn;
48− public:
49− eff_fn_T(U f) noexcept : fn(std::move(f)) {}
50− auto operator ()() const -> T override {
51− return fn();
52− }
53− };
54−
55− } // namespace _template_
56−} // namespace purescript
57−
58−#endif // purescript_functions_H
runtime/purescript.cppdeleted−59
@@ -1,59 +0,0 @@
1−///////////////////////////////////////////////////////////////////////////////
2−//
3−// Module : purescript.cpp
4−// Copyright : (c) Andy Arvanitis 2019
5−// License : BSD
6−//
7−// Maintainer : Andy Arvanitis
8−// Stability : experimental
9−// Portability :
10−//
11−// Basic types and functions to support purescript-to-C++ rendering
12−//
13−///////////////////////////////////////////////////////////////////////////////
14−//
15−#include "purescript.h"
16−
17−namespace purescript {
18−
19−template class _template_::fn_t<boxed>;
20−template class _template_::eff_fn_t<boxed>;
21−template class _template_::dict_t<boxed>;
22−template class _template_::weak<boxed>;
23−template class _template_::recur<boxed>;
24−
25−boxed::boxed(const long n) : _int_(static_cast<int>(n)) {
26−#if !defined(NDEBUG) && !defined(PURESCRIPT_DISABLE_EXCEPTIONS)
27− if (n < std::numeric_limits<int>::min() || n > std::numeric_limits<int>::max()) {
28− throw std::runtime_error("integer out of range");
29− }
30−#endif
31−}
32−
33−boxed::boxed(const unsigned long n) : _int_(static_cast<int>(n)) {
34−#if !defined(NDEBUG) && !defined(PURESCRIPT_DISABLE_EXCEPTIONS)
35− if (n > std::numeric_limits<int>::max()) {
36− throw std::runtime_error("integer out of range");
37− }
38−#endif
39−}
40−
41−auto boxed::operator[](const int index) const -> const boxed& {
42−#if !defined(NDEBUG)
43− return static_cast<const array_t*>(shared.get())->at(index);
44−#else
45− return (*static_cast<const array_t*>(shared.get()))[index];
46−#endif
47−}
48−
49−auto boxed::operator[](const int index) -> boxed& {
50−#if !defined(NDEBUG)
51− return static_cast<array_t*>(shared.get())->at(index);
52−#else
53− return (*static_cast<array_t*>(shared.get()))[index];
54−#endif
55−}
56−
57−const boxed undefined;
58−
59−} // namespace purescript
runtime/purescript.hdeleted−242
@@ -1,242 +0,0 @@
1−///////////////////////////////////////////////////////////////////////////////
2−//
3−// Module : purescript.h
4−// Copyright : (c) Andy Arvanitis 2018
5−// License : BSD
6−//
7−// Maintainer : Andy Arvanitis
8−// Stability : experimental
9−// Portability :
10−//
11−// Basic types and functions to support purescript-to-C++ rendering
12−//
13−///////////////////////////////////////////////////////////////////////////////
14−//
15−#ifndef purescript_H
16−#define purescript_H
17−
18−#include <memory>
19−#include <vector>
20−#include <string>
21−#include <utility>
22−#if !defined(NDEBUG)
23−#include <limits>
24−#endif
25−#if !defined(PURESCRIPT_DISABLE_EXCEPTIONS)
26−#include <stdexcept>
27−#endif
28−#include "functions.h"
29−#include "dictionary.h"
30−#include "recursion.h"
31−
32−namespace purescript {
33−
34− using std::string;
35−
36− class boxed {
37− public:
38− std::shared_ptr<void> shared;
39− union {
40− int _int_;
41− double _double_;
42− bool _bool_;
43− };
44−
45− public:
46− using fn_t = _template_::fn_t<boxed>;
47− using eff_fn_t = _template_::eff_fn_t<boxed>;
48−
49− using dict_t = _template_::dict_t<boxed>;
50− using array_t = std::vector<boxed>;
51−
52− using weak = _template_::weak<boxed>;
53− using recur = _template_::recur<boxed>;
54−
55− private:
56− template <typename T>
57− using fn_T = _template_::fn_T<boxed, T>;
58−
59− template <typename T>
60− using eff_fn_T = _template_::eff_fn_T<boxed, T>;
61−
62− public:
63− boxed() noexcept : shared() {}
64− boxed(const std::nullptr_t) noexcept : shared() {}
65−
66− boxed(const weak& w) : shared(w.shared()) {}
67− boxed(const recur& r) : shared(r.shared()) {}
68− boxed(const recur::weak& w) : shared(w.shared()) {}
69−
70− template <typename T>
71− boxed(std::shared_ptr<T>&& other) noexcept : shared(std::move(other)) {}
72−
73− template <typename T>
74− boxed(const std::shared_ptr<T>& other) : shared(other) {}
75−
76− boxed(const int n) noexcept : _int_(n) {}
77− boxed(const long n);
78− boxed(const unsigned long n);
79− boxed(const double n) noexcept : _double_(n) {}
80− boxed(const bool b) noexcept : _bool_(b) {}
81− boxed(const char s[]) : shared(std::make_shared<string>(s)) {}
82− boxed(string&& s) : shared(std::make_shared<string>(std::move(s))) {}
83− boxed(const string& s) : shared(std::make_shared<string>(s)) {}
84− boxed(array_t&& l) : shared(std::make_shared<array_t>(std::move(l))) {}
85− boxed(const array_t& l) : shared(std::make_shared<array_t>(l)) {}
86− boxed(dict_t&& m) : shared(std::make_shared<dict_t>(std::move(m))) {}
87− boxed(const dict_t& m) : shared(std::make_shared<dict_t>(m)) {}
88−
89− template <typename T,
90− typename = typename std::enable_if<!std::is_same<boxed,T>::value>::type>
91− boxed(T f,
92− typename std::enable_if<std::is_same<decltype(std::declval<T>()(std::declval<boxed>())),
93− boxed>::value>::type* = 0)
94− : shared(std::shared_ptr<fn_t>(std::make_shared<fn_T<T>>(std::move(f)))) {
95− }
96−
97− template <typename T,
98− typename = typename std::enable_if<!std::is_same<boxed,T>::value>::type>
99− boxed(T f,
100− typename std::enable_if<std::is_same<decltype(std::declval<T>()()),
101− boxed>::value>::type* = 0)
102− : shared(std::shared_ptr<eff_fn_t>(std::make_shared<eff_fn_T<T>>(std::move(f)))) {
103− }
104−
105− auto get() const noexcept -> void * {
106− return shared.get();
107− }
108−
109− auto operator()(const boxed& arg) const -> boxed {
110− return (*static_cast<fn_t*>(shared.get()))(arg);
111− }
112−
113− auto operator()() const -> boxed {
114− return (*static_cast<eff_fn_t*>(shared.get()))();
115− }
116−
117− auto operator[](const char key[]) const -> const boxed& {
118− return (*static_cast<const dict_t*>(shared.get()))[key];
119− }
120−
121− auto operator[](const char key[]) -> boxed& {
122− return (*static_cast<dict_t*>(shared.get()))[key];
123− }
124−
125− auto operator[](const int index) const -> const boxed&;
126− auto operator[](const int index) -> boxed&;
127−
128− }; // class boxed
129−
130− extern template class _template_::fn_t<boxed>;
131− extern template class _template_::eff_fn_t<boxed>;
132− extern template class _template_::dict_t<boxed>;
133− extern template class _template_::weak<boxed>;
134− extern template class _template_::recur<boxed>;
135−
136− extern const boxed undefined;
137−
138− using fn_t = boxed::fn_t;
139− using eff_fn_t = boxed::eff_fn_t;
140− using dict_t = boxed::dict_t;
141− using array_t = boxed::array_t;
142−
143− template <typename T, typename... Args,
144− typename = typename std::enable_if<!std::is_same<T, int>::value &&
145− !std::is_same<T, double>::value &&
146− !std::is_same<T, bool>::value
147− >::type>
148− inline auto box(Args&&... args) -> boxed {
149− return std::make_shared<T>(std::forward<Args>(args)...);
150− }
151−
152− template <typename T,
153− typename std::enable_if<std::is_same<T, int>::value, T>::type* = nullptr>
154− inline auto box(T arg) noexcept -> boxed {
155− return boxed(arg);
156− }
157−
158− template <typename T,
159− typename std::enable_if<std::is_same<T, double>::value, T>::type* = nullptr>
160− inline auto box(T arg) noexcept -> boxed {
161− return boxed(arg);
162− }
163−
164− template <typename T,
165− typename std::enable_if<std::is_same<T, bool>::value, T>::type* = nullptr>
166− inline auto box(T arg) noexcept -> boxed {
167− return boxed(arg);
168− }
169−
170− template <typename T,
171− typename = typename std::enable_if<!std::is_same<T, int>::value &&
172− !std::is_same<T, double>::value &&
173− !std::is_same<T, bool>::value
174− >::type>
175− constexpr auto unbox(const boxed& b) -> const T& {
176− return *static_cast<const T*>(b.get());
177− }
178−
179− template <typename T,
180− typename std::enable_if<std::is_same<T, int>::value, T>::type* = nullptr>
181− constexpr auto unbox(const boxed& b) noexcept -> T {
182− return b._int_;
183− }
184−
185− template <typename T,
186− typename std::enable_if<std::is_same<T, double>::value, T>::type* = nullptr>
187− constexpr auto unbox(const boxed& b) noexcept -> T {
188− return b._double_;
189− }
190−
191− template <typename T,
192− typename std::enable_if<std::is_same<T, bool>::value, T>::type* = nullptr>
193− constexpr auto unbox(const boxed& b) noexcept -> T {
194− return b._bool_;
195− }
196−
197− template <typename T,
198− typename = typename std::enable_if<!std::is_same<T, int>::value &&
199− !std::is_same<T, double>::value &&
200− !std::is_same<T, bool>::value
201− >::type>
202− constexpr auto unbox(boxed& b) -> T& {
203− return *static_cast<T*>(b.get());
204− }
205−
206− template <typename T>
207− constexpr auto unbox(const T value) noexcept -> T {
208− return value;
209− }
210−
211− template <typename T,
212− typename = typename std::enable_if<std::is_same<T, int>::value>::type>
213− constexpr auto unbox(const std::size_t value) noexcept -> long long {
214− return value;
215− }
216−
217− inline auto array_length(const boxed& a) -> boxed::array_t::size_type {
218− return unbox<boxed::array_t>(a).size();
219− }
220−
221−} // namespace purescript
222−
223−#if !defined(PURESCRIPT_DISABLE_EXCEPTIONS)
224−#define THROW_(e) throw std::runtime_error(s)
225−#else
226−#define THROW_(e) return undefined
227−#endif
228−
229−#define DEFINE_FOREIGN_DICTIONARY_AND_ACCESSOR() \
230− inline auto foreign() -> dict_t& {\
231− static dict_t _;\
232− return _;\
233− }
234−
235−#define FOREIGN_BEGIN(NS) namespace NS {\
236− using namespace purescript;\
237− DEFINE_FOREIGN_DICTIONARY_AND_ACCESSOR()\
238− static const auto data = ([]() -> char {\
239− dict_t& exports = foreign();
240−#define FOREIGN_END return 0; }()); }
241−
242−#endif // purescript_H
runtime/recursion.hdeleted−92
@@ -1,92 +0,0 @@
1−///////////////////////////////////////////////////////////////////////////////
2−//
3−// Module : recursion.h
4−// Copyright : (c) Andy Arvanitis 2019
5−// License : BSD
6−//
7−// Maintainer : Andy Arvanitis
8−// Stability : experimental
9−// Portability :
10−//
11−// Runtime types to support recursion
12−//
13−///////////////////////////////////////////////////////////////////////////////
14−//
15−#ifndef purescript_recursion_H
16−#define purescript_recursion_H
17−
18−#include <memory>
19−
20−namespace purescript {
21−
22− namespace _template_ {
23−
24− template <typename T>
25− class weak {
26− std::weak_ptr<void> wptr;
27−
28− public:
29− weak() = delete;
30− weak(T& b) : wptr(b.shared) {}
31−
32− auto shared() const -> std::shared_ptr<void> {
33−#if defined(NDEBUG)
34− return wptr.lock();
35−#else
36− return static_cast<std::shared_ptr<void>>(wptr);
37−#endif
38− }
39−
40− }; // class weak
41−
42− template <typename T>
43− class recur {
44− std::shared_ptr<T> sptr;
45− std::shared_ptr<typename T::weak> wptr;
46−
47− public:
48− recur() : sptr(std::make_shared<T>())
49− , wptr(std::make_shared<typename T::weak>(*sptr)) {}
50−
51− auto shared() const -> std::shared_ptr<void> {
52− return sptr->shared;
53− }
54−
55− auto operator()() const -> T {
56− return (*sptr)();
57− }
58−
59− auto operator()(const T& arg) const -> T {
60− return (*sptr)(arg);
61− }
62−
63− template <typename U>
64− auto operator=(U&& right) -> recur& {
65− *sptr = std::forward<U>(right);
66− *wptr = *sptr;
67− return *this;
68− }
69−
70− class weak {
71− std::shared_ptr<typename T::weak> wptr;
72− public:
73− weak(const recur& r) : wptr(r.wptr) {}
74−
75− auto shared() const -> std::shared_ptr<void> {
76− return wptr->shared();
77− }
78−
79− auto operator()() const -> T {
80− return static_cast<T>(*wptr)();
81− }
82−
83− auto operator()(const T& arg) const -> T {
84− return static_cast<T>(*wptr)(arg);
85− }
86− }; // class recur::weak
87− }; // class recur
88−
89− } // namespace _template_
90−} // namespace purescript
91−
92−#endif // purescript_recursion_H
src/CodeGen/Cpp.hsdeleted−421
@@ -1,421 +0,0 @@
1−-- | This module generates code in the core imperative representation from
2−-- elaborated PureScript code.
3−module CodeGen.Cpp
4− ( module AST
5− , module Common
6− , moduleToCpp
7− ) where
8−
9−import Prelude.Compat
10−import Protolude (ordNub)
11−
12−import Control.Arrow ((&&&))
13−import Control.Monad (forM, liftM, replicateM, void)
14−import Control.Monad.Supply.Class
15−
16−import Data.List ((\\), delete, intersect, nub)
17−import qualified Data.Foldable as F
18−import qualified Data.Map as M
19−import Data.Maybe (fromMaybe, isNothing, mapMaybe)
20−import Data.Monoid ((<>))
21−import Data.String (fromString)
22−import Data.Text (Text)
23−import qualified Data.Text as T
24−
25−import Language.PureScript.AST.SourcePos
26−import Language.PureScript.CoreImp.AST (AST)
27−import qualified Language.PureScript.CoreImp.AST as AST
28−import Language.PureScript.CoreFn
29−import Language.PureScript.Crash
30−import Language.PureScript.Names
31−import Language.PureScript.Options
32−import Language.PureScript.PSString (PSString, mkString)
33−import Language.PureScript.Traversals (sndM)
34−import qualified Language.PureScript.Constants as C
35−
36−import System.FilePath.Posix ((</>))
37−
38−import CodeGen.Cpp.Common as Common
39−import CodeGen.Cpp.Optimizer
40−import CodeGen.Cpp.Printer
41−
42−data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)
43−
44−-- | Generate code in the simplified intermediate representation for all declarations in a
45−-- module.
46−moduleToCpp
47− :: forall m
48− -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
49− . (Monad m, MonadSupply m)
50− => Module Ann
51− -> Maybe AST
52− -> m (Text, [Text], [AST], Text, Text)
53−moduleToCpp (Module _ coms mn _ imps _ foreigns decls) _ =
54− do
55− let usedNames = concatMap getNames decls
56− let mnLookup = renameImports usedNames imps
57− cppImports <- traverse (importToCpp mnLookup) . (\\ (mn : C.primModules)) . (\\ [mn]) $ ordNub $ map snd imps
58− interfaceImport <- importToCpp (renameImports [] [(emptyAnn, mn)]) mn
59− let decls' = renameModules mnLookup decls
60− cppDecls <- mapM (bindToCpp ModuleDecl) decls'
61− optimized <- traverse (traverse (optimize modName')) cppDecls
62− let optimized' = concat optimized
63− values = annotValue <$> optimized'
64− foreigns' = identToCpp <$> foreigns
65− interface = interfaceSource modName values foreigns
66− implHeader = implHeaderSource modName cppImports interfaceImport
67− implFooter = implFooterSource modName foreigns
68− return $ (interface, foreigns', optimized', implHeader, implFooter)
69− where
70− modName = moduleNameToCpp mn
71− modName' = AST.Var Nothing modName
72−
73− annotValue :: AST -> (Text, Bool)
74− annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))
75− | isLiteral ret = (name, True)
76− annotValue (AST.Function _ (Just name) [] _) = (name, False)
77− annotValue _ = error "Unexpected top-level value form"
78−
79− -- | Extracts all declaration names from a binding group.
80− getNames :: Bind Ann -> [Ident]
81− getNames (NonRec _ ident _) = [ident]
82− getNames (Rec vals) = map (snd . fst) vals
83−
84− -- | Creates alternative names for each module to ensure they don't collide
85− -- with declaration names.
86− renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
87− renameImports = go M.empty
88− where
89− go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
90− go acc used ((ann, mn') : mns') =
91− let mni = Ident $ runModuleName mn'
92− in if mn' /= mn && mni `elem` used
93− then let newName = freshModuleName 1 mn' used
94− in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'
95− else go (M.insert mn' (ann, mn') acc) used mns'
96− go acc _ [] = acc
97−
98− freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
99− freshModuleName i mn'@(ModuleName pns) used =
100− let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) <> "_" <> T.pack (show i)]
101− in if Ident (runModuleName newName) `elem` used
102− then freshModuleName (i + 1) mn' used
103− else newName
104−
105− -- | Generates C++ code for a module import, binding the required module
106− -- to the alternative
107− importToCpp :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m Text
108− importToCpp mnLookup mn' = do
109− let ((_, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
110− mname = moduleNameToCpp mnSafe
111− pure $ "#include \"" <> mname <> "/" <> mname <> ".h\"\n"
112−
113− -- | Replaces the `ModuleName`s in the AST so that the generated code refers to
114− -- the collision-avoiding renamed module imports.
115− renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]
116− renameModules mnLookup binds =
117− let (f, _, _) = everywhereOnValues id goExpr goBinder
118− in map f binds
119− where
120− goExpr :: Expr a -> Expr a
121− goExpr (Var ann q) = Var ann (renameQual q)
122− goExpr e = e
123− goBinder :: Binder a -> Binder a
124− goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs
125− goBinder b = b
126− renameQual :: Qualified a -> Qualified a
127− renameQual (Qualified (Just mn') a) =
128− let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
129− in Qualified (Just mnSafe) a
130− renameQual q = q
131−
132− -- |
133− -- Generate code in the simplified intermediate representation for a declaration
134− --
135− bindToCpp :: DeclType -> Bind Ann -> m [AST]
136− bindToCpp dt (NonRec ann ident val) = return <$> nonRecToCpp dt ann ident val
137− bindToCpp dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToCpp dt')
138− where
139− dt' = if dt == LetDecl then RecLetDecl else dt
140−
141− -- | Generate code in the simplified intermediate representation for a single non-recursive
142− -- declaration.
143− --
144− -- The main purpose of this function is to handle code generation for comments.
145− nonRecToCpp :: DeclType -> Ann -> Ident -> Expr Ann -> m AST
146− nonRecToCpp dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
147− -- withoutComment <- asks optionsNoComments
148− let withoutComment = False
149− if withoutComment
150− then nonRecToCpp dt a i (modifyAnn removeComments e)
151− else AST.Comment Nothing com <$> nonRecToCpp dt a i (modifyAnn removeComments e)
152− nonRecToCpp ModuleDecl (ss, _, _, _) ident val = do
153− cpp <- valueToCpp val
154− pure $ AST.Function Nothing (Just $ identToCpp ident) [] (AST.Block Nothing [AST.Return Nothing cpp])
155− nonRecToCpp RecLetDecl (ss, _, _, _) ident val = do
156− cpp <- valueToCpp val
157− pure $
158− let retainedName = identToCpp ident
159− retained = AST.Var Nothing $ retainedName
160− unretainedName = retainedName <> unretainedSuffix
161− unretained = AST.Var Nothing $ unretainedName
162− boxed = AST.Var Nothing . -- Note: prevents optimizer from eliminating this
163− prettyPrintCpp1 $
164− AST.VariableIntroduction
165− Nothing
166− retainedName
167− (Just unretained)
168− alias = AST.Var Nothing $ "auto& " <> retainedName <> " = " <> unretainedName
169− in
170− case cpp of
171− AST.Function _ name args (AST.Block Nothing cpps) ->
172− AST.Assignment Nothing
173− retained
174− (AST.Function Nothing
175− name
176− args
177− (AST.Block Nothing (boxed : cpps)))
178− _ ->
179− AST.Assignment Nothing
180− retained
181− (AST.App Nothing
182− (AST.Function Nothing
183− Nothing
184− []
185− (AST.Block Nothing ([ alias
186− , AST.Return Nothing cpp
187− ])))
188− [])
189− nonRecToCpp _ (ss, _, _, _) ident val = do
190− cpp <- valueToCpp val
191− pure $ AST.VariableIntroduction Nothing (identToCpp ident) (Just cpp)
192−
193− -- | Generate code in the simplified intermediate representation for a variable based on a
194− -- PureScript identifier.
195− var :: Ident -> AST
196− var = AST.Var Nothing . identToCpp
197−
198− accessorString :: PSString -> AST -> AST
199− accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
200−
201− -- | Generate code in the simplified intermediate representation for a value or expression.
202−
203− valueToCpp :: Expr Ann -> m AST
204− valueToCpp (Literal (pos, _, _, _) l) = literalToValueCpp pos l
205− valueToCpp (Accessor _ prop val) =
206− accessorString prop <$> valueToCpp val
207− valueToCpp (ObjectUpdate _ o ps) = do
208− obj <- valueToCpp o
209− updates <- mapM (sndM valueToCpp) ps
210− obj' <- freshName'
211− let objVar = AST.Var Nothing obj'
212− copy = AST.VariableIntroduction Nothing obj' (Just $ AST.App Nothing (AST.Var Nothing (unbox dictType)) [obj])
213− assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
214− sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
215− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
216− valueToCpp (Abs _ arg val) = do
217− ret <- valueToCpp val
218− let cppArg = case arg of
219− UnusedIdent -> []
220− _ -> [identToCpp arg]
221− return $ AST.Function Nothing Nothing cppArg (AST.Block Nothing [AST.Return Nothing ret])
222− valueToCpp e@App{} = do
223− let (f, args) = unApp e []
224− args' <- mapM valueToCpp args
225− case f of
226− Var (_, _, _, Just IsNewtype) _ -> return (head args')
227− _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToCpp f
228− where
229− unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
230− unApp (App _ val arg) args = unApp val (arg : args)
231− unApp other args = (other, args)
232− -- valueToCpp (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
233− -- return $ if mn' == mn
234− -- then AST.Var Nothing (moduleNameToCpp mn' <> "::" <> identToCpp ident)
235− -- else varToCpp qi
236− -- valueToCpp (Var (_, _, _, Just IsForeign) (Qualified (Just mn') ident)) =
237− -- return $ AST.Var Nothing (moduleNameToCpp mn' <> "::" <> identToCpp ident)
238− -- valueToCpp (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
239− -- return $ if mn' == mn
240− -- then foreignIdent ident
241− -- else varToCpp qi
242− -- valueToCpp (Var (_, _, _, Just IsForeign) ident) =
243− -- internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident)
244− valueToCpp (Var _ ident) = return $ varToCpp ident
245− valueToCpp (Case (ss, _, _, _) values binders) = do
246− vals <- mapM valueToCpp values
247− bindersToCpp ss binders vals
248− valueToCpp (Let _ ds val) = do
249− let recurs = concatMap getNames $ filter isRec ds
250− recurDs = (\v -> AST.Var Nothing $ "boxed::recur " <> identToCpp v) <$> recurs
251− recurDsWeak = (\v -> AST.Var
252− Nothing
253− ("boxed::recur::weak " <> identToCpp v <> unretainedSuffix <> "(" <> identToCpp v <> ")")
254− ) <$> recurs
255− mutualRecurWarning = if any isMutRec $ filter isRec ds
256− then [AST.Var Nothing "#pragma message(\"Mutually recursive lets will cause retain cycles (memory leaks)\") //"]
257− else []
258− ds' <- concat <$> mapM (bindToCpp LetDecl) ds
259− ret <- valueToCpp val
260− return $
261− AST.App Nothing
262− (AST.Function Nothing
263− Nothing
264− []
265− (AST.Block Nothing (recurDs ++ recurDsWeak ++ mutualRecurWarning ++ ds' ++ [AST.Return Nothing ret])))
266− []
267− where
268− isRec :: Bind Ann -> Bool
269− isRec (Rec _) = True
270− isRec _ = False
271− isMutRec :: Bind Ann -> Bool
272− isMutRec b | (length . nub $ getNames b) > 1 = True
273− | otherwise = False
274− valueToCpp (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"
275− valueToCpp (Constructor _ _ (ProperName ctor) fields) =
276− let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :
277− ((\field -> (mkString (identToCpp field), var field)) `map` fields)
278− fn = foldr (\f inner -> AST.Function Nothing Nothing [identToCpp f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
279− in return fn
280−
281−
282− iife :: Text -> [AST] -> AST
283− iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
284−
285− literalToValueCpp :: SourceSpan -> Literal (Expr Ann) -> m AST
286− literalToValueCpp ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
287− literalToValueCpp ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)
288− literalToValueCpp ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s
289− literalToValueCpp ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])
290− literalToValueCpp ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b
291− literalToValueCpp ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToCpp xs
292− literalToValueCpp ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToCpp) ps
293−
294− -- | Generate code in the simplified intermediate representation for a reference to a
295− -- variable.
296− varToCpp :: Qualified Ident -> AST
297− varToCpp (Qualified Nothing ident) = var ident
298− varToCpp qual = qualifiedToCpp id qual
299−
300− -- | Generate code in the simplified intermediate representation for a reference to a
301− -- variable that may have a qualified name.
302− qualifiedToCpp :: (a -> Ident) -> Qualified a -> AST
303− qualifiedToCpp f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = AST.Var Nothing . runIdent $ f a
304− qualifiedToCpp f (Qualified (Just mn') a) = AST.Indexer Nothing (AST.Var Nothing . identToCpp $ f a) (AST.Var Nothing (moduleNameToCpp mn'))
305− qualifiedToCpp f (Qualified _ a) = AST.Var Nothing $ identToCpp (f a)
306−
307− -- foreignIdent :: Ident -> AST
308− -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")
309−
310− -- | Generate code in the simplified intermediate representation for pattern match binders
311− -- and guards.
312− bindersToCpp :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
313− bindersToCpp ss binders vals = do
314− valNames <- replicateM (length vals) freshName'
315− let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
316− cpps <- forM binders $ \(CaseAlternative bs result) -> do
317− ret <- guardsToCpp result
318− go valNames ret bs
319− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat cpps ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))
320− []
321− where
322− go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
323− go _ done [] = return done
324− go (v:vs) done' (b:bs) = do
325− done'' <- go vs done' bs
326− binderToCpp v done'' b
327− go _ _ _ = internalError "Invalid arguments to bindersToCpp"
328−
329− failedPatternMessage :: Text
330− failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss <> ": "
331−
332− guardsToCpp :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
333− guardsToCpp (Left gs) = traverse genGuard gs where
334− genGuard (cond, val) = do
335− cond' <- valueToCpp cond
336− val' <- valueToCpp val
337− return
338− (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))
339− (AST.Block Nothing [AST.Return Nothing val']) Nothing)
340−
341− guardsToCpp (Right v) = return . AST.Return Nothing <$> valueToCpp v
342−
343− -- | Generate code in the simplified intermediate representation for a pattern match
344− -- binder.
345− binderToCpp :: Text -> [AST] -> Binder Ann -> m [AST]
346− binderToCpp _ done NullBinder{} = return done
347− binderToCpp varName done (LiteralBinder _ l) =
348− literalToBinderCpp varName done l
349− binderToCpp varName done (VarBinder _ ident) =
350− return (AST.VariableIntroduction Nothing (identToCpp ident) (Just (AST.Var Nothing varName)) : done)
351− binderToCpp varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
352− binderToCpp varName done b
353− binderToCpp varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do
354− cpp <- go (zip fields bs) done
355− return $ case ctorType of
356− ProductType -> cpp
357− SumType ->
358− [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))
359− (AST.Block Nothing cpp)
360− Nothing]
361− where
362− go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
363− go [] done' = return done'
364− go ((field, binder) : remain) done' = do
365− argVar <- freshName'
366− done'' <- go remain done'
367− cpp <- binderToCpp argVar done'' binder
368− return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToCpp field) $ AST.Var Nothing varName) : cpp)
369−
370− binderToCpp _ _ ConstructorBinder{} =
371− internalError "binderToCpp: Invalid ConstructorBinder in binderToCpp"
372− binderToCpp varName done (NamedBinder _ ident binder) = do
373− cpp <- binderToCpp varName done binder
374− return (AST.VariableIntroduction Nothing (identToCpp ident) (Just (AST.Var Nothing varName)) : cpp)
375−
376− literalToBinderCpp :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
377− literalToBinderCpp varName done (NumericLiteral num) =
378− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
379− literalToBinderCpp varName done (CharLiteral c) =
380− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
381− literalToBinderCpp varName done (StringLiteral str) =
382− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
383− literalToBinderCpp varName done (BooleanLiteral True) =
384− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]
385− literalToBinderCpp varName done (BooleanLiteral False) =
386− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]
387− -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
388− literalToBinderCpp varName done (ObjectLiteral bs) = go done bs
389− where
390− go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
391− go done' [] = return done'
392− go done' ((prop, binder):bs') = do
393− propVar <- freshName'
394− done'' <- go done' bs'
395− cpp <- binderToCpp propVar done'' binder
396− return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : cpp)
397− literalToBinderCpp varName done (ArrayLiteral bs) = do
398− cpp <- go done 0 bs
399− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo
400− (arrayLength $ AST.Var Nothing varName)
401− (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))
402− (AST.Block Nothing cpp) Nothing]
403− where
404− go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
405− go done' _ [] = return done'
406− go done' index (binder:bs') = do
407− elVar <- freshName'
408− done'' <- go done' (index + 1) bs'
409− cpp <- binderToCpp elVar done'' binder
410− return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : cpp)
411−
412−emptyAnn :: Ann
413−emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)
414−
415−arrayLength :: AST -> AST
416−arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
417−
418−freshName' :: MonadSupply m => m Text
419−freshName' = do
420− name <- freshName
421− return $ T.replace "$" "_Local_" name
src/CodeGen/Cpp/Common.hsdeleted−222
@@ -1,222 +0,0 @@
1−-- | Common code generation utility functions
2−module CodeGen.Cpp.Common where
3−
4−import Prelude.Compat
5−
6−import Data.Char
7−import Data.Monoid ((<>))
8−import Data.Text (Text)
9−import qualified Data.Text as T
10−
11−import Language.PureScript.Crash
12−import Language.PureScript.Names
13−
14−moduleNameToCpp :: ModuleName -> Text
15−moduleNameToCpp (ModuleName pns) =
16− let name = T.intercalate "_" (runProperName `map` pns)
17− in if nameIsCppBuiltIn name then ("_" <> name <> "_") else name
18−
19−-- | Convert an 'Ident' into a valid C++ identifier:
20−--
21−-- * Alphanumeric characters are kept unmodified.
22−--
23−-- * Reserved C++ identifiers are wrapped with '_'.
24−--
25−identToCpp :: Ident -> Text
26−identToCpp UnusedIdent = unusedName
27−identToCpp (Ident "$__unused") = unusedName
28−identToCpp (Ident name) = properToCpp name
29−identToCpp (GenIdent _ _) = internalError "GenIdent in identToCpp"
30−
31−unusedName :: Text
32−unusedName = "_Unused_"
33−
34−properToCpp :: Text -> Text
35−properToCpp name
36− | nameIsCppReserved name || nameIsCppBuiltIn name || prefixIsReserved name = "_" <> name <> "_"
37− | otherwise = T.concatMap identCharToText name
38−
39−-- | Test if a string is a valid AST identifier without escaping.
40−identNeedsEscaping :: Text -> Bool
41−identNeedsEscaping s = s /= properToCpp s || T.null s
42−
43−-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the
44−-- ordinal value.
45−identCharToText :: Char -> Text
46−identCharToText c | isAlphaNum c = T.singleton c
47−identCharToText '_' = "_"
48−identCharToText '\'' = "_Prime_"
49−identCharToText '$' = "$"
50−identCharToText c = "_Code_Point_" <> T.pack (show (ord c))
51−
52−-- | Checks whether an identifier name is reserved in C++.
53−nameIsCppReserved :: Text -> Bool
54−nameIsCppReserved name =
55− name `elem` cppAnyReserved
56−
57−-- | Checks whether a name matches a built-in value in C++.
58−nameIsCppBuiltIn :: Text -> Bool
59−nameIsCppBuiltIn name =
60− name `elem`
61− [ "final"
62− , "override"
63− , "posix"
64− , "std"
65− ]
66−
67−cppAnyReserved :: [Text]
68−cppAnyReserved =
69− concat
70− [ cppKeywords
71− , cppLiterals
72− ]
73−
74−cppKeywords :: [Text]
75−cppKeywords =
76− [ "alignas"
77− , "alignof"
78− , "and"
79− , "and_eq"
80− , "asm"
81− , "assert"
82− , "atomic_cancel"
83− , "atomic_commit"
84− , "atomic_noexcept"
85− , "auto"
86− , "bitand"
87− , "bitor"
88− , "bool"
89− , "break"
90− , "case"
91− , "catch"
92− , "char"
93− , "char16_t"
94− , "char32_t"
95− , "class"
96− , "compl"
97− , "concept"
98− , "const"
99− , "constexpr"
100− , "const_cast"
101− , "continue"
102− , "concept"
103− , "decltype"
104− , "default"
105− , "delete"
106− , "do"
107− , "double"
108− , "dynamic_cast"
109− , "else"
110− , "enum"
111− , "explicit"
112− , "export"
113− , "extern"
114− , "false"
115− , "float"
116− , "for"
117− , "friend"
118− , "goto"
119− , "if"
120− , "import"
121− , "inline"
122− , "int"
123− , "long"
124− , "module"
125− , "mutable"
126− , "namespace"
127− , "new"
128− , "noexcept"
129− , "not"
130− , "not_eq"
131− , "nullptr"
132− , "nullptr_t"
133− , "operator"
134− , "or"
135− , "or_eq"
136− , "private"
137− , "protected"
138− , "public"
139− , "register"
140− , "reinterpret_cast"
141− , "requires"
142− , "return"
143− , "short"
144− , "signed"
145− , "sizeof"
146− , "static"
147− , "static_assert"
148− , "static_cast"
149− , "struct"
150− , "switch"
151− , "synchronized"
152− , "template"
153− , "this"
154− , "thread_local"
155− , "throw"
156− , "true"
157− , "try"
158− , "typedef"
159− , "typeid"
160− , "typename"
161− , "typeof"
162− , "union"
163− , "unsigned"
164− , "using"
165− , "virtual"
166− , "void"
167− , "volatile"
168− , "wchar_t"
169− , "while"
170− , "xor"
171− , "xor_eq"
172− ]
173−
174−prefixIsReserved :: Text -> Bool
175−prefixIsReserved name =
176− any (`T.isPrefixOf` name)
177− [ "__"
178− ]
179−
180−cppLiterals :: [Text]
181−cppLiterals =
182− [ "box"
183− , "boxed"
184− , "copy"
185− , "errno"
186− , "peek"
187− , "purescript"
188− , "runtime_error"
189− , "setjmp"
190− , "string"
191− , "unbox"
192− ]
193−
194−dictType :: Text
195−dictType = "dict_t"
196−
197−arrayType :: Text
198−arrayType = "array_t"
199−
200−int :: Text
201−int = "int"
202−
203−float :: Text
204−float = "double"
205−
206−bool :: Text
207−bool = "bool"
208−
209−string :: Text
210−string = "string"
211−
212−unbox :: Text -> Text
213−unbox t = "unbox<" <> t <> ">"
214−
215−arrayLengthFn :: Text
216−arrayLengthFn = "array_length"
217−
218−unretainedSuffix :: Text
219−unretainedSuffix = "_Weak_"
220−
221−tcoLoop :: Text
222−tcoLoop = "_TCO_Loop_"
src/CodeGen/Cpp/Optimizer.hsdeleted−140
@@ -1,140 +0,0 @@
1−-- | This module optimizes code in the intermediate representation.
2−module CodeGen.Cpp.Optimizer (optimize) where
3−
4−import Prelude.Compat
5−
6−import Control.Monad.Supply.Class (MonadSupply)
7−import Data.Text (Text)
8−import Language.PureScript.CoreImp.AST
9−import Language.PureScript.CoreImp.Optimizer.Blocks
10−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
11−import Language.PureScript.CoreImp.Optimizer.Inliner hiding (inlineUnsafeCoerce, inlineUnsafePartial)
12−import Language.PureScript.CoreImp.Optimizer.Unused
13−import Language.PureScript.PSString (PSString, decodeString)
14−
15−import CodeGen.Cpp.Common (unusedName)
16−import CodeGen.Cpp.Optimizer.TCO
17−
18−import qualified Language.PureScript.Constants as C
19−
20−
21−-- | Apply a series of optimizer passes to simplified C++ code
22−optimize :: MonadSupply m => AST -> AST -> m AST
23−-- optimize = untilFixedPoint $ return . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . tco
24−optimize mn cpp = do
25− cpp' <- untilFixedPoint (return . inlineApply . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) cpp
26− untilFixedPoint (return . tidyUp) . tco mn
27− =<< untilFixedPoint (return . magicDo')
28− =<< untilFixedPoint (return . magicDo) cpp'
29−
30−
31− where
32− tidyUp :: AST -> AST
33− tidyUp = applyAll
34− [ collapseNestedBlocks
35− -- , collapseNestedIfs
36− , collapseIfChecks
37− , removeCodeAfterReturnStatements
38− , unThunk
39− , etaConvert
40− , evaluateIifes
41− , inlineVariables
42− ]
43−
44−untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
45−untilFixedPoint f = go
46− where
47− go a = do
48− a' <- f a
49− if a' == a then return a' else go a'
50−
51−-- | Overridden from CoreImp
52−
53−inlineUnsafePartial :: AST -> AST
54−inlineUnsafePartial = everywhereTopDown convert where
55− convert (App ss (Indexer _ (Var _ unsafePartial) (Var _ partialUnsafe)) [ comp ])
56− | unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe
57− -- Apply to undefined here, the application should be optimized away
58− -- if it is safe to do so
59− = App ss comp [ Var ss C.undefined ]
60− convert other = other
61−
62−inlineUnsafeCoerce :: AST -> AST
63−inlineUnsafeCoerce = everywhereTopDown convert where
64− convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])
65− | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce
66− = comp
67− convert other = other
68−
69−inlineApply :: AST -> AST
70−inlineApply = everywhereTopDown convert where
71− convert (App ss (App _ (Indexer _ (Var _ apply) (Var _ dataFunction)) [ f ]) [ arg ])
72− | apply == C.apply && dataFunction == C.dataFunction
73− = App ss f [ arg ]
74− convert (App ss (App _ (Indexer _ (Var _ applyFlipped) (Var _ dataFunction)) [ arg ]) [ f ])
75− | applyFlipped == C.applyFlipped && dataFunction == C.dataFunction
76− = App ss f [ arg ]
77− convert other = other
78−
79−collapseIfChecks :: AST -> AST
80−collapseIfChecks = everywhere collapse where
81− collapse :: AST -> AST
82− collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs
83− collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)
84− | prop == "otherwise" && val == "Data_Boolean" = exprs
85− collapse exprs = exprs
86−
87−magicDo :: AST -> AST
88−magicDo = magicDo'' C.eff C.effDictionaries
89−
90−magicDo' :: AST -> AST
91−magicDo' = magicDo'' C.effect C.effectDictionaries
92−
93−magicDo'' :: Text -> C.EffectDictionaries -> AST -> AST
94−magicDo'' effectModule C.EffectDictionaries{..} = everywhereTopDown convert
95− where
96− -- Desugar monomorphic calls to >>= and return for the Eff monad
97− convert :: AST -> AST
98− -- Desugar pure
99− convert (App _ (App _ pure' [val]) []) | isPure pure' = val
100− -- Desugar discard
101− convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 cpp)]) | isDiscard bind && unused == unusedName =
102− Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns cpp )
103− -- Desugar bind
104− convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 cpp)]) | isBind bind =
105− Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns cpp)
106− -- Inline double applications
107− convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
108− App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
109− convert other = other
110−
111− -- Check if an expression represents a monomorphic call to >>= for the Eff monad
112− isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
113− isBind _ = False
114− -- Check if an expression represents a call to @discard@
115− isDiscard (App _ (App _ fn [dict1]) [dict2])
116− | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
117− isDict (effectModule, edBindDict) dict2 &&
118− isDiscardPoly fn = True
119− isDiscard _ = False
120− -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
121− isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True
122− isPure _ = False
123− -- Check if an expression represents the polymorphic >>= function
124− isBindPoly = isDict (C.controlBind, C.bind)
125− -- Check if an expression represents the polymorphic pure function
126− isPurePoly = isDict (C.controlApplicative, C.pure')
127− -- Check if an expression represents the polymorphic discard function
128− isDiscardPoly = isDict (C.controlBind, C.discard)
129−
130−
131− applyReturns :: AST -> AST
132− applyReturns (Return ss ret) = Return ss (App ss ret [])
133− applyReturns (Block ss cpps) = Block ss (map applyReturns cpps)
134− applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
135− applyReturns other = other
136−
137− isDict :: (Text, PSString) -> AST -> Bool
138− isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
139− Just x == decodeString dictName && y == moduleName
140− isDict _ _ = False
src/CodeGen/Cpp/Printer.hsdeleted−515
@@ -1,515 +0,0 @@
1−-- | Pretty printer for the AST
2−module CodeGen.Cpp.Printer
3− ( prettyPrintCpp
4− , prettyPrintCpp1
5− , prettyPrintCppWithSourceMaps
6− , interfaceSource
7− , implHeaderSource
8− , implFooterSource
9− , isLiteral
10− ) where
11−
12−import Prelude.Compat
13−
14−import Control.Arrow ((<+>))
15−import Control.Monad (forM, mzero)
16−import Control.Monad.State (StateT, evalStateT)
17−import Control.PatternArrows
18−import Data.Char (isAscii)
19−import Data.List (filter, (\\))
20−import qualified Control.Arrow as A
21−
22−import Data.Maybe (fromMaybe)
23−import Data.Monoid ((<>))
24−import Data.Text (Text)
25−import qualified Data.Text as T
26−
27−import Language.PureScript.AST (SourceSpan(..))
28−import Language.PureScript.CoreImp.AST
29−import Language.PureScript.Comments
30−import Language.PureScript.Crash
31−import Language.PureScript.Names (Ident, runIdent)
32−import Language.PureScript.Pretty.Common
33−import Language.PureScript.PSString (PSString, decodeString, mkString)
34−import CodeGen.Cpp.Common
35−
36−import qualified Language.PureScript.Constants as C
37−
38−-- TODO (Christoph): Get rid of T.unpack / pack
39−
40−literals :: (Emit gen) => Pattern PrinterState AST gen
41−literals = mkPattern' match'
42− where
43− match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
44− match' cpp = (addMapping' (getSourceSpan cpp) <>) <$> match cpp
45−
46− match :: (Emit gen) => AST -> StateT PrinterState Maybe gen
47− match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n
48− match (StringLiteral _ s) = return $ emit $ stringLiteral s
49− match (BooleanLiteral _ True) = return $ emit "true"
50− match (BooleanLiteral _ False) = return $ emit "false"
51− match (ArrayLiteral _ xs) = mconcat <$> sequence
52− [ return . emit $ arrayType <> "{ "
53− , intercalate (emit ", ") <$> forM xs prettyPrintCpp'
54− , return $ emit " }"
55− ]
56− -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"
57− match (ObjectLiteral _ ps) = mconcat <$> sequence
58− [ return . emit $ dictType <> "{\n"
59− , withIndent $ do
60− cpps <- forM ps $ \(key, value) -> do
61− value' <- prettyPrintCpp' value
62− return $ emit "{ " <> objectPropertyToString key <> value' <> emit " }"
63− indentString <- currentIndent
64− return $ intercalate (emit ",\n") $ map (indentString <>) cpps
65− , return $ emit "\n"
66− , currentIndent
67− , return $ emit "}"
68− ]
69− where
70− objectPropertyToString :: (Emit gen) => PSString -> gen
71− objectPropertyToString s = emit $ stringLiteral s <> ", "
72− match (Block _ sts) = mconcat <$> sequence
73− [ return $ emit "{\n"
74− , withIndent $ prettyStatements sts
75− , return $ emit "\n"
76− , currentIndent
77− , return $ emit "}"
78− ]
79− match (Var _ ident) = return $ emit ident
80− match (VariableIntroduction _ ident value) = mconcat <$> sequence
81− [ return $ emit $ "boxed " <> ident
82− , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintCpp') value
83− ]
84− match (Assignment _ target value) = mconcat <$> sequence
85− [ prettyPrintCpp' target
86− , return $ emit " = "
87− , prettyPrintCpp' value
88− ]
89− match (App _ val []) = mconcat <$> sequence
90− [ prettyPrintCpp' val
91− , return $ emit "()"
92− ]
93− match (App ss (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [x]) [y])
94− | fnMod == dictMod
95− , dictMod == C.dataEq || dictMod == C.dataSemiring || dictMod == C.dataRing ||
96− dictMod == C.dataEuclideanRing || dictMod == C.dataHeytingAlgebra
97− , Just op <- renderOp fn
98− , Just t <- unboxType dict
99− = mconcat <$> sequence
100− [ return $ emit $ unbox' t x
101− , return $ emit op
102− , return $ emit $ unbox' t y
103− ]
104− match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])
105− | fnMod == dictMod
106− , dictMod == C.dataRing
107− , fn == C.negate
108− , Just t <- unboxType dict
109− = mconcat <$> sequence
110− [ return $ emit "-"
111− , return $ emit $ unbox' t n
112− ]
113− match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])
114− | fnMod == dictMod
115− , dictMod == C.dataHeytingAlgebra
116− , fn == properToCpp C.not
117− , Just t <- unboxType dict
118− = mconcat <$> sequence
119− [ return $ emit "!"
120− , return $ emit $ unbox' t n
121− ]
122− match (App _ val args) = mconcat <$> sequence
123− [ prettyPrintCpp' val
124− , return $ emit "("
125− , intercalate (emit ", ") <$> forM args prettyPrintCpp'
126− , return $ emit ")"
127− ]
128− match (Function _ (Just name) [] (Block _ [Return _ ret]))
129− | isLiteral ret = mconcat <$> sequence
130− [ return $ emit "auto "
131− , return $ emit name
132− , return $ emit "() -> const boxed& "
133− , return $ emit "{\n"
134− , withIndent $ do
135− indentString <- currentIndent
136− return $ indentString <> emit staticValueBegin
137− , withIndent $ do
138− case ret of
139− Function _ Nothing args body -> mconcat <$> sequence
140− [ return $ emit "[]("
141− , return $ emit $ intercalate ", " (renderArg <$> args)
142− , return $ emit ") -> boxed "
143− , prettyPrintCpp' body
144− ]
145− _ -> do
146− prettyPrintCpp' ret
147− , return $ emit ";\n"
148− , withIndent $ do
149− indentString <- currentIndent
150− return $ indentString <> emit staticValueEnd
151− , return $ emit "\n}"
152− ]
153− match (Function _ (Just name) [] ret) = mconcat <$> sequence
154− [ return $ emit "auto "
155− , return $ emit name
156− , return $ emit "() -> boxed "
157− , prettyPrintCpp' ret
158− ]
159− match (Function _ name args ret) = mconcat <$> sequence
160− [ return $ emit captures
161− , return $ emit "("
162− , return $ emit $ intercalate ", " (render <$> args)
163− , return $ emit ") -> boxed "
164− , prettyPrintCpp' ret
165− ]
166− where
167− (captures, render)
168− | name == Just tcoLoop = ("[&]", renderArgByVal)
169− | otherwise = ("[=]", renderArg)
170− match (Indexer _ prop@(Var _ name) val) = mconcat <$> sequence
171− [ prettyPrintCpp' val
172− , return $ emit "::"
173− , prettyPrintCpp' prop
174− , return $ emit "()"
175− ]
176− match (Indexer _ prop val) = mconcat <$> sequence
177− [ prettyPrintCpp' val
178− , return $ emit "["
179− , prettyPrintCpp' prop
180− , return $ emit "]"
181− ]
182− match (InstanceOf _ val ty) = mconcat <$> sequence
183− [ return . emit $ unbox' dictType val
184− , return $ emit ".contains("
185− , prettyPrintCpp' ty
186− , return $ emit ")"
187− ]
188− match (While _ cond sts) = mconcat <$> sequence
189− [ return $ emit "while ("
190− , prettyPrintCpp' cond
191− , return $ emit ") "
192− , prettyPrintCpp' sts
193− ]
194− match (For _ ident start end sts) = mconcat <$> sequence
195− [ return $ emit $ "for (boxed " <> ident <> " = "
196− , prettyPrintCpp' start
197− , return $ emit $ "; " <> ident <> " < "
198− , prettyPrintCpp' end
199− , return $ emit $ "; " <> ident <> "++) "
200− , prettyPrintCpp' sts
201− ]
202− match (ForIn _ ident obj sts) = mconcat <$> sequence
203− [ return $ emit $ "for (boxed " <> ident <> " in "
204− , prettyPrintCpp' obj
205− , return $ emit ") "
206− , prettyPrintCpp' sts
207− ]
208− match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
209− [ return $ emit "if ("
210− , return $ emit $ unbox' "bool" cond
211− , return $ emit ") "
212− , prettyPrintCpp' thens
213− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
214− ]
215− match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
216− [ return $ emit "if (!("
217− , return $ emit $ unbox' "bool" cond
218− , return $ emit ")) "
219− , prettyPrintCpp' thens
220− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
221− ]
222− match (IfElse _ (Binary _ EqualTo x y@(NumericLiteral _ n)) thens elses) = mconcat <$> sequence
223− [ return $ emit "if ("
224− , return $ emit $ unbox' t x
225− , return $ emit $ " == "
226− , prettyPrintCpp' y
227− , return $ emit ") "
228− , prettyPrintCpp' thens
229− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
230− ]
231− where
232− t | Left _ <- n = int
233− | Right _ <- n = float
234− match (IfElse _ (Binary _ EqualTo a b@StringLiteral{}) thens elses) = mconcat <$> sequence
235− [ return $ emit "if ("
236− , return $ emit $ unbox' string a
237− , return $ emit $ " == "
238− , prettyPrintCpp' b
239− , return $ emit ") "
240− , prettyPrintCpp' thens
241− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
242− ]
243− match (IfElse _ cond thens elses) = mconcat <$> sequence
244− [ return $ emit "if ("
245− , prettyPrintCpp' cond
246− , return $ emit ") "
247− , prettyPrintCpp' thens
248− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses
249− ]
250− match (Return _ value) = mconcat <$> sequence
251− [ return $ emit "return "
252− , prettyPrintCpp' value
253− ]
254− match (ReturnNoResult _) = return $ emit "return undefined"
255− -- match (Throw _ _) = return mempty
256− match (Throw _ value) = mconcat <$> sequence
257− [ return $ emit "THROW_("
258− , return $ emit "\"PatternMatchFailure: \""
259− , prettyPrintCpp' value
260− , return $ emit ")"
261− ]
262− match (Comment _ com cpp) = mconcat <$> sequence
263− [ return $ emit "\n"
264− , mconcat <$> forM com comment
265− , prettyPrintCpp' cpp
266− ]
267− match _ = mzero
268−
269− comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
270− comment (LineComment com) = fmap mconcat $ sequence $
271− [ currentIndent
272− , return $ emit "//" <> emit com <> emit "\n"
273− ]
274− comment (BlockComment com) = fmap mconcat $ sequence $
275− [ currentIndent
276− , return $ emit "/**\n"
277− ] ++
278− map asLine (T.lines com) ++
279− [ currentIndent
280− , return $ emit " */\n"
281− , currentIndent
282− ]
283− where
284− asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen
285− asLine s = do
286− i <- currentIndent
287− return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
288−
289− removeComments :: Text -> Text
290− removeComments t =
291− case T.stripPrefix "*/" t of
292− Just rest -> removeComments rest
293− Nothing -> case T.uncons t of
294− Just (x, xs) -> x `T.cons` removeComments xs
295− Nothing -> ""
296−
297−unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
298−unary' op mkStr = Wrap match (const)
299− where
300− match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
301− match = mkPattern match'
302− where
303− match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)
304− match' _ = Nothing
305−
306−unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
307−unary op str = unary' op (\v -> str <> "(" <> prettyPrintCpp1 v <> ")")
308−
309−negateOperator :: (Emit gen) => Operator PrinterState AST gen
310−negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
311− where
312− isNegate (Unary _ Negate _) = True
313− isNegate _ = False
314−
315−binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen
316−binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)
317− where
318− match :: Pattern PrinterState AST (AST, AST)
319− match = mkPattern match'
320− where
321− match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)
322− match' _ = Nothing
323−
324−isLiteral :: AST -> Bool
325−isLiteral Function{} = True
326−isLiteral NumericLiteral{} = True
327−isLiteral StringLiteral{} = True
328−isLiteral BooleanLiteral{} = True
329−isLiteral ObjectLiteral{} = True
330−isLiteral ArrayLiteral{} = True
331−isLiteral _ = False
332−
333−prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
334−prettyStatements sts = do
335− cpps <- forM sts prettyPrintCpp'
336− indentString <- currentIndent
337− return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) cpps
338−
339−-- | Generate a pretty-printed string representing a collection of C++ expressions at the same indentation level
340−prettyPrintCppWithSourceMaps :: [AST] -> (Text, [SMap])
341−prettyPrintCppWithSourceMaps cpp =
342− let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) cpp
343− in (s, mp)
344−
345−prettyPrintCpp :: [AST] -> Text
346−prettyPrintCpp = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
347−
348−-- | Generate an indented, pretty-printed string representing a C++ expression
349−prettyPrintCpp' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
350−prettyPrintCpp' = A.runKleisli $ runPattern matchValue
351− where
352− matchValue :: (Emit gen) => Pattern PrinterState AST gen
353− matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
354− operators :: (Emit gen) => OperatorTable PrinterState AST gen
355− operators =
356− OperatorTable [ [ unary New "box" ]
357− , [ unary Not "!"
358− , unary BitwiseNot "~"
359− , unary Positive "+"
360− , negateOperator ]
361− , [ binary Multiply "*"
362− , binary Divide "/"
363− , binary Modulus "%" ]
364− , [ binary Add "+"
365− , binary Subtract "-" ]
366− , [ binary ShiftLeft "<<"
367− , binary ShiftRight ">>"
368− , binary ZeroFillShiftRight ">>>" ]
369− , [ binary LessThan "<"
370− , binary LessThanOrEqualTo "<="
371− , binary GreaterThan ">"
372− , binary GreaterThanOrEqualTo ">=" ]
373− , [ binary EqualTo "=="
374− , binary NotEqualTo "!=" ]
375− , [ binary BitwiseAnd "&" ]
376− , [ binary BitwiseXor "^" ]
377− , [ binary BitwiseOr "|" ]
378− , [ binary And "&&" ]
379− , [ binary Or "||" ]
380− ]
381−
382−prettyPrintCpp1 :: AST -> Text
383−prettyPrintCpp1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintCpp'
384−
385−stringLiteral :: PSString -> Text
386−stringLiteral pss | Just s <- decodeString pss =
387− (if T.all isAscii s
388− then ""
389− else ("u8")) <> stringLiteral' s
390− where
391− stringLiteral' :: Text -> Text
392− stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""
393− encodeChar :: Char -> Text
394− encodeChar '\0' = "\\0"
395− encodeChar '\b' = "\\b"
396− encodeChar '\t' = "\\t"
397− encodeChar '\n' = "\\n"
398− encodeChar '\v' = "\\v"
399− encodeChar '\f' = "\\f"
400− encodeChar '\r' = "\\r"
401− encodeChar '"' = "\\\""
402− encodeChar '\\' = "\\\\"
403− encodeChar c = T.singleton $ c
404−stringLiteral _ = "\"\\uFFFD\""
405−
406−unbox' :: Text -> AST -> Text
407−unbox' _ v@(NumericLiteral{}) = prettyPrintCpp1 v
408−unbox' _ v@(BooleanLiteral{}) = prettyPrintCpp1 v
409−unbox' _ v@(StringLiteral{}) = prettyPrintCpp1 v
410−unbox' t v = unbox t <> "(" <> prettyPrintCpp1 v <> ")"
411−
412−unboxType :: Text -> Maybe Text
413−unboxType t
414− | t == C.eqInt ||
415− t == C.semiringInt ||
416− t == C.ringInt
417− = Just int
418− | t == C.semiringNumber ||
419− t == C.ringNumber ||
420− t == C.euclideanRingNumber
421− = Just float
422− | t == C.heytingAlgebraBoolean
423− = Just bool
424− | otherwise = Nothing
425−
426−renderOp :: Text -> Maybe Text
427−renderOp op
428− | op == C.eq = Just " == "
429− | op == C.notEq = Just " != "
430− | op == C.add = Just " + "
431− | op == C.sub = Just " - "
432− | op == C.mul = Just " * "
433− | op == C.div = Just " / "
434− | op == C.conj = Just " && "
435− | op == C.disj = Just "|| "
436− | otherwise = Nothing
437−
438−interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
439−interfaceSource mn values foreigns =
440− let foreigns' = identToCpp <$> foreigns
441− valueNames = fst <$> values
442− values' = filter ((`notElem` foreigns') . fst) values ++
443− zip (foreigns' \\ valueNames) (repeat True)
444− in
445− "// Generated by pscpp compiler\n\n" <>
446− "#ifndef " <> mn <> "_H\n" <>
447− "#define " <> mn <> "_H\n\n" <>
448− "#include \"purescript.h\"\n\n" <>
449− "namespace " <> mn <> " {\n\n" <>
450− "using namespace purescript;\n\n" <>
451− (T.concat $ (\(export, static) ->
452− let rty = if static then "const boxed&" else "boxed" in
453− "auto " <> export <> "() -> " <> rty <> ";\n") <$> values') <> "\n" <>
454− "} // end namespace " <> mn <> "\n\n" <>
455− "#endif // " <> mn <> "_H\n\n"
456−
457−implHeaderSource :: Text -> [Text] -> Text -> Text
458−implHeaderSource mn imports interfaceImport =
459− T.concat imports <> "\n"<>
460− interfaceImport <> "\n\n" <>
461− "namespace " <> mn <> " {\n\n"
462−
463−implFooterSource :: Text -> [Ident] -> Text
464−implFooterSource mn foreigns =
465− "\n\n\n" <>
466− (if null foreigns
467− then ""
468− else ("// Foreign values\n\n" <>
469− "DEFINE_FOREIGN_DICTIONARY_AND_ACCESSOR()\n\n" <>
470− (T.concat $ (\foreign' -> "auto " <>
471− identToCpp foreign' <>
472− "() -> const boxed& { " <>
473− staticValueBegin <>
474− foreignDict <> "().at(" <>
475− (stringLiteral . mkString $ runIdent foreign') <> "); " <>
476− staticValueEnd <>
477− " };\n") <$> foreigns) <>
478− "\n")) <>
479− "} // end namespace " <> mn <>
480− "\n\n" <>
481− if mn == "Main" then mainSource else "\n"
482− where
483− mainSource :: Text
484− mainSource = "\
485− \int main(int argc, const char * argv[]) {\n\
486− \ Main::main()();\n\
487− \ return 0;\n\
488− \}\n\n\
489− \"
490−
491−varDecl :: Text
492−varDecl = "const boxed"
493−
494−varRefDecl :: Text
495−varRefDecl = varDecl <> "&"
496−
497−renderArg' :: Text -> Text -> Text
498−renderArg' decl arg
499− | arg == unusedName = decl
500− | otherwise = decl <> " " <> arg
501−
502−renderArg :: Text -> Text
503−renderArg = renderArg' varRefDecl
504−
505−renderArgByVal :: Text -> Text
506−renderArgByVal = renderArg' varDecl
507−
508−foreignDict :: Text
509−foreignDict = "foreign"
510−
511−staticValueBegin :: Text
512−staticValueBegin = "static const boxed _ = "
513−
514−staticValueEnd :: Text
515−staticValueEnd = "return _;"
src/CodeGen/IL.hsnew file+321
@@ -0,0 +1,321 @@
1+-- | This module generates code in the core imperative representation from
2+-- elaborated PureScript code.
3+module CodeGen.IL
4+ ( module AST
5+ , module Common
6+ , moduleToIL
7+ ) where
8+
9+import Prelude.Compat
10+import Protolude (ordNub)
11+
12+import Control.Arrow ((&&&))
13+import Control.Monad (forM, liftM, replicateM, void)
14+import Control.Monad.Supply.Class
15+
16+import Data.List ((\\), delete, intersect, nub)
17+import qualified Data.Foldable as F
18+import qualified Data.Map as M
19+import Data.Maybe (fromMaybe, isNothing, mapMaybe)
20+import Data.Monoid ((<>))
21+import Data.String (fromString)
22+import Data.Text (Text)
23+import qualified Data.Text as T
24+
25+import Language.PureScript.AST.SourcePos
26+import Language.PureScript.CoreImp.AST (AST)
27+import qualified Language.PureScript.CoreImp.AST as AST
28+import Language.PureScript.CoreFn
29+import Language.PureScript.Crash
30+import Language.PureScript.Names
31+import Language.PureScript.Options
32+import Language.PureScript.PSString (PSString, mkString)
33+import Language.PureScript.Traversals (sndM)
34+import qualified Language.PureScript.Constants as C
35+
36+import System.FilePath.Posix ((</>))
37+
38+import CodeGen.IL.Common as Common
39+import CodeGen.IL.Optimizer
40+import CodeGen.IL.Printer
41+
42+data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)
43+
44+-- | Generate code in the simplified intermediate representation for all declarations in a
45+-- module.
46+moduleToIL
47+ :: forall m
48+ -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
49+ . (Monad m, MonadSupply m)
50+ => Module Ann
51+ -> Text
52+ -> m (Text, [Text], [AST], Text, Text)
53+moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =
54+ do
55+ ilDecls <- mapM (bindToIL ModuleDecl) decls
56+ optimized <- traverse (traverse (optimize modName')) ilDecls
57+ let optimized' = concat optimized
58+ values = annotValue <$> optimized'
59+ foreigns' = moduleIdentToIL <$> foreigns
60+ interface = interfaceSource modName values foreigns
61+ imports = nub . concat $ importToIL <$> optimized'
62+ implHeader = implHeaderSource modName imports project
63+ implFooter = implFooterSource (runModuleName mn) foreigns
64+ return $ (interface, foreigns', optimized', implHeader, implFooter)
65+ where
66+ modName = moduleNameToIL mn
67+ modName' = AST.Var Nothing modName
68+
69+ annotValue :: AST -> (Text, Bool)
70+ annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))
71+ | isLiteral ret = (name, True)
72+ annotValue (AST.Function _ (Just name) [] _) = (name, False)
73+ annotValue _ = error "Unexpected top-level value form"
74+
75+ -- | Extracts all declaration names from a binding group.
76+ getNames :: Bind Ann -> [Ident]
77+ getNames (NonRec _ ident _) = [ident]
78+ getNames (Rec vals) = map (snd . fst) vals
79+
80+ -- | Generates IL code for a module import
81+ --
82+ importToIL :: AST -> [Text]
83+ importToIL = AST.everything (++) modRef
84+ where
85+ modRef (AST.Indexer _ (AST.Var _ _) (AST.Var _ mname))
86+ | not $ T.null mname = [extract mname]
87+ modRef _ = []
88+ extract :: Text -> Text
89+ extract = T.replace "_" "." . T.dropWhileEnd (=='_')
90+
91+ -- |
92+ -- Generate code in the simplified intermediate representation for a declaration
93+ --
94+ bindToIL :: DeclType -> Bind Ann -> m [AST]
95+ bindToIL dt (NonRec ann ident val) = return <$> nonRecToIL dt ann ident val
96+ bindToIL dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToIL dt')
97+ where
98+ dt' = if dt == LetDecl then RecLetDecl else dt
99+
100+ -- | Generate code in the simplified intermediate representation for a single non-recursive
101+ -- declaration.
102+ --
103+ -- The main purpose of this function is to handle code generation for comments.
104+ nonRecToIL :: DeclType -> Ann -> Ident -> Expr Ann -> m AST
105+ nonRecToIL dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
106+ -- withoutComment <- asks optionsNoComments
107+ let withoutComment = False
108+ if withoutComment
109+ then nonRecToIL dt a i (modifyAnn removeComments e)
110+ else AST.Comment Nothing com <$> nonRecToIL dt a i (modifyAnn removeComments e)
111+ nonRecToIL ModuleDecl (ss, _, _, _) ident val = do
112+ il <- valueToIL val
113+ pure $ AST.Function Nothing (Just $ moduleIdentToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])
114+ nonRecToIL RecLetDecl (ss, _, _, _) ident val = do
115+ ilExpr <- valueToIL val
116+ pure $ AST.Assignment Nothing (AST.Var Nothing $ identToIL ident) ilExpr
117+ nonRecToIL _ (ss, _, _, _) ident val = do
118+ il <- valueToIL val
119+ pure $ AST.VariableIntroduction Nothing (identToIL ident) (Just il)
120+
121+ -- | Generate code in the simplified intermediate representation for a variable based on a
122+ -- PureScript identifier.
123+ var :: Ident -> AST
124+ var = AST.Var Nothing . identToIL
125+
126+ accessorString :: PSString -> AST -> AST
127+ accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
128+
129+ -- | Generate code in the simplified intermediate representation for a value or expression.
130+
131+ valueToIL :: Expr Ann -> m AST
132+ valueToIL (Literal (pos, _, _, _) l) = literalToValueIL pos l
133+ valueToIL (Accessor _ prop val) =
134+ accessorString prop <$> valueToIL val
135+ valueToIL (ObjectUpdate _ o ps) = do
136+ obj <- valueToIL o
137+ updates <- mapM (sndM valueToIL) ps
138+ obj' <- freshName'
139+ let objVar = AST.Var Nothing obj'
140+ copy = AST.VariableIntroduction Nothing obj' (Just $ copyDict obj)
141+ assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
142+ sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
143+ return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
144+ valueToIL (Abs _ arg val) = do
145+ ret <- valueToIL val
146+ let ilArg = case arg of
147+ UnusedIdent -> []
148+ _ -> [identToIL arg]
149+ return $ AST.Function Nothing Nothing ilArg (AST.Block Nothing [AST.Return Nothing ret])
150+ valueToIL e@App{} = do
151+ let (f, args) = unApp e []
152+ args' <- mapM valueToIL args
153+ fn <- valueToIL f
154+ case f of
155+ Var (_, _, _, Just IsNewtype) _ -> return (head args')
156+ _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToIL f
157+ where
158+ unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
159+ unApp (App _ val arg) args = unApp val (arg : args)
160+ unApp other args = (other, args)
161+ valueToIL (Var _ ident) = return $ varToIL ident
162+ valueToIL (Case (ss, _, _, _) values binders) = do
163+ vals <- mapM valueToIL values
164+ bindersToIL ss binders vals
165+ valueToIL (Let _ ds val) = do
166+ let recurs = concatMap getNames $ filter isRec ds
167+ recurDs = (\v -> AST.VariableIntroduction Nothing (identToIL v) Nothing) <$> recurs
168+ ds' <- concat <$> mapM (bindToIL LetDecl) ds
169+ ret <- valueToIL val
170+ return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (recurDs ++ ds' ++ [AST.Return Nothing ret]))) []
171+ where
172+ isRec :: Bind Ann -> Bool
173+ isRec (Rec _) = True
174+ isRec _ = False
175+ valueToIL (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"
176+ valueToIL (Constructor _ _ (ProperName ctor) fields) =
177+ let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :
178+ ((\field -> (mkString (identToIL field), var field)) `map` fields)
179+ fn = foldr (\f inner -> AST.Function Nothing Nothing [identToIL f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
180+ in return fn
181+
182+
183+ iife :: Text -> [AST] -> AST
184+ iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
185+
186+ literalToValueIL :: SourceSpan -> Literal (Expr Ann) -> m AST
187+ literalToValueIL ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
188+ literalToValueIL ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)
189+ literalToValueIL ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s
190+ literalToValueIL ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])
191+ literalToValueIL ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b
192+ literalToValueIL ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToIL xs
193+ literalToValueIL ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToIL) ps
194+
195+ -- | Generate code in the simplified intermediate representation for a reference to a
196+ -- variable.
197+ varToIL :: Qualified Ident -> AST
198+ varToIL (Qualified Nothing ident) = var ident
199+ varToIL qual = qualifiedToIL id qual
200+
201+ -- | Generate code in the simplified intermediate representation for a reference to a
202+ -- variable that may have a qualified name.
203+ qualifiedToIL :: (a -> Ident) -> Qualified a -> AST
204+ qualifiedToIL f (Qualified (Just (ModuleName mn')) a) | mn' == C.prim = AST.Var Nothing . moduleIdentToIL $ f a
205+ qualifiedToIL f (Qualified (Just mn') a) | mn /= mn' = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))
206+ qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing "")
207+
208+ -- foreignIdent :: Ident -> AST
209+ -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")
210+
211+ -- | Generate code in the simplified intermediate representation for pattern match binders
212+ -- and guards.
213+ bindersToIL :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
214+ bindersToIL ss binders vals = do
215+ valNames <- replicateM (length vals) freshName'
216+ let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
217+ ils <- forM binders $ \(CaseAlternative bs result) -> do
218+ ret <- guardsToIL result
219+ go valNames ret bs
220+ return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat ils ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))
221+ []
222+ where
223+ go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
224+ go _ done [] = return done
225+ go (v:vs) done' (b:bs) = do
226+ done'' <- go vs done' bs
227+ binderToIL v done'' b
228+ go _ _ _ = internalError "Invalid arguments to bindersToIL"
229+
230+ failedPatternMessage :: Text
231+ failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss
232+
233+ guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
234+ guardsToIL (Left gs) = traverse genGuard gs where
235+ genGuard (cond, val) = do
236+ cond' <- valueToIL cond
237+ val' <- valueToIL val
238+ return
239+ (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))
240+ (AST.Block Nothing [AST.Return Nothing val']) Nothing)
241+
242+ guardsToIL (Right v) = return . AST.Return Nothing <$> valueToIL v
243+
244+ -- | Generate code in the simplified intermediate representation for a pattern match
245+ -- binder.
246+ binderToIL :: Text -> [AST] -> Binder Ann -> m [AST]
247+ binderToIL _ done NullBinder{} = return done
248+ binderToIL varName done (LiteralBinder _ l) =
249+ literalToBinderIL varName done l
250+ binderToIL varName done (VarBinder _ ident) =
251+ return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : done)
252+ binderToIL varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
253+ binderToIL varName done b
254+ binderToIL varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do
255+ il <- go (zip fields bs) done
256+ return $ case ctorType of
257+ ProductType -> il
258+ SumType ->
259+ [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))
260+ (AST.Block Nothing il)
261+ Nothing]
262+ where
263+ go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
264+ go [] done' = return done'
265+ go ((field, binder) : remain) done' = do
266+ argVar <- freshName'
267+ done'' <- go remain done'
268+ il <- binderToIL argVar done'' binder
269+ return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToIL field) $ AST.Var Nothing varName) : il)
270+
271+ binderToIL _ _ ConstructorBinder{} =
272+ internalError "binderToIL: Invalid ConstructorBinder in binderToIL"
273+ binderToIL varName done (NamedBinder _ ident binder) = do
274+ il <- binderToIL varName done binder
275+ return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : il)
276+
277+ literalToBinderIL :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
278+ literalToBinderIL varName done (NumericLiteral num) =
279+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
280+ literalToBinderIL varName done (CharLiteral c) =
281+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
282+ literalToBinderIL varName done (StringLiteral str) =
283+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
284+ literalToBinderIL varName done (BooleanLiteral True) =
285+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]
286+ literalToBinderIL varName done (BooleanLiteral False) =
287+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]
288+ -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
289+ literalToBinderIL varName done (ObjectLiteral bs) = go done bs
290+ where
291+ go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
292+ go done' [] = return done'
293+ go done' ((prop, binder):bs') = do
294+ propVar <- freshName'
295+ done'' <- go done' bs'
296+ il <- binderToIL propVar done'' binder
297+ return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : il)
298+ literalToBinderIL varName done (ArrayLiteral bs) = do
299+ il <- go done 0 bs
300+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo
301+ (arrayLength $ AST.Var Nothing varName)
302+ (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))
303+ (AST.Block Nothing il) Nothing]
304+ where
305+ go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
306+ go done' _ [] = return done'
307+ go done' index (binder:bs') = do
308+ elVar <- freshName'
309+ done'' <- go done' (index + 1) bs'
310+ il <- binderToIL elVar done'' binder
311+ return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : il)
312+
313+emptyAnn :: Ann
314+emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)
315+
316+arrayLength :: AST -> AST
317+arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
318+-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")
319+
320+copyDict :: AST -> AST
321+copyDict a = AST.App Nothing (AST.Var Nothing copyDictFn) [a]
src/CodeGen/IL/Common.hsnew file+196
@@ -0,0 +1,196 @@
1+-- | Common code generation utility functions
2+module CodeGen.IL.Common where
3+
4+import Prelude.Compat
5+
6+import Control.Monad.Supply.Class (MonadSupply, freshName)
7+import Data.Char
8+import Data.Maybe (maybe)
9+import Data.Monoid ((<>))
10+import Data.Text (Text)
11+import qualified Data.Text as T
12+
13+import Language.PureScript.Crash
14+import Language.PureScript.Names
15+
16+import qualified Language.PureScript.Constants as C
17+
18+moduleNameToIL :: ModuleName -> Text
19+moduleNameToIL (ModuleName mn) =
20+ let name = T.replace "." "_" mn
21+ in if nameIsILBuiltIn name then (name <> moduleRenamerMarker) else name
22+
23+moduleNameToIL' :: ModuleName -> Text
24+moduleNameToIL' (ModuleName mn) = T.replace "_" "." mn
25+
26+-- | Convert an 'Ident' into a valid IL identifier:
27+--
28+-- * Alphanumeric characters are kept unmodified.
29+--
30+-- * Reserved IL identifiers are wrapped with '_'.
31+--
32+identToIL :: Ident -> Text
33+identToIL UnusedIdent = unusedName
34+identToIL (Ident "$__unused") = unusedName
35+identToIL (Ident name) | name == C.undefined = undefinedName -- Note: done in Printer.hs too
36+identToIL (Ident name) = properToIL name
37+identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
38+
39+moduleIdentToIL :: Ident -> Text
40+moduleIdentToIL UnusedIdent = unusedName
41+moduleIdentToIL (Ident name) | name == C.undefined = undefinedName
42+moduleIdentToIL (Ident name) = moduleProperToIL name
43+moduleIdentToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
44+
45+undefinedName :: Text
46+undefinedName = "Undefined"
47+
48+unusedName :: Text
49+unusedName = "_"
50+
51+properToIL :: Text -> Text
52+properToIL name
53+ | nameIsILReserved name = "ˉ" <> name
54+ | otherwise = T.concatMap identCharToText name
55+
56+-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the
57+-- ordinal value.
58+identCharToText :: Char -> Text
59+identCharToText 'ṩ' = "_ṩ"
60+identCharToText c | isAlphaNum c = T.singleton c
61+identCharToText '_' = "_"
62+identCharToText '\'' = "ꞌ" -- lowercase saltillo
63+identCharToText c = error (show (ord c)) -- TODO: should never occur now(?)
64+
65+moduleProperToIL :: Text -> Text
66+moduleProperToIL = T.concatMap identCharToText
67+
68+-- | Checks whether an identifier name is reserved in IL.
69+nameIsILReserved :: Text -> Bool
70+nameIsILReserved name =
71+ name `elem` ilAnyReserved
72+
73+-- | Checks whether a name matches a built-in value in IL.
74+nameIsILBuiltIn :: Text -> Bool
75+nameIsILBuiltIn name =
76+ name `elem`
77+ [ "Any"
78+ , "Apply"
79+ , "Contains"
80+ , "CopyDict"
81+ , "Dict"
82+ , "EffFn"
83+ , "Fn"
84+ , "Foreign"
85+ , "Get"
86+ , "Index"
87+ , "Is"
88+ , "Length"
89+ , "Once"
90+ , "Run"
91+ , "Undefined"
92+ ]
93+
94+ilAnyReserved :: [Text]
95+ilAnyReserved =
96+ concat
97+ [ ilKeywords
98+ , ilLiterals
99+ ]
100+
101+ilKeywords :: [Text]
102+ilKeywords =
103+ [ "break"
104+ , "case"
105+ , "chan"
106+ , "const"
107+ , "continue"
108+ , "default"
109+ , "defer"
110+ , "else"
111+ , "fallthrough"
112+ , "for"
113+ , "func"
114+ , "go"
115+ , "goto"
116+ , "if"
117+ , "import"
118+ , "interface"
119+ , "map"
120+ , "package"
121+ , "range"
122+ , "return"
123+ , "select"
124+ , "struct"
125+ , "switch"
126+ , "type"
127+ , "var"
128+ ]
129+
130+ilLiterals :: [Text]
131+ilLiterals =
132+ [ "init"
133+ , "nil"
134+ , "int"
135+ , "int8"
136+ , "int16"
137+ , "int32"
138+ , "int64"
139+ , "uint"
140+ , "uint8"
141+ , "uint16"
142+ , "uint32"
143+ , "uint64"
144+ , "uintptr"
145+ , "float32"
146+ , "float64"
147+ , "complex64"
148+ , "complex128"
149+ , "byte"
150+ , "rune"
151+ , "string"
152+ ]
153+
154+withPrefix :: Text -> Text
155+withPrefix s = "Ꞌ" <> s -- uppercase saltillo
156+
157+anyType :: Text
158+anyType = "Any"
159+
160+dictType :: Text
161+dictType = "Dict"
162+
163+arrayType :: Text
164+arrayType = "[]" <> anyType
165+
166+uncurriedFnType :: Int -> Text
167+uncurriedFnType i = "Fn" <> (T.pack . show $ i)
168+
169+int :: Text
170+int = "int"
171+
172+float :: Text
173+float = "float64"
174+
175+bool :: Text
176+bool = "bool"
177+
178+string :: Text
179+string = "string"
180+
181+arrayLengthFn :: Text
182+arrayLengthFn = "Length"
183+
184+indexFn :: Text
185+indexFn = "Index"
186+
187+copyDictFn :: Text
188+copyDictFn = "CopyDict"
189+
190+freshName' :: MonadSupply m => m Text
191+freshName' = do
192+ name <- freshName
193+ return $ T.replace "$" "ṩ" name
194+
195+moduleRenamerMarker :: Text
196+moduleRenamerMarker = "__"
src/CodeGen/IL/Optimizer.hsnew file+81
@@ -0,0 +1,81 @@
1+-- | This module optimizes code in the intermediate representation.
2+module CodeGen.IL.Optimizer (optimize) where
3+
4+import Prelude.Compat
5+
6+import Control.Monad.Supply.Class (MonadSupply)
7+import Data.Text (Text)
8+import Language.PureScript.CoreImp.AST
9+import Language.PureScript.CoreImp.Optimizer.Blocks
10+import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
11+import Language.PureScript.CoreImp.Optimizer.Inliner (etaConvert, evaluateIifes, inlineVariables, unThunk)
12+import Language.PureScript.CoreImp.Optimizer.Unused
13+
14+import CodeGen.IL.Common (unusedName)
15+import CodeGen.IL.Optimizer.Inliner
16+import CodeGen.IL.Optimizer.MagicDo
17+import CodeGen.IL.Optimizer.TCO
18+
19+import qualified Language.PureScript.Constants as C
20+
21+-- | Apply a series of optimizer passes to simplified IL code
22+optimize :: MonadSupply m => AST -> AST -> m AST
23+optimize mn il = do
24+ il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il
25+ il'' <- untilFixedPoint (return . ignoreUnusedResults . inlineCommonValues . inlineCommonOperators . tidyUp) . tco mn . inlineST
26+ =<< untilFixedPoint (return . magicDoST)
27+ =<< untilFixedPoint (return . magicDoEff)
28+ =<< untilFixedPoint (return . magicDoEffect) il'
29+ untilFixedPoint (return . collapseVarDeclarations) il''
30+ where
31+ tidyUp :: AST -> AST
32+ tidyUp = applyAll
33+ [ collapseNestedBlocks
34+ , collapseNestedIfs
35+ , collapseIfChecks
36+ , removeCodeAfterReturnStatements
37+ , unThunk
38+ , etaConvert
39+ , evaluateIifes
40+ , inlineVariables
41+ ]
42+
43+untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
44+untilFixedPoint f = go
45+ where
46+ go a = do
47+ a' <- f a
48+ if a' == a then return a' else go a'
49+
50+collapseIfChecks :: AST -> AST
51+collapseIfChecks = everywhere collapse where
52+ collapse :: AST -> AST
53+ collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs
54+ collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)
55+ | prop == "otherwise" && val == "Data_Boolean" = exprs
56+ collapse exprs = exprs
57+
58+collapseVarDeclarations :: AST -> AST
59+collapseVarDeclarations = everywhere collapse where
60+ collapse :: AST -> AST
61+ collapse (Block ss sts) = Block ss (go Nothing sts)
62+ collapse s = s
63+
64+ go :: Maybe Text -> [AST] -> [AST]
65+ go _ [] = []
66+ go Nothing (decl@(VariableIntroduction _ var (Just _)) : sts) = decl : go (Just var) (go Nothing sts)
67+ go (Just var') ((VariableIntroduction ss var (Just val)) : sts)
68+ | var == var' = (Assignment ss (Var Nothing var) val) : go (Just var') sts
69+ go var' (s:sts) = s : go var' sts
70+
71+ignoreUnusedResults :: AST -> AST
72+ignoreUnusedResults = everywhere $ removeFromBlock go
73+ where
74+ go :: [AST] -> [AST]
75+ go [] = []
76+ go (VariableIntroduction ss var (Just s) : sts)
77+ | not $ any (everything (||) (isUsed var)) sts = sts'
78+ where
79+ sts' | App{} <- s = s : (go sts)
80+ | otherwise = go sts
81+ go (s:sts) = s : go sts
src/CodeGen/IL/Optimizer/Common.hsnew file+18
@@ -0,0 +1,18 @@
1+-- | Common functions used by the various optimizer phases
2+module CodeGen.IL.Optimizer.Common where
3+
4+import Prelude.Compat
5+
6+import Data.Text (Text)
7+
8+import Language.PureScript.CoreImp.AST
9+import Language.PureScript.PSString (PSString, decodeString)
10+
11+isDict :: (Text, PSString) -> AST -> Bool
12+isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
13+ Just x == decodeString dictName && y == moduleName
14+isDict _ _ = False
15+
16+isDict' :: [(Text, PSString)] -> AST -> Bool
17+isDict' xs il = any (`isDict` il) xs
18+
src/CodeGen/IL/Optimizer/Inliner.hsnew file+435
@@ -0,0 +1,435 @@
1+-- | This module performs basic inlining of known functions
2+module CodeGen.IL.Optimizer.Inliner
3+ ( inlineCommonValues
4+ , inlineCommonOperators
5+ , inlineFnComposition
6+ , inlineUnsafeCoerce
7+ , inlineUnsafePartial
8+ ) where
9+
10+import Prelude.Compat
11+
12+import Control.Monad.Supply.Class (MonadSupply)
13+
14+import Data.Either (rights)
15+import Data.Maybe (fromMaybe)
16+import Data.String (IsString, fromString)
17+import Data.Text (Text)
18+import qualified Data.Text as T
19+
20+import Language.PureScript.PSString (PSString, decodeString, mkString)
21+import Language.PureScript.CoreImp.AST
22+import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict, isDict')
23+import Language.PureScript.AST (SourceSpan(..))
24+import qualified Language.PureScript.Constants as C
25+
26+import CodeGen.IL.Common
27+import CodeGen.IL.Optimizer.Common
28+
29+-- TODO: Potential bug:
30+-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }
31+-- Needs to be: { 0..toFixed(10); }
32+-- Probably needs to be fixed in pretty-printer instead.
33+shouldInline :: AST -> Bool
34+shouldInline (Var _ _) = True
35+shouldInline (NumericLiteral _ _) = True
36+shouldInline (StringLiteral _ _) = True
37+shouldInline (BooleanLiteral _ _) = True
38+shouldInline (Indexer _ index val) = shouldInline index && shouldInline val
39+shouldInline _ = False
40+
41+inlineCommonValues :: AST -> AST
42+inlineCommonValues = everywhere convert
43+ where
44+ convert :: AST -> AST
45+ convert (App ss fn [dict])
46+ | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0)
47+ | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1)
48+ | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False
49+ | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True
50+ convert (App ss (App _ fn [dict]) [x])
51+ | isDict ringInt dict && isDict fnNegate fn = Unary ss Negate (unbox x $ snd ringInt)
52+ convert (App ss (App _ (App _ fn [dict]) [x]) [y])
53+ | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add semiringInt x y
54+ | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply semiringInt x y
55+ | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract ringInt x y
56+ convert other = other
57+ fnZero = (C.dataSemiring, C.zero)
58+ fnOne = (C.dataSemiring, C.one)
59+ fnBottom = (C.dataBounded, C.bottom)
60+ fnTop = (C.dataBounded, C.top)
61+ fnAdd = (C.dataSemiring, C.add)
62+ fnMultiply = (C.dataSemiring, C.mul)
63+ fnSubtract = (C.dataRing, C.sub)
64+ fnNegate = (C.dataRing, C.negate)
65+ intOp ss op (_, d) x y = Binary ss op (unbox x d) (unbox y d)
66+
67+inlineCommonOperators :: AST -> AST
68+inlineCommonOperators = everywhereTopDown $ applyAll $
69+ [ binary semiringNumber opAdd Add
70+ , binary semiringNumber opMul Multiply
71+
72+ , binary ringNumber opSub Subtract
73+ , unary ringNumber opNegate Negate
74+
75+ , binary euclideanRingNumber opDiv Divide
76+
77+ -- , binary eqNumber opEq EqualTo
78+ -- , binary eqNumber opNotEq NotEqualTo
79+ , binary eqInt opEq EqualTo
80+ , binary eqInt opNotEq NotEqualTo
81+ , binary eqString opEq EqualTo
82+ , binary eqString opNotEq NotEqualTo
83+ , binary eqChar opEq EqualTo
84+ , binary eqChar opNotEq NotEqualTo
85+ , binary eqBoolean opEq EqualTo
86+ , binary eqBoolean opNotEq NotEqualTo
87+
88+ , binary ordBoolean opLessThan LessThan
89+ , binary ordBoolean opLessThanOrEq LessThanOrEqualTo
90+ , binary ordBoolean opGreaterThan GreaterThan
91+ , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo
92+ , binary ordChar opLessThan LessThan
93+ , binary ordChar opLessThanOrEq LessThanOrEqualTo
94+ , binary ordChar opGreaterThan GreaterThan
95+ , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo
96+ , binary ordInt opLessThan LessThan
97+ , binary ordInt opLessThanOrEq LessThanOrEqualTo
98+ , binary ordInt opGreaterThan GreaterThan
99+ , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo
100+ , binary ordNumber opLessThan LessThan
101+ , binary ordNumber opLessThanOrEq LessThanOrEqualTo
102+ , binary ordNumber opGreaterThan GreaterThan
103+ , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo
104+ , binary ordString opLessThan LessThan
105+ , binary ordString opLessThanOrEq LessThanOrEqualTo
106+ , binary ordString opGreaterThan GreaterThan
107+ , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo
108+
109+ , binary semigroupString opAppend Add
110+
111+ , binary heytingAlgebraBoolean opConj And
112+ , binary heytingAlgebraBoolean opDisj Or
113+ , unary heytingAlgebraBoolean opNot Not
114+
115+ , binary' C.dataIntBits C.or BitwiseOr
116+ , binary' C.dataIntBits C.and BitwiseAnd
117+ , binary' C.dataIntBits C.xor BitwiseXor
118+ , binary' C.dataIntBits C.shl ShiftLeft
119+ , binary' C.dataIntBits C.shr ShiftRight
120+ , unary' C.dataIntBits C.complement BitwiseNot
121+
122+ , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x]
123+ , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x]
124+ , inlineUnsafeIndex (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)
125+ ] ++
126+ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++
127+ [ fn | i <- [0..10], fn <- [ mkEffFn C.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++
128+ [ fn | i <- [0..10], fn <- [ mkEffFn C.effectUncurried C.mkEffectFn i, runEffFn C.effectUncurried C.runEffectFn i ] ]
129+ where
130+ binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST
131+ binary dict@(_, d) fns op = convert where
132+ convert :: AST -> AST
133+ convert (App ss (App _ (App _ fn [dict']) [x]) [y])
134+ | isDict dict dict' && isDict fns fn = Binary ss op (unbox x d) (unbox y d)
135+ convert other = other
136+ binary' :: Text -> PSString -> BinaryOperator -> AST -> AST
137+ binary' moduleName opString op = convert where
138+ convert :: AST -> AST
139+ convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op (unbox x mn) (unbox y mn)
140+ convert other = other
141+ mn :: PSString
142+ mn = mkString moduleName
143+ unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST
144+ unary dicts@(_, d) fns op = convert where
145+ convert :: AST -> AST
146+ convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op (unbox x d)
147+ convert other = other
148+ unary' :: Text -> PSString -> UnaryOperator -> AST -> AST
149+ unary' moduleName fnName op = convert where
150+ convert :: AST -> AST
151+ convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op (unbox x fnName)
152+ convert other = other
153+
154+ mkFn :: Int -> AST -> AST
155+ mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args il ->
156+ Function ss1 Nothing args (Block ss2 [Return ss3 il])
157+
158+ mkEffFn :: Text -> Text -> Int -> AST -> AST
159+ mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args il ->
160+ Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 il [])])
161+
162+ mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST
163+ mkFn' modName fnName res 0 = convert where
164+ convert :: AST -> AST
165+ convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 il])]) | isNFn modName fnName 0 mkFnN =
166+ res s1 s2 s3 [] il
167+ convert other = other
168+ mkFn' modName fnName res n = convert where
169+ convert :: AST -> AST
170+ convert orig@(App ss mkFnN [fn]) | isNFn modName fnName n mkFnN =
171+ case collectArgs n [] fn of
172+ Just (args, [Return ss' ret]) -> res ss ss ss' args ret
173+ _ -> orig
174+ convert other = other
175+ collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST])
176+ collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ il)) | length acc == n - 1 = Just (reverse (oneArg : acc), il)
177+ collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
178+ collectArgs _ _ _ = Nothing
179+
180+ isNFn :: Text -> Text -> Int -> AST -> Bool
181+ isNFn expectMod prefix n (Indexer _ (Var _ name) (Var _ modName)) | modName == expectMod =
182+ name == fromString (T.unpack prefix <> show n)
183+ isNFn _ _ _ _ = False
184+
185+ runFn :: Int -> AST -> AST
186+ runFn = runFn' C.dataFunctionUncurried C.runFn (\ss f args ->
187+ let len = length args
188+ typ = mkString $ uncurriedFnType len in
189+ if len > 0
190+ then App ss (App Nothing (StringLiteral Nothing typ) [f]) args
191+ else App ss f args)
192+ runEffFn :: Text -> Text -> Int -> AST -> AST
193+ runEffFn modName fnName = runFn' modName fnName $ \ss fn acc ->
194+ let typ = mkString . uncurriedFnType $ length acc in
195+ Function ss Nothing [] (Block ss [Return ss (App ss (App Nothing (StringLiteral Nothing typ) [fn]) acc)])
196+
197+ runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST
198+ runFn' modName runFnName res n = convert where
199+ convert :: AST -> AST
200+ convert il = fromMaybe il $ go n [] il
201+
202+ go :: Int -> [AST] -> AST -> Maybe AST
203+ go 0 acc (App ss runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n =
204+ Just $ res ss fn acc
205+ go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs
206+ go _ _ _ = Nothing
207+
208+ inlineNonClassFunction :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
209+ inlineNonClassFunction p f = convert where
210+ convert :: AST -> AST
211+ convert (App _ (App _ op' [x]) [y]) | p op' = f x y
212+ convert other = other
213+
214+ inlineUnsafeIndex :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
215+ inlineUnsafeIndex p _ = convert where
216+ convert :: AST -> AST
217+ convert (App _ (App ss op' [x]) [y@NumericLiteral{}])
218+ | p op' = Indexer ss y x
219+ convert (App _ (App ss op' [x]) [y])
220+ | p op' = App ss (Var Nothing indexFn) [x, y]
221+ convert other = other
222+
223+ isModFn :: (Text, PSString) -> AST -> Bool
224+ isModFn (m, op) (Indexer _ (Var _ op') (Var _ m')) =
225+ m == m' && decodeString op == Just op'
226+ isModFn _ _ = False
227+
228+ isModFnWithDict :: (Text, PSString) -> AST -> Bool
229+ isModFnWithDict (m, op) (App _ (Indexer _ (Var _ op') (Var _ m')) [Var _ _]) =
230+ m == m' && decodeString op == Just op'
231+ isModFnWithDict _ _ = False
232+
233+-- (f <<< g $ x) = f (g x)
234+-- (f <<< g) = \x -> f (g x)
235+inlineFnComposition :: forall m. MonadSupply m => AST -> m AST
236+inlineFnComposition = everywhereTopDownM convert where
237+ convert :: AST -> m AST
238+ convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z])
239+ | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]]
240+ | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]]
241+ convert app@(App ss (App _ (App _ fn [dict']) _) _)
242+ | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName'
243+ convert other = return other
244+
245+ mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST
246+ mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) []
247+ where
248+ vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns
249+ comp = Function ss Nothing [a] (Block ss [Return Nothing apps])
250+ apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns
251+
252+ mkApp :: Either AST (Text, AST) -> AST
253+ mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name
254+
255+ goApps :: AST -> m [Either AST (Text, AST)]
256+ goApps (App _ (App _ (App _ fn [dict']) [x]) [y])
257+ | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y
258+ | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x
259+ goApps app@(App {}) = pure . Right . (,app) <$> freshName'
260+ goApps other = pure [Left other]
261+
262+ isFnCompose :: AST -> AST -> Bool
263+ isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn
264+
265+ isFnComposeFlipped :: AST -> AST -> Bool
266+ isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn
267+
268+ fnCompose :: forall a b. (IsString a, IsString b) => (a, b)
269+ fnCompose = (C.controlSemigroupoid, C.compose)
270+
271+ fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)
272+ fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)
273+
274+inlineUnsafeCoerce :: AST -> AST
275+inlineUnsafeCoerce = everywhereTopDown convert where
276+ convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])
277+ | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce
278+ = comp
279+ convert other = other
280+
281+inlineUnsafePartial :: AST -> AST
282+inlineUnsafePartial = everywhereTopDown convert where
283+ convert (App ss fn [ comp ])
284+ | isDict fnUnsafePartial fn
285+ = App ss comp []
286+ where
287+ fnUnsafePartial :: forall a b. (IsString a, IsString b) => (a, b)
288+ fnUnsafePartial = (C.partialUnsafe, C.unsafePartial)
289+ convert other = other
290+
291+semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)
292+semiringNumber = (C.dataSemiring, C.semiringNumber)
293+
294+semiringInt :: forall a b. (IsString a, IsString b) => (a, b)
295+semiringInt = (C.dataSemiring, C.semiringInt)
296+
297+ringNumber :: forall a b. (IsString a, IsString b) => (a, b)
298+ringNumber = (C.dataRing, C.ringNumber)
299+
300+ringInt :: forall a b. (IsString a, IsString b) => (a, b)
301+ringInt = (C.dataRing, C.ringInt)
302+
303+euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b)
304+euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)
305+
306+-- eqNumber :: forall a b. (IsString a, IsString b) => (a, b)
307+-- eqNumber = (C.dataEq, C.eqNumber)
308+
309+eqInt :: forall a b. (IsString a, IsString b) => (a, b)
310+eqInt = (C.dataEq, C.eqInt)
311+
312+eqString :: forall a b. (IsString a, IsString b) => (a, b)
313+eqString = (C.dataEq, C.eqString)
314+
315+eqChar :: forall a b. (IsString a, IsString b) => (a, b)
316+eqChar = (C.dataEq, C.eqChar)
317+
318+eqBoolean :: forall a b. (IsString a, IsString b) => (a, b)
319+eqBoolean = (C.dataEq, C.eqBoolean)
320+
321+ordBoolean :: forall a b. (IsString a, IsString b) => (a, b)
322+ordBoolean = (C.dataOrd, C.ordBoolean)
323+
324+ordNumber :: forall a b. (IsString a, IsString b) => (a, b)
325+ordNumber = (C.dataOrd, C.ordNumber)
326+
327+ordInt :: forall a b. (IsString a, IsString b) => (a, b)
328+ordInt = (C.dataOrd, C.ordInt)
329+
330+ordString :: forall a b. (IsString a, IsString b) => (a, b)
331+ordString = (C.dataOrd, C.ordString)
332+
333+ordChar :: forall a b. (IsString a, IsString b) => (a, b)
334+ordChar = (C.dataOrd, C.ordChar)
335+
336+semigroupString :: forall a b. (IsString a, IsString b) => (a, b)
337+semigroupString = (C.dataSemigroup, C.semigroupString)
338+
339+boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b)
340+boundedBoolean = (C.dataBounded, C.boundedBoolean)
341+
342+heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b)
343+heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)
344+
345+semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b)
346+semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)
347+
348+opAdd :: forall a b. (IsString a, IsString b) => (a, b)
349+opAdd = (C.dataSemiring, C.add)
350+
351+opMul :: forall a b. (IsString a, IsString b) => (a, b)
352+opMul = (C.dataSemiring, C.mul)
353+
354+opEq :: forall a b. (IsString a, IsString b) => (a, b)
355+opEq = (C.dataEq, C.eq)
356+
357+opNotEq :: forall a b. (IsString a, IsString b) => (a, b)
358+opNotEq = (C.dataEq, C.notEq)
359+
360+opLessThan :: forall a b. (IsString a, IsString b) => (a, b)
361+opLessThan = (C.dataOrd, C.lessThan)
362+
363+opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
364+opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)
365+
366+opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b)
367+opGreaterThan = (C.dataOrd, C.greaterThan)
368+
369+opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
370+opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)
371+
372+opAppend :: forall a b. (IsString a, IsString b) => (a, b)
373+opAppend = (C.dataSemigroup, C.append)
374+
375+opSub :: forall a b. (IsString a, IsString b) => (a, b)
376+opSub = (C.dataRing, C.sub)
377+
378+opNegate :: forall a b. (IsString a, IsString b) => (a, b)
379+opNegate = (C.dataRing, C.negate)
380+
381+opDiv :: forall a b. (IsString a, IsString b) => (a, b)
382+opDiv = (C.dataEuclideanRing, C.div)
383+
384+opConj :: forall a b. (IsString a, IsString b) => (a, b)
385+opConj = (C.dataHeytingAlgebra, C.conj)
386+
387+opDisj :: forall a b. (IsString a, IsString b) => (a, b)
388+opDisj = (C.dataHeytingAlgebra, C.disj)
389+
390+opNot :: forall a b. (IsString a, IsString b) => (a, b)
391+opNot = (C.dataHeytingAlgebra, C.not)
392+
393+unbox :: AST -> PSString -> AST
394+unbox e d = select . inlineCommonValues $ inlineCommonOperators e
395+ where
396+ select :: AST -> AST
397+ select e' =
398+ case e' of
399+ Var{} -> unbox' e'
400+ App{} -> unbox' e'
401+ Indexer{} -> unbox' e'
402+ _ -> e'
403+ unbox' :: AST -> AST
404+ unbox' e' = maybe e' (\t -> App Nothing (StringLiteral Nothing t) [e']) $ unboxType d
405+
406+unboxType :: PSString -> Maybe PSString
407+unboxType s = do
408+ t <- decodeString s
409+ t' <- unboxType' t
410+ return $ mkString t'
411+ where
412+ unboxType' :: Text -> Maybe Text
413+ unboxType' t
414+ | t == C.eqInt ||
415+ t == C.semiringInt ||
416+ t == C.ringInt ||
417+ t == C.ordInt ||
418+ t == C.dataIntBits
419+ = Just int
420+ | t == C.semiringNumber ||
421+ t == C.ringNumber ||
422+ t == C.ordNumber ||
423+ t == C.euclideanRingNumber
424+ = Just float
425+ | t == C.eqBoolean ||
426+ t == C.ordBoolean ||
427+ t == C.heytingAlgebraBoolean
428+ = Just bool
429+ | t == C.eqChar ||
430+ t == C.eqString ||
431+ t == C.ordChar ||
432+ t == C.ordString ||
433+ t == C.semigroupString
434+ = Just string
435+ | otherwise = Nothing
src/CodeGen/IL/Optimizer/MagicDo.hsnew file+146
@@ -0,0 +1,146 @@
1+-- | This module implements the "Magic Do" optimization, which inlines calls to return
2+-- and bind for the Eff monad, as well as some of its actions.
3+module CodeGen.IL.Optimizer.MagicDo (magicDoEffect, magicDoEff, magicDoST, inlineST) where
4+
5+import Prelude.Compat
6+import Protolude (ordNub)
7+
8+import Data.Maybe (fromJust, isJust)
9+import Data.Text (Text)
10+
11+import Language.PureScript.CoreImp.AST
12+import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
13+import Language.PureScript.PSString (PSString, decodeString, mkString)
14+import qualified Language.PureScript.Constants as C
15+
16+import CodeGen.IL.Common (undefinedName, unusedName)
17+import CodeGen.IL.Optimizer.Common
18+
19+-- | Inline type class dictionaries for >>= and return for the Eff monad
20+--
21+-- E.g.
22+--
23+-- Prelude[">>="](dict)(m1)(function(x) {
24+-- return ...;
25+-- })
26+--
27+-- becomes
28+--
29+-- function __do {
30+-- var x = m1();
31+-- ...
32+-- }
33+magicDoEff :: AST -> AST
34+magicDoEff = magicDo C.eff C.effDictionaries
35+
36+magicDoEffect :: AST -> AST
37+magicDoEffect = magicDo C.effect C.effectDictionaries
38+
39+magicDoST :: AST -> AST
40+magicDoST = magicDo C.st C.stDictionaries
41+
42+magicDo :: Text -> C.EffectDictionaries -> AST -> AST
43+magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert
44+ where
45+ -- Desugar monomorphic calls to >>= and return for the Eff monad
46+ convert :: AST -> AST
47+ -- Desugar pure
48+ convert (App _ (App _ pure' [val]) []) | isPure pure' = val
49+ -- Desugar discard
50+ convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 il)]) | isDiscard bind && unused == unusedName =
51+ Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns il )
52+ -- Desugar bind
53+ convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 il)]) | isBind bind =
54+ Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns il)
55+ -- Desugar untilE
56+ convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f =
57+ App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []
58+ -- Desugar whileE
59+ convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f =
60+ App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []
61+ -- -- Inline __do returns
62+ -- convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body
63+ -- Inline double applications
64+ convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
65+ App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
66+ convert other = other
67+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad
68+ isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
69+ isBind _ = False
70+ -- Check if an expression represents a call to @discard@
71+ isDiscard (App _ (App _ fn [dict1]) [dict2])
72+ | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
73+ isDict (effectModule, edBindDict) dict2 &&
74+ isDiscardPoly fn = True
75+ isDiscard _ = False
76+
77+ -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
78+ isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True
79+ isPure _ = False
80+ -- Check if an expression represents the polymorphic >>= function
81+ isBindPoly = isDict (C.controlBind, C.bind)
82+ -- Check if an expression represents the polymorphic pure function
83+ isPurePoly = isDict (C.controlApplicative, C.pure')
84+ -- Check if an expression represents the polymorphic discard function
85+ isDiscardPoly = isDict (C.controlBind, C.discard)
86+ -- Check if an expression represents a function in the Effect module
87+ isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == effectModule && name == name'
88+ isEffFunc _ _ = False
89+
90+ applyReturns :: AST -> AST
91+ applyReturns (Return ss ret) = Return ss (App ss ret [])
92+ applyReturns (Block ss ils) = Block ss (map applyReturns ils)
93+ applyReturns (While ss cond il) = While ss cond (applyReturns il)
94+ applyReturns (For ss v lo hi il) = For ss v lo hi (applyReturns il)
95+ applyReturns (ForIn ss v xs il) = ForIn ss v xs (applyReturns il)
96+ applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
97+ applyReturns other = other
98+
99+-- | Inline functions in the ST module
100+inlineST :: AST -> AST
101+inlineST = everywhere convertBlock
102+ where
103+ -- Look for runST blocks and inline the STRefs there.
104+ -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
105+ -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
106+ convertBlock (App s1 f [arg]) | isSTFunc C.runST f =
107+ let refs = ordNub . findSTRefsIn $ arg
108+ usages = findAllSTUsagesIn arg
109+ allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
110+ localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
111+ in App s1 (everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg) []
112+ convertBlock other = other
113+ -- Convert a block in a safe way, preserving object wrappers of references,
114+ -- or in a more aggressive way, turning wrappers into local variables depending on the
115+ -- agg(ressive) parameter.
116+ convert agg (App s1 f [arg]) | isSTFunc C.newSTRef f =
117+ Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]])
118+ convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f =
119+ if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref
120+ convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f =
121+ if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg
122+ convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f =
123+ if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref])
124+ convert _ other = other
125+ -- Check if an expression represents a function in the ST module
126+ isSTFunc name (Indexer _ (StringLiteral _ name') (Var _ st)) = st == C.st && name == name'
127+ isSTFunc _ _ = False
128+ -- Find all ST Refs initialized in this block
129+ findSTRefsIn = everything (++) isSTRef
130+ where
131+ isSTRef (VariableIntroduction _ ident (Just (App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]
132+ isSTRef _ = []
133+ -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
134+ findAllSTUsagesIn = everything (++) isSTUsage
135+ where
136+ isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]
137+ isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
138+ isSTUsage _ = []
139+ -- Find all uses of a variable
140+ appearingIn ref = everything (++) isVar
141+ where
142+ isVar e@(Var _ v) | v == ref = [e]
143+ isVar _ = []
144+ -- Convert a AST value to a String if it is a Var
145+ toVar (Var _ v) = Just v
146+ toVar _ = Nothing
src/CodeGen/Cpp/Optimizer/TCO.hs → src/CodeGen/IL/Optimizer/TCO.hsrenamed+16−18
@@ -1,4 +1,4 @@
1−module CodeGen.Cpp.Optimizer.TCO (tco) where
1+module CodeGen.IL.Optimizer.TCO (tco, tcoLoop) where
22
33import Prelude.Compat
44
@@ -7,23 +7,26 @@ import Data.Monoid ((<>))
77import Language.PureScript.CoreImp.AST
88import Language.PureScript.AST.SourcePos (SourceSpan)
99import Safe (headDef, tailSafe)
10−import CodeGen.Cpp.Common
10+import CodeGen.IL.Common
1111
1212import qualified Language.PureScript.Constants as C
1313
14+tcoLoop :: Text
15+tcoLoop = "ṩtco_loop"
16+
1417tco :: AST -> AST -> AST
1518tco mn = everywhere convert where
1619 tcoVar :: Text -> Text
17− tcoVar arg = "_TCO_" <> arg <> "_"
20+ tcoVar arg = "ṩtco_var_" <> arg
1821
1922 copyVar :: Text -> Text
20− copyVar arg = "_TCO_Copy_" <> arg <> "_"
23+ copyVar arg = "ṩcopy_" <> arg
2124
2225 tcoDone :: Text
23− tcoDone = "_TCO_Done_"
26+ tcoDone = "ṩtco_done"
2427
2528 tcoResult :: Text
26− tcoResult = "_TCO_Result_"
29+ tcoResult = "ṩtco_result"
2730
2831 convert :: AST -> AST
2932 convert fn@(Function ss (Just name) args _)
@@ -37,7 +40,6 @@ tco mn = everywhere convert where
3740 | isTailRecursive name body'
3841 = Assignment ss (Var ss name) (replace (toLoop name outerArgs innerArgs body'))
3942 where
40− -- fn = Function ss' Nothing args (Block ss' stmts)
4143 innerArgs = headDef [] argss
4244 outerArgs = concat . reverse $ tailSafe argss
4345 (argss, body', replace) = collectAllFunctionArgs [] id fn
@@ -90,18 +92,14 @@ tco mn = everywhere convert where
9092 toLoop :: Text -> [Text] -> [Text] -> AST -> AST
9193 toLoop ident outerArgs innerArgs js =
9294 Block rootSS $
93− concatMap (\arg -> [ VariableIntroduction rootSS (tcoVar arg) Nothing
94− , Assignment rootSS (Var rootSS (tcoVar arg)) (Var rootSS (copyVar arg)) ]) (outerArgs ++ innerArgs) ++
95− -- [ VariableIntroduction rootSS (blockDecl <> tcoDone) Nothing
96− [ Var rootSS ("bool " <> tcoDone <> " = false")
97− -- , Assignment rootSS (Var rootSS tcoDone) (BooleanLiteral rootSS False)
98− -- , Assignment rootSS (Var rootSS tcoDone) (Var rootSS "NO")
95+ concatMap (\arg -> [ VariableIntroduction rootSS (tcoVar arg) . Just $
96+ Var rootSS (copyVar arg) ]) (outerArgs ++ innerArgs) ++
97+ [ Assignment rootSS (Var rootSS $ "var " <> tcoDone) $ BooleanLiteral Nothing False
9998 , VariableIntroduction rootSS tcoResult Nothing
100− , Assignment rootSS (Var rootSS ("const auto " <> tcoLoop)) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))
101− -- , While rootSS (Binary Nothing EqualTo (Var rootSS tcoDone) (BooleanLiteral Nothing False))
99+ , Assignment rootSS (Var rootSS $ "var " <> tcoLoop) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))
102100 , While rootSS (Unary Nothing Not (Var rootSS tcoDone))
103101 (Block rootSS
104− [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . tcoVar) innerArgs))))])
102+ [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))])
105103 , Return rootSS (Var rootSS tcoResult)
106104 ]
107105 where
@@ -117,7 +115,7 @@ tco mn = everywhere convert where
117115 zipWith (\val arg ->
118116 Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
119117 ++ zipWith (\val arg ->
120− Assignment ss (Var ss (tcoVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
118+ Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
121119 ++ [ ReturnNoResult ss ]
122120 | otherwise = Block ss [ markDone ss, Return ss ret ]
123121 loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]
@@ -130,7 +128,6 @@ tco mn = everywhere convert where
130128
131129 markDone :: Maybe SourceSpan -> AST
132130 markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True)
133− -- markDone ss = Assignment ss (Var ss tcoDone) (Var ss "YES")
134131
135132 collectArgs :: [[AST]] -> AST -> [[AST]]
136133 collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn
@@ -138,6 +135,7 @@ tco mn = everywhere convert where
138135
139136 isSelfCall :: Text -> AST -> Bool
140137 isSelfCall ident (App _ (Var _ ident') _) = ident == ident'
138+ isSelfCall ident (App _ (Indexer _ (Var _ ident') (Var _ mn')) _) = mn' == "" && ident == ident'
141139 isSelfCall ident (App _ (Indexer _ (Var _ ident') mn') _) = mn' == mn && ident == ident'
142140 isSelfCall ident (App _ fn _) = isSelfCall ident fn
143141 isSelfCall _ _ = False
src/CodeGen/IL/Printer.hsnew file+527
@@ -0,0 +1,527 @@
1+-- | Pretty printer for the AST
2+module CodeGen.IL.Printer
3+ ( prettyPrintIL
4+ , prettyPrintIL1
5+ , prettyPrintILWithSourceMaps
6+ , interfaceSource
7+ , implHeaderSource
8+ , implFooterSource
9+ , isLiteral
10+ , modLabel
11+ , modPrefix
12+ , ffiLoader
13+ ) where
14+
15+import Prelude.Compat
16+
17+import Control.Arrow ((<+>))
18+import Control.Monad (forM, mzero)
19+import Control.Monad.State (StateT, evalStateT)
20+import Control.PatternArrows
21+import Data.List (filter, (\\))
22+import qualified Control.Arrow as A
23+
24+import Data.Maybe (fromMaybe)
25+import Data.Monoid ((<>))
26+import Data.Text (Text)
27+import qualified Data.Text as T
28+
29+import Language.PureScript.AST (SourceSpan(..))
30+import Language.PureScript.CoreImp.AST
31+import Language.PureScript.Comments
32+import Language.PureScript.Crash
33+import Language.PureScript.Names (Ident, runIdent)
34+import Language.PureScript.Pretty.Common
35+import Language.PureScript.PSString (PSString, decodeString, mkString)
36+
37+import CodeGen.IL.Common
38+import CodeGen.IL.Optimizer.TCO (tcoLoop)
39+
40+import qualified Language.PureScript.Constants as C
41+
42+-- TODO (Christoph): Get rid of T.unpack / pack
43+
44+literals :: (Emit gen) => Pattern PrinterState AST gen
45+literals = mkPattern' match'
46+ where
47+ match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
48+ match' il = (addMapping' (getSourceSpan il) <>) <$> match il
49+
50+ match :: (Emit gen) => AST -> StateT PrinterState Maybe gen
51+ match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n
52+ match (StringLiteral _ s) = return $ emit $ stringLiteral s
53+ match (BooleanLiteral _ True) = return $ emit "true"
54+ match (BooleanLiteral _ False) = return $ emit "false"
55+ match (ArrayLiteral _ xs) = mconcat <$> sequence
56+ [ return . emit $ arrayType <> "{"
57+ , intercalate (emit ", ") <$> forM xs prettyPrintIL'
58+ , return $ emit "}"
59+ ]
60+ -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"
61+ match (ObjectLiteral _ ps) = mconcat <$> sequence
62+ [ return . emit $ dictType <> "{"
63+ , withIndent $ do
64+ ils <- forM ps $ \(key, value) -> do
65+ value' <- prettyPrintIL' value
66+ return $ objectPropertyToString key <> value'
67+ return $ intercalate (emit " ") $ map (<> emit ",") ils
68+ , return $ emit "}"
69+ ]
70+ where
71+ objectPropertyToString :: (Emit gen) => PSString -> gen
72+ objectPropertyToString s = emit $ stringLiteral s <> ": "
73+ match (Block _ sts) = mconcat <$> sequence
74+ [ return $ emit "{\n"
75+ , withIndent $ prettyStatements sts
76+ , return $ emit "\n"
77+ , currentIndent
78+ , return $ emit "}"
79+ ]
80+ match (Var _ ident) | ident == C.undefined = return $ emit undefinedName
81+ match (Var _ ident) = return $ emit ident
82+ match (VariableIntroduction _ ident value) = mconcat <$> sequence
83+ [ return . emit $ varDecl <> " " <> ident <> " " <> anyType
84+ , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintIL') value
85+ ]
86+ match (Assignment _ target value) = mconcat <$> sequence
87+ [ prettyPrintIL' target
88+ , return $ emit " = "
89+ , prettyPrintIL' value
90+ ]
91+ match (App _ val []) = mconcat <$> sequence
92+ [ return $ emit "Run("
93+ , prettyPrintIL' val
94+ , return $ emit ")"
95+ ]
96+ match (App _ (StringLiteral _ u) [arg])
97+ | Just ty <- decodeString u = mconcat <$> sequence
98+ [ prettyPrintIL' arg
99+ , return $ emit ".("
100+ , return $ emit ty
101+ , return $ emit ")"
102+ ]
103+ match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence
104+ [ return $ emit fn
105+ , return $ emit "("
106+ , prettyPrintIL' arg
107+ , return $ emit ")"
108+ ]
109+ match (App _ (Var _ fn) args) | fn == indexFn = mconcat <$> sequence
110+ [ return $ emit fn
111+ , return $ emit "("
112+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
113+ , return $ emit ")"
114+ ]
115+ match (App _ (Var _ fn) args) | fn == tcoLoop = mconcat <$> sequence
116+ [ return $ emit fn
117+ , return $ emit "("
118+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
119+ , return $ emit ")"
120+ ]
121+ match (App _ (App Nothing (StringLiteral Nothing fnx) [fn@Function{}]) args)
122+ | Just ftype <- decodeString fnx
123+ , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
124+ [ prettyPrintIL' fn
125+ , return $ emit "("
126+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
127+ , return $ emit ")"
128+ ]
129+ match (App _ (App Nothing (StringLiteral Nothing fnx) [fn]) args)
130+ | Just ftype <- decodeString fnx
131+ , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
132+ [ prettyPrintIL' fn
133+ , return $ emit ".("
134+ , return $ emit ftype
135+ , return $ emit ")("
136+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
137+ , return $ emit ")"
138+ ]
139+ match app@(App{})
140+ | (val, args) <- unApp app []
141+ , length args > 1
142+ = mconcat <$> sequence
143+ [ return $ emit "Apply("
144+ , prettyPrintIL' val
145+ , return $ emit ", "
146+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
147+ , return $ emit ")"
148+ ]
149+ match (App _ val args) = mconcat <$> sequence
150+ [ return $ emit "Apply("
151+ , prettyPrintIL' val
152+ , return $ emit ", "
153+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
154+ , return $ emit ")"
155+ ]
156+ match (Function _ (Just name) [] (Block _ [Return _ ret]))
157+ | isComplexLiteral ret = mconcat <$> sequence
158+ [ return $ emit "\n"
159+ , return . emit $ varDecl <> " " <> initName name <> " Once\n"
160+ , prettyPrintIL' $ VariableIntroduction Nothing (valueName name) Nothing
161+ , return $ emit "\n\n"
162+ , return $ emit "func "
163+ , return . emit $ withPrefix name
164+ , return . emit $ "() " <> anyType <> " "
165+ , return $ emit "{\n"
166+ , withIndent $ do
167+ indentString <- currentIndent
168+ return $ indentString <> (emit $ initName name <> ".Do(func() {\n") <>
169+ indentString <> indentString <> (emit $ valueName name <> " = ")
170+ , withIndent $ do
171+ case ret of
172+ Function _ Nothing args body -> mconcat <$> sequence
173+ [ return $ emit "func("
174+ , return . emit $ intercalate ", " (renderArg anyType <$> args)
175+ , return . emit $ ") " <> anyType <> " "
176+ , prettyPrintIL' body
177+ ]
178+ _ -> do
179+ prettyPrintIL' ret
180+ , return $ emit "\n"
181+ , withIndent $ do
182+ indentString <- currentIndent
183+ return $ indentString <> (emit $ "})\n" <> "return " <> valueName name <>"\n")
184+ , return $ emit "}\n\n"
185+ ]
186+ match (Function _ (Just name) [] ret) = mconcat <$> sequence
187+ [ return $ emit "func "
188+ , return . emit $ withPrefix name
189+ , return . emit $ "() " <> anyType <> " "
190+ , prettyPrintIL' ret
191+ ]
192+ match (Function _ _ args ret) = mconcat <$> sequence
193+ [ return $ emit "func("
194+ , return . emit $ intercalate ", " (renderArg anyType <$> args)
195+ , return . emit $ ") " <> anyType <> " "
196+ , prettyPrintIL' ret
197+ ]
198+ match (Indexer _ (Var _ name) (Var _ "")) = mconcat <$> sequence
199+ [ prettyPrintIL' (Var Nothing $ withPrefix name)
200+ , return $ emit "()"
201+ ]
202+ match (Indexer _ (Var _ name) val) = mconcat <$> sequence
203+ [ prettyPrintIL' val
204+ , return $ emit "."
205+ , prettyPrintIL' (Var Nothing $ withPrefix name)
206+ , return $ emit "()"
207+ ]
208+ match (Indexer _ prop@StringLiteral{} val@ObjectLiteral{}) = mconcat <$> sequence
209+ [ prettyPrintIL' val
210+ , return $ emit "["
211+ , prettyPrintIL' prop
212+ , return $ emit "]"
213+ ]
214+ match (Indexer _ prop@StringLiteral{} val) = mconcat <$> sequence
215+ [ prettyPrintIL' val
216+ , return $ emit ".("
217+ , return $ emit dictType
218+ , return $ emit ")["
219+ , prettyPrintIL' prop
220+ , return $ emit "]"
221+ ]
222+ match (Indexer _ index val@ArrayLiteral{}) = mconcat <$> sequence
223+ [ prettyPrintIL' val
224+ , return $ emit "["
225+ , prettyPrintIL' index
226+ , return $ emit "]"
227+ ]
228+ match (Indexer _ index val) = mconcat <$> sequence
229+ [ prettyPrintIL' val
230+ , return $ emit ".("
231+ , return $ emit arrayType
232+ , return $ emit ")["
233+ , prettyPrintIL' index
234+ , return $ emit "]"
235+ ]
236+ match (InstanceOf _ val ty) = mconcat <$> sequence
237+ [ return $ emit "Is("
238+ , prettyPrintIL' val
239+ , return $ emit ", "
240+ , prettyPrintIL' ty
241+ , return $ emit ")"
242+ ]
243+ match (While _ cond sts) = mconcat <$> sequence
244+ [ return $ emit "for "
245+ , prettyPrintIL' cond
246+ , return $ emit " "
247+ , prettyPrintIL' sts
248+ ]
249+ match (For _ ident start end sts) = mconcat <$> sequence
250+ [ return $ emit $ "for var " <> ident <> " = "
251+ , prettyPrintIL' start
252+ , return $ emit $ "; " <> ident <> " < "
253+ , prettyPrintIL' end
254+ , return $ emit $ "; " <> ident <> "++ "
255+ , prettyPrintIL' sts
256+ ]
257+ match (ForIn _ ident obj sts) = mconcat <$> sequence
258+ [ return $ emit $ "for var " <> ident <> " in "
259+ , prettyPrintIL' obj
260+ , return $ emit " "
261+ , prettyPrintIL' sts
262+ ]
263+ match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
264+ [ return $ emit "if "
265+ , prettyPrintIL' cond
266+ , return $ emit " "
267+ , prettyPrintIL' thens
268+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
269+ ]
270+ match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
271+ [ return $ emit "if !("
272+ , prettyPrintIL' cond
273+ , return $ emit ") "
274+ , prettyPrintIL' thens
275+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
276+ ]
277+ match (IfElse _ cond thens elses) = mconcat <$> sequence
278+ [ return $ emit "if "
279+ , prettyPrintIL' cond
280+ , return $ emit " "
281+ , prettyPrintIL' thens
282+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
283+ ]
284+ match (Return _ value) = mconcat <$> sequence
285+ [ return $ emit "return "
286+ , prettyPrintIL' value
287+ ]
288+ match (ReturnNoResult _) = return . emit $ "return " <> undefinedName
289+ -- match (Throw _ _) = return mempty
290+ match (Throw _ value) = mconcat <$> sequence
291+ [ return $ emit "panic("
292+ , prettyPrintIL' value
293+ , return $ emit ")"
294+ ]
295+ match (Comment _ com il) = mconcat <$> sequence
296+ [ return $ emit "\n"
297+ , mconcat <$> forM com comment
298+ , prettyPrintIL' il
299+ ]
300+ match _ = mzero
301+
302+ comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
303+ comment (LineComment com) = fmap mconcat $ sequence $
304+ [ currentIndent
305+ , return $ emit "//" <> emit com <> emit "\n"
306+ ]
307+ comment (BlockComment com) = fmap mconcat $ sequence $
308+ [ currentIndent
309+ , return $ emit "/**\n"
310+ ] ++
311+ map asLine (T.lines com) ++
312+ [ currentIndent
313+ , return $ emit " */\n"
314+ , currentIndent
315+ ]
316+ where
317+ asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen
318+ asLine s = do
319+ i <- currentIndent
320+ return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
321+
322+ removeComments :: Text -> Text
323+ removeComments t =
324+ case T.stripPrefix "*/" t of
325+ Just rest -> removeComments rest
326+ Nothing -> case T.uncons t of
327+ Just (x, xs) -> x `T.cons` removeComments xs
328+ Nothing -> ""
329+
330+unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
331+unary' op mkStr = Wrap match (<>)
332+ where
333+ match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
334+ match = mkPattern match'
335+ where
336+ match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)
337+ match' _ = Nothing
338+
339+unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
340+unary op str = unary' op (const str)
341+
342+negateOperator :: (Emit gen) => Operator PrinterState AST gen
343+negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
344+ where
345+ isNegate (Unary _ Negate _) = True
346+ isNegate _ = False
347+
348+binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen
349+binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)
350+ where
351+ match :: Pattern PrinterState AST (AST, AST)
352+ match = mkPattern match'
353+ where
354+ match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)
355+ match' _ = Nothing
356+
357+isLiteral :: AST -> Bool
358+isLiteral Function{} = True
359+isLiteral NumericLiteral{} = True
360+isLiteral StringLiteral{} = True
361+isLiteral BooleanLiteral{} = True
362+isLiteral ObjectLiteral{} = True
363+isLiteral ArrayLiteral{} = True
364+isLiteral _ = False
365+
366+isComplexLiteral :: AST -> Bool
367+-- isComplexLiteral Function{} = True
368+isComplexLiteral ObjectLiteral{} = True
369+isComplexLiteral ArrayLiteral{} = True
370+isComplexLiteral _ = False
371+
372+unApp :: AST -> [AST] -> (AST, [AST])
373+unApp (App _ val [arg]) args = unApp val (arg : args)
374+unApp other args = (other, args)
375+
376+prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
377+prettyStatements sts = do
378+ ils <- forM sts prettyPrintIL'
379+ indentString <- currentIndent
380+ return $ intercalate (emit "\n") $ map (indentString <>) ils
381+
382+-- | Generate a pretty-printed string representing a collection of C++ expressions at the same indentation level
383+prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])
384+prettyPrintILWithSourceMaps il =
385+ let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) il
386+ in (s, mp)
387+
388+prettyPrintIL :: [AST] -> Text
389+prettyPrintIL = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
390+
391+-- | Generate an indented, pretty-printed string representing a C++ expression
392+prettyPrintIL' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
393+prettyPrintIL' = A.runKleisli $ runPattern matchValue
394+ where
395+ matchValue :: (Emit gen) => Pattern PrinterState AST gen
396+ matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
397+ operators :: (Emit gen) => OperatorTable PrinterState AST gen
398+ operators =
399+ OperatorTable [ [ unary New "?" ]
400+ , [ unary Not "!"
401+ , unary BitwiseNot "~"
402+ , unary Positive "+"
403+ , negateOperator ]
404+ , [ binary Multiply "*"
405+ , binary Divide "/"
406+ , binary Modulus "%" ]
407+ , [ binary Add "+"
408+ , binary Subtract "-" ]
409+ , [ binary ShiftLeft "<<"
410+ , binary ShiftRight ">>" ]
411+ , [ binary LessThan "<"
412+ , binary LessThanOrEqualTo "<="
413+ , binary GreaterThan ">"
414+ , binary GreaterThanOrEqualTo ">=" ]
415+ , [ binary EqualTo "=="
416+ , binary NotEqualTo "!=" ]
417+ , [ binary BitwiseAnd "&" ]
418+ , [ binary BitwiseXor "^" ]
419+ , [ binary BitwiseOr "|" ]
420+ , [ binary And "&&" ]
421+ , [ binary Or "||" ]
422+ ]
423+
424+prettyPrintIL1 :: AST -> Text
425+prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'
426+
427+stringLiteral :: PSString -> Text
428+stringLiteral pss | Just s <- decodeString pss = stringLiteral' s
429+ where
430+ stringLiteral' :: Text -> Text
431+ stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""
432+ encodeChar :: Char -> Text
433+ encodeChar '\0' = "\\x00"
434+ encodeChar '\b' = "\\b"
435+ encodeChar '\t' = "\\t"
436+ encodeChar '\n' = "\\n"
437+ encodeChar '\v' = "\\v"
438+ encodeChar '\f' = "\\f"
439+ encodeChar '\r' = "\\r"
440+ encodeChar '"' = "\\\""
441+ encodeChar '\\' = "\\\\"
442+ encodeChar c = T.singleton $ c
443+stringLiteral _ = "\"\\uFFFD\""
444+
445+interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
446+interfaceSource _ _ _ = ""
447+
448+implHeaderSource :: Text -> [Text] -> Text -> Text
449+implHeaderSource mn imports otherPrefix =
450+ "// Code generated by psgo. DO NOT EDIT.\n\n" <>
451+ "package " <> (if mn == "Main" || mn == "Test_Main" then "main" else mn) <> "\n\n" <>
452+ "import . \"" <> runtime <> "\"\n" <>
453+ (if mn == "Main" || mn == "Test_Main"
454+ then "import _ \"" <> otherPrefix <> "/" <> ffiLoader <> "\"\n"
455+ else "\n") <>
456+ "import (\n" <>
457+ (T.concat $ formatImport <$> imports) <> ")\n\n" <>
458+ "type _ = Any\n\n"
459+ where
460+ formatImport :: Text -> Text
461+ formatImport s =
462+ "\t\"" <> otherPrefix <> "/" <> modPrefix <> "/" <> moduleRenamer s <> "\"\n"
463+ moduleRenamer :: Text -> Text
464+ moduleRenamer s
465+ | (s', sfx) <- T.breakOn moduleRenamerMarker s,
466+ not $ T.null sfx = s'
467+ moduleRenamer s = s
468+
469+implFooterSource :: Text -> [Ident] -> Text
470+implFooterSource mn foreigns =
471+ "\n\n\n" <>
472+ (if null foreigns
473+ then ""
474+ else ("// Foreign values\n\n" <>
475+ "var " <> foreignDict <> " = "<> foreignMod <> "(\"" <> mn <> "\")\n\n" <>
476+ (T.concat $ (\foreign' ->
477+ let name = moduleIdentToIL foreign' in
478+ varDecl <> " " <> initName name <> " Once\n" <>
479+ varDecl <> " " <> valueName name <> " " <> anyType <> "\n\n" <>
480+ "func " <>
481+ withPrefix name <>
482+ "() Any { \n" <>
483+ " " <> initName name <> ".Do(func() {\n" <>
484+ " " <> valueName name <> " = " <>
485+ "Get(" <> foreignDict <> ", " <>
486+ (stringLiteral . mkString $ runIdent foreign') <> ")\n" <>
487+ " })\n" <>
488+ " return " <> valueName name <> "\n" <>
489+ "}\n\n") <$> foreigns))) <>
490+ if mn == "Main" || mn == "Test.Main" then mainSource else "\n"
491+ where
492+ mainSource :: Text
493+ mainSource = "\
494+ \func main() {\n\
495+ \ Run(Ꞌmain())\n\
496+ \}\n\n\
497+ \"
498+
499+varDecl :: Text
500+varDecl = "var"
501+
502+renderArg :: Text -> Text -> Text
503+renderArg decl arg = arg <> " " <> decl
504+
505+foreignMod :: Text
506+foreignMod = "Foreign"
507+
508+foreignDict :: Text
509+foreignDict = "foreign"
510+
511+modLabel :: Text
512+modLabel = "purescript-native"
513+
514+modPrefix :: Text
515+modPrefix = modLabel <> "/output"
516+
517+runtime :: Text
518+runtime = "github.com/" <> modLabel <> "/go-runtime"
519+
520+ffiLoader :: Text
521+ffiLoader = modLabel <> "/ffi-loader"
522+
523+initName :: Text -> Text
524+initName s = "ᛌ" <> s <> "_once"
525+
526+valueName :: Text -> Text
527+valueName s = "ᛧ" <> s
src/Tests.hs+11−12
@@ -31,18 +31,13 @@ runTests = do
3131 let srcDir = outputDir </> "src"
3232 createDirectory srcDir
3333
34− callProcess "git" ["clone", "--branch", "v0.12.3", "--depth", "1", "https://github.com/purescript/purescript.git"]
34+ callProcess "git" ["clone", "--branch", "v0.13.8", "--depth", "1", "https://github.com/purescript/purescript.git"]
3535 let passingDir = baseDir </> "purescript" </> "tests" </> "purs" </> "passing"
3636 passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passingDir
3737
3838 setCurrentDirectory outputDir
39− callProcess "pscpp" ["--makefile"]
4039
4140 fetchPackages
42− callProcess "git" ["clone", "--depth", "1", "https://github.com/andyarvanitis/purescript-cpp-ffi.git", "ffi"]
43−
44− callProcess "rm" ["-rf", ".psc-package/psc-0.12.3/prelude/v4.1.0"]
45− callProcess "git" ["clone", "--depth", "1", "https://github.com/andyarvanitis/purescript-prelude.git", ".psc-package/psc-0.12.3/prelude/v4.1.0"]
4641
4742 let tests = filter (`notElem` skipped) passingTestCases
4843
@@ -65,14 +60,15 @@ runTests = do
6560 testCaseDirExists <- doesDirectoryExist testCaseDir
6661 when testCaseDirExists $ callProcess "cp" ["-R", testCaseDir, srcDir]
6762
68− callProcess "make" ["clean"]
69− callProcess "make" ["debug", "-j8"]
63+ callProcess "rm" ["-rf", "output"]
64+ callProcess "rm" ["-rf", "Main"]
65+ callProcess "spago" ["build"]
7066 --
71− -- Run C++ files
67+ -- Run executable file
7268 --
7369 outputFile <- openFile (tmp </> logpath </> logfile) AppendMode
7470 hPutStrLn outputFile ("\n" ++ inputFile ++ ":")
75− proc <- runProcess ("output" </> "bin" </> "main") [] Nothing Nothing Nothing (Just outputFile) Nothing
71+ proc <- runProcess ("./" </> "Main") [] Nothing Nothing Nothing (Just outputFile) Nothing
7672
7773 removeFile (srcDir </> inputFile)
7874 when testCaseDirExists $ callProcess "rm" ["-rf", srcDir </> (takeWhile (/='.') inputFile)]
@@ -116,8 +112,11 @@ packages =
116112fetchPackages :: IO ()
117113-------------------------------------------------------------------------------
118114fetchPackages = do
119− callProcess "psc-package" ["init"]
120− mapM (callProcess "psc-package" . (\p -> ["install", p])) packages
115+ callProcess "spago" ["init"]
116+ callCommand "sed '$s/\\(}\\)/, backend = \"psgo\"\\1/' < spago.dhall | dhall format > spago.tmp"
117+ callCommand "mv spago.tmp spago.dhall"
118+
119+ mapM (callProcess "spago" . (\p -> ["install", p])) packages
121120 return ()
122121
123122-------------------------------------------------------------------------------
stack.nixnew file+23
@@ -0,0 +1,23 @@
1+#
2+# You may need to manually run `unset STACK_IN_NIX_SHELL`
3+# (doesn't work from a `shellHook`; see: https://github.com/commercialhaskell/stack/issues/5000
4+#
5+#
6+# You may need to set LC_ALL when building, e.g.
7+# LC_ALL=en_US.iso88591 stack --nix build; see e.g. https://github.com/koalaman/shellcheck/issues/324
8+#
9+#
10+{ pkgs ?
11+ import (builtins.fetchTarball {
12+ name = "nixos-release-19.03";
13+ url = https://github.com/nixos/nixpkgs/archive/34c7eb7545d155cc5b6f499b23a7cb1c96ab4d59.tar.gz;
14+ sha256 = "11z6ajj108fy2q5g8y4higlcaqncrbjm3dnv17pvif6avagw4mcb";
15+ }) {}
16+}:
17+
18+pkgs.haskell.lib.buildStackProject {
19+ name = "default-stack-shell";
20+ ghc = pkgs.haskell.compiler.ghc865;
21+ buildInputs = with pkgs; [git git-lfs gmp ncurses zlib];
22+ LANG = "en_US.UTF-8";
23+}
stack.yaml+18−63
@@ -1,69 +1,24 @@
1−# This file was automatically generated by 'stack init'
2−#
3−# Some commonly used options have been documented as comments in this file.
4−# For advanced use and comprehensive documentation of the format, please see:
5−# https://docs.haskellstack.org/en/stable/yaml_configuration/
1+resolver: lts-13.26
62
7−# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8−# A snapshot resolver dictates the compiler version and the set of packages
9−# to be used for project dependencies. For example:
10−#
11−# resolver: lts-3.5
12−# resolver: nightly-2015-09-21
13−# resolver: ghc-7.10.2
14−# resolver: ghcjs-0.1.0_ghc-7.10.2
15−# resolver:
16−# name: custom-snapshot
17−# location: "./custom-snapshot.yaml"
18−resolver: lts-12.0
19−
20−# User packages to be built.
21−# Various formats can be used as shown in the example below.
22−#
23−# packages:
24−# - some-directory
25−# - https://example.com/foo/bar/baz-0.0.2.tar.gz
26−# - location:
27−# git: https://github.com/commercialhaskell/stack.git
28−# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29−# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30−# extra-dep: true
31−# subdirs:
32−# - auto-update
33−# - wai
34−#
35−# A package marked 'extra-dep: true' will only be built if demanded by a
36−# non-dependency (i.e. a user package), and its test suites and benchmarks
37−# will not be run. This is useful for tweaking upstream packages.
383packages:
394- .
40−# Dependency packages to be pulled from upstream that are not in the resolver
41−# (e.g., acme-missiles-0.3)
42−extra-deps:
43−- git: https://github.com/purescript/purescript
44− commit: v0.12.3
45−- pipes-http-1.0.5
465
47−# Override default flag values for local packages and extra-deps
48−# flags: {}
6+extra-deps:
7+- git: https://github.com/purescript/purescript
8+ commit: 9cad73ed8ea7df3011032ddbd2f3de5a0c08629c
9+- happy-1.19.9
10+- language-javascript-0.7.0.0
11+- network-3.0.1.1
12+- these-1.0.1
13+- semialign-1
4914
50−# Extra package databases containing global packages
51−# extra-package-dbs: []
15+nix:
16+ enable: false
17+ shell-file: stack.nix
5218
53−# Control whether we use the GHC we find on the path
54−# system-ghc: true
55−#
56−# Require a specific version of stack, using version ranges
57−# require-stack-version: -any # Default
58−# require-stack-version: ">=1.6"
59−#
60−# Override the architecture used by stack, especially useful on Windows
61−# arch: i386
62−# arch: x86_64
63−#
64−# Extra directories used by stack for building
65−# extra-include-dirs: [/path/to/dir]
66−# extra-lib-dirs: [/path/to/dir]
67−#
68−# Allow a newer minor version of GHC than the snapshot specifies
69−# compiler-check: newer-minor
19+flags:
20+ aeson-pretty:
21+ lib-only: true
22+ these:
23+ assoc: false
24+ quickcheck: false
support/Makefiledeleted−129
@@ -1,129 +0,0 @@
1−# PureScript to native binary (via C++) Makefile
2−#
3−# Run 'make' or 'make release' to build an optimized release build
4−# Run 'make debug' to build a non-optimized build suitable for debugging
5−#
6−# You can also perform a parallel build with 'make -jN', where N is the
7−# number of cores to use.
8−#
9−# PURS, SRC, OUTPUT, and BIN can all be overridden with the
10−# command itself. For example: 'make BIN=myutil'
11−#
12−# Flags can be added to either the codegen or native build phases.
13−# For example: 'make PURSFLAGS=--codegen,js CXXFLAGS=-DDEBUG LDFLAGS=lgmp'
14−#
15−# You can also edit the generated version of this file directly.
16−#
17−PURS := purs
18−PSC_PACKAGE := psc-package
19−PSCPP := pscpp
20−SRC := src
21−OUTPUT := output
22−CC_SRC := $(OUTPUT)/src
23−FFI_SRC := ffi
24−BIN := main
25−
26−override PURSFLAGS += compile --codegen corefn
27−override CXXFLAGS += --std=c++11
28−
29−CXXVERSION = $(shell $(CXX) --version)
30−ifneq (,$(findstring g++,$(CXXVERSION)))
31− PSCPPFLAGS += "--ucns"
32−endif
33−
34−DEBUG := "-DDEBUG -g"
35−RELEASE := "-DNDEBUG -O3"
36−
37−INCLUDES := -I $(CC_SRC)
38−BIN_DIR := $(OUTPUT)/bin
39−
40−PACKAGE_SOURCES = $(subst \,/,$(shell $(PSC_PACKAGE) sources))
41−PURESCRIPT_PKGS := $(firstword $(subst /, ,$(PACKAGE_SOURCES)))
42−
43−## Not all environments support globstar (** dir pattern)
44−rwildcard=$(wildcard $1$2) $(foreach d,$(wildcard $1*),$(call rwildcard,$d/,$2))
45−
46−unspecified:
47− @echo
48− @echo "Please specify the type of build you want: 'debug' or 'release'"
49− @echo
50− @echo " debug => not optimized (your app will run slower), good for"
51− @echo " running in a source-level debugger, more (descriptive)"
52− @echo " runtime exceptions"
53− @echo
54− @echo " release => optimized (your app will run faster), less helpful when debugging"
55− @echo
56−
57−debug: codegen
58− @$(MAKE) $(BIN) CFLAGS+=$(DEBUG) CXXFLAGS+=$(DEBUG)
59−
60−release: codegen
61− @$(MAKE) $(BIN) CFLAGS+=$(RELEASE) CXXFLAGS+=$(RELEASE)
62−
63−.PHONY: corefn
64−corefn: PURESCRIPT_PKG_SRCS=$(foreach d,$(PACKAGE_SOURCES),$(call rwildcard,$(firstword $(subst *, ,$(d))),*.purs))
65−corefn: PURESCRIPT_SRCS=$(call rwildcard,$(SRC)/,*.purs)
66−corefn: $(PURESCRIPT_PKGS)
67− @$(PURS) $(PURSFLAGS) --output $(OUTPUT) $(PURESCRIPT_PKG_SRCS) $(PURESCRIPT_SRCS)
68−
69−.PHONY: codegen
70−codegen: COREFN_SRCS=$(call rwildcard,$(OUTPUT)/,corefn.json)
71−codegen: corefn
72− @$(PSCPP) $(PSCPPFLAGS) $(COREFN_SRCS)
73−
74−$(PURESCRIPT_PKGS):
75− @echo "Getting packages using" $(PSC_PACKAGE) "..."
76− @$(PSC_PACKAGE) update
77−
78−SRCS := $(call rwildcard,$(CC_SRC)/,*.cpp)
79−SRCS += $(call rwildcard,$(FFI_SRC)/,*.cpp)
80−SRCS += $(call rwildcard,$(FFI_SRC)/,*.cc)
81−SRCS += $(call rwildcard,$(FFI_SRC)/,*.mm)
82−SRCS += $(call rwildcard,$(FFI_SRC)/,*.c)
83−SRCS += $(call rwildcard,$(FFI_SRC)/,*.m)
84−
85−OBJS1 = $(SRCS:.cpp=.o)
86−OBJS2 = $(OBJS1:.cc=.o)
87−OBJS3 = $(OBJS2:.mm=.o)
88−OBJS4 = $(OBJS3:.c=.o)
89−OBJS = $(OBJS4:.m=.o)
90−DEPS = $(OBJS:.o=.d)
91−
92−$(BIN): $(OBJS)
93− @echo "Linking" $(BIN_DIR)/$(BIN)
94− @mkdir -p $(BIN_DIR)
95− @$(CXX) $^ -o $(BIN_DIR)/$@ $(LDFLAGS)
96−
97−-include $(DEPS)
98−
99−%.o: %.cpp
100− @echo "Creating" $@ "(C++)"
101− @$(CXX) $(CXXFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@
102−
103−%.o: %.cc
104− @echo "Creating" $@ "(C++)"
105− @$(CXX) $(CXXFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@
106−
107−%.o: %.mm
108− @echo "Creating" $@ "(Objective-C++)"
109− @$(CXX) $(CXXFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@
110−
111−%.o: %.c
112− @echo "Creating" $@ "(C)"
113− @$(CXX) $(CFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@
114−
115−%.o: %.m
116− @echo "Creating" $@ "(Objective-C)"
117− @$(CXX) $(CFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@
118−
119−.PHONY: all
120−all: release
121−
122−.PHONY: clean
123−clean:
124− @-rm -f $(OBJS) $(DEPS)
125− @-rm -rf $(OUTPUT)
126−
127−.PHONY: run
128−run:
129− @$(BIN_DIR)/$(BIN) $(ARGS)
support/ffi-loader.gonew file+30
@@ -0,0 +1,30 @@
1+package ffi_loader
2+
3+// Load PureScript standard library FFI packages. Comment out the ones you don't need for
4+// faster/smaller builds.
5+
6+import (
7+ _ "github.com/purescript-native/go-ffi/purescript-arrays"
8+ _ "github.com/purescript-native/go-ffi/purescript-assert"
9+ _ "github.com/purescript-native/go-ffi/purescript-console"
10+ _ "github.com/purescript-native/go-ffi/purescript-effect"
11+ _ "github.com/purescript-native/go-ffi/purescript-enums"
12+ _ "github.com/purescript-native/go-ffi/purescript-exceptions"
13+ _ "github.com/purescript-native/go-ffi/purescript-foldable-traversable"
14+ _ "github.com/purescript-native/go-ffi/purescript-functions"
15+ _ "github.com/purescript-native/go-ffi/purescript-globals"
16+ _ "github.com/purescript-native/go-ffi/purescript-integers"
17+ _ "github.com/purescript-native/go-ffi/purescript-lazy"
18+ _ "github.com/purescript-native/go-ffi/purescript-math"
19+ _ "github.com/purescript-native/go-ffi/purescript-partial"
20+ _ "github.com/purescript-native/go-ffi/purescript-prelude"
21+ _ "github.com/purescript-native/go-ffi/purescript-random"
22+ _ "github.com/purescript-native/go-ffi/purescript-refs"
23+ _ "github.com/purescript-native/go-ffi/purescript-st"
24+ _ "github.com/purescript-native/go-ffi/purescript-strings"
25+ _ "github.com/purescript-native/go-ffi/purescript-unfoldable"
26+)
27+
28+// Add your own FFI packages here.
29+
30+import ()
support/go.mod.ffi-loadernew file+2
@@ -0,0 +1,2 @@
1+module $PROJECT/purescript-native/ffi-loader
2+
support/go.mod.outputnew file+2
@@ -0,0 +1,2 @@
1+module $PROJECT/purescript-native/output
2+
support/go.mod.workingnew file+1
@@ -0,0 +1 @@
1+module $PROJECT/example