git.iko.soy/rowtype-yoga/purescript-native
on 54ee44d help sign in
355eb9b
swap
0 ahead, 96 behind
.gitignore+2−2
since splitsnapshots
unifiedsplit
@@ -12,12 +12,12 @@ cabal.sandbox.config
12.test_modules/
12.test_modules/
13bower_components/
13bower_components/
14node_modules
14node_modules
15+pscpp.cabal
16+psgo.cabal
15tmp/
17tmp/
16.stack-work/
18.stack-work/
17−stack.yaml.lock
18output
19output
19examples/docs/docs/
20examples/docs/docs/
20core-tests/full-core-docs.md
21core-tests/full-core-docs.md
21.psc-ide-port
22.psc-ide-port
22.vscode/
23.vscode/
23−result
README-go.mddeleted−48
@@ -1,48 +0,0 @@
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+54−25
@@ -1,41 +1,70 @@
1[![PureScript](https://raw.githubusercontent.com/purescript/purescript/master/logo.png)](http://purescript.org)
1[![PureScript](https://raw.githubusercontent.com/purescript/purescript/master/logo.png)](http://purescript.org)
2
2
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.
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.
4
4
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).
5+---
6+
7+### **Please note that this project supersedes [pure11](https://github.com/pure11/pure11)**
8+
9+#### Please see [changes](https://github.com/andyarvanitis/purescript-native/wiki/changes) for more details.
10+
11+---
6
12
7#### Platforms
13#### Platforms
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:
14+* Generated C++ code and resulting binary executables tested (to at least some extent) on:
9− * macOS Mojave 10.14.5 – full test suite
10− * For C++, Xcode 10.2.1's `clang` was used
15+ * macOS Mojave, Xcode 10.1's clang (full test suite)
11− * For Go, `go` version 1.12.7 was used
12− * Windows 10 x64 – full test suite
13− * C++: Visual Studio 2017 and `clang`
16+ * Windows 10 x64 and x86, Visual Studio 2017
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 9.5 amd64, default versions of clang and gcc/g++ (full test suite)
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`
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).
20
48
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.
21
51
22−#### Requirements for building `pscpp` and `psgo`
52+#### Getting Started
53+This assumes you are running macOS (OS X) or a Unix-like system (Linux, *BSD, etc.).
23
54
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/))
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.
25
56
26−#### Requirements for using PureScript + purescript-native
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.
27
58
28−* A recent version (0.13+) of [purescript](https://github.com/purescript/purescript/releases).
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.
29
60
30−* For `pscpp`, a C++11-capable toolchain, e.g. recent versions of clang, gcc, Microsoft Visual Studio
61+4. Generate the default GNU `Makefile` in your working directory by running `pscpp --makefile`.
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.
34
62
63+5. Use PureScript's standard [`psc-package`](https://psc-package.readthedocs.io/en/latest/) utility to add and manage package dependencies.
35
64
36−#### For more information and a Getting Started guide, please see
65+6. You should now be ready to build a PureScript program:
37−* [`pscpp`](https://github.com/andyarvanitis/purescript-native/blob/cpp/README-cpp.md)
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.
38−* [`psgo`](https://github.com/andyarvanitis/purescript-native/blob/golang/README-go.md)
39
67
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).
40
69
41---
70---
app/Main.hs+47−162
@@ -10,7 +10,7 @@ import Data.Aeson
10import Data.Aeson.Types
10import Data.Aeson.Types
11import Data.Char
11import Data.Char
12import Data.FileEmbed (embedFile)
12import Data.FileEmbed (embedFile)
13−import Data.List (delete, intercalate, isPrefixOf, nub, partition, (\\))
13+import Data.List (delete, isPrefixOf, partition)
14import Data.Maybe
14import Data.Maybe
15import Data.Monoid ((<>))
15import Data.Monoid ((<>))
16import Data.Version
16import Data.Version
@@ -19,10 +19,8 @@ import Control.Monad.Supply.Class
19import Text.Printf
19import Text.Printf
20
20
21import System.Environment
21import System.Environment
22−import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, getModificationTime)
22+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getModificationTime)
23import System.FilePath ((</>), joinPath, splitDirectories, takeDirectory)
23import System.FilePath ((</>), joinPath, splitDirectories, takeDirectory)
24−import System.FilePath.Find
25−import System.Process
26
24
27import Data.Text (Text)
25import Data.Text (Text)
28import qualified Data.Text as T
26import qualified Data.Text as T
@@ -31,8 +29,6 @@ import qualified Data.Text.Lazy as L
31import qualified Data.Text.Lazy.Encoding as L
29import qualified Data.Text.Lazy.Encoding as L
32import qualified Data.ByteString as B
30import qualified Data.ByteString as B
33
31
34−import Development.GitRev
35−
36import Language.PureScript.AST.Literals
32import Language.PureScript.AST.Literals
37import Language.PureScript.CoreFn
33import Language.PureScript.CoreFn
38import Language.PureScript.CoreFn.FromJSON
34import Language.PureScript.CoreFn.FromJSON
@@ -43,8 +39,6 @@ import CodeGen.IL.Printer
43
39
44import Tests
40import Tests
45
41
46−data Command = Build | Run (Maybe String)
47−
48parseJson :: Text -> Value
42parseJson :: Text -> Value
49parseJson text
43parseJson text
50 | Just fileJson <- decode . L.encodeUtf8 $ L.fromStrict text = fileJson
44 | Just fileJson <- decode . L.encodeUtf8 $ L.fromStrict text = fileJson
@@ -54,102 +48,43 @@ jsonToModule :: Value -> Module Ann
54jsonToModule value =
48jsonToModule value =
55 case parse moduleFromJSON value of
49 case parse moduleFromJSON value of
56 Success (_, r) -> r
50 Success (_, r) -> r
57− _ -> error "Failed parsing corefn. Psgo currently supports purescript <= 0.13.8"
51+ _ -> error "failed"
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')
77
52
78main :: IO ()
53main :: IO ()
79main = do
54main = do
80 args <- getArgs
55 args <- getArgs
81− -- let (opts, files) = partition (isPrefixOf "--") args
56+ if null args
82− let (opts, moduleName, files) = splitArgs args
57+ then return ()
83− opts' = (map . map) toLower opts
84− if "--tests" `elem` opts'
85− then runTests
86 else do
58 else do
87− if "--help" `elem` opts' || "--version" `elem` opts'
59+ let (opts, files) = partition (isPrefixOf "--") args
88− then do
60+ opts' = (map . map) toLower opts
89− when ("--help" `elem` opts') $ do
61+ if "--tests" `elem` opts'
90− putStrLn help
62+ then runTests
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
63 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
64+ when ("--makefile" `elem` opts') $
104− then runBuildTool $ Run moduleName
65+ B.writeFile "Makefile" $(embedFile "support/Makefile")
105− else when ("--no-build" `notElem` opts) $
66+ when ("--help" `elem` opts') $
106− runBuildTool Build
67+ putStrLn help
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
68+ when (not $ null files) $ do
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
69+ let filepath = takeDirectory (head files)
123− joinPath $ (init $ splitDirectories filepath)
70+ baseOutpath = joinPath $ (init $ splitDirectories filepath) ++ [outdir]
124− generateFiles :: [String] -> [FilePath] -> IO ()
71+ writeRuntimeFiles baseOutpath
125− generateFiles opts files = do
126− let baseOutpath = basePath files
127− writeSupportFiles baseOutpath
128− Par.mapM (generateCode opts baseOutpath) files
72+ Par.mapM (generateCode opts' baseOutpath) files
129− return ()
73+ 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 ()
74+ return ()
139
75
140generateCode :: [String] -> FilePath -> FilePath -> IO ()
76generateCode :: [String] -> FilePath -> FilePath -> IO ()
141generateCode opts baseOutpath jsonFile = do
77generateCode opts baseOutpath jsonFile = do
142 jsonModTime <- getModificationTime jsonFile
78 jsonModTime <- getModificationTime jsonFile
143 let filepath = takeDirectory jsonFile
79 let filepath = takeDirectory jsonFile
144 dirparts = splitDirectories $ filepath
80 dirparts = splitDirectories $ filepath
145− mname = last dirparts
81+ mname = (\c -> if c == '.' then '_' else c) <$> last dirparts
146 basedir = joinPath $ init dirparts
82 basedir = joinPath $ init dirparts
147− mname' = T.pack mname
83+ possInterfaceFilename = basedir </> outdir </> mname </> interfaceFileName mname
148− possibleFileName = basedir </> (T.unpack mname') </> implFileName mname'
149− exists <- doesFileExist possibleFileName
84+ exists <- doesFileExist possInterfaceFilename
150 if exists
85 if exists
151 then do
86 then do
152− modTime <- getModificationTime possibleFileName
87+ modTime <- getModificationTime possInterfaceFilename
153 when (modTime < jsonModTime) $
88 when (modTime < jsonModTime) $
154 transpile opts baseOutpath jsonFile
89 transpile opts baseOutpath jsonFile
155 else transpile opts baseOutpath jsonFile
90 else transpile opts baseOutpath jsonFile
@@ -157,94 +92,44 @@ generateCode opts baseOutpath jsonFile = do
157transpile :: [String] -> FilePath -> FilePath -> IO ()
92transpile :: [String] -> FilePath -> FilePath -> IO ()
158transpile opts baseOutpath jsonFile = do
93transpile opts baseOutpath jsonFile = do
159 jsonText <- T.decodeUtf8 <$> B.readFile jsonFile
94 jsonText <- T.decodeUtf8 <$> B.readFile jsonFile
160− project <- projectEnv
161 let module' = jsonToModule $ parseJson jsonText
95 let module' = jsonToModule $ parseJson jsonText
162− ((_, foreigns, asts, implHeader, implFooter), _) <- runSupplyT 5 (moduleToIL module' project)
96+ ((interface, foreigns, asts, implHeader, implFooter), _) <- runSupplyT 5 (moduleToIL module' Nothing)
163− let mn = moduleNameToIL' $ moduleName module'
97+ let mn = moduleNameToIL $ moduleName module'
164 implementation = prettyPrintIL asts
98 implementation = prettyPrintIL asts
165 outpath = joinPath [baseOutpath, T.unpack mn]
99 outpath = joinPath [baseOutpath, T.unpack mn]
100+ interfacePath = outpath </> interfaceFileName (T.unpack mn)
166 implPath = outpath </> implFileName mn
101 implPath = outpath </> implFileName mn
102+ putStrLn interfacePath
167 createDirectoryIfMissing True outpath
103 createDirectoryIfMissing True outpath
104+ B.writeFile interfacePath $ T.encodeUtf8 interface
168 putStrLn implPath
105 putStrLn implPath
169 B.writeFile implPath $ T.encodeUtf8 (implHeader <> implementation <> implFooter)
106 B.writeFile implPath $ T.encodeUtf8 (implHeader <> implementation <> implFooter)
170
107
171−writeSupportFiles :: FilePath -> IO ()
108+writeRuntimeFiles :: FilePath -> IO ()
172−writeSupportFiles baseOutpath = do
109+writeRuntimeFiles baseOutpath = do
173− currentDir <- getCurrentDirectory
110+ createDirectoryIfMissing True $ baseOutpath </> "purescript"
174− let outputdir = T.pack $ baseOutpath \\ currentDir
111+ let runtimeSource = baseOutpath </> "purescript" </> "purescript.go"
175− ffiOutpath = currentDir </> subdir
112+ runtimeExists <- doesFileExist runtimeSource
176− createDirectoryIfMissing True baseOutpath
113+ when (not runtimeExists) $ do
177− createDirectoryIfMissing True ffiOutpath
114+ B.writeFile runtimeSource $(embedFile "runtime/purescript.go")
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")
182− where
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
204
115
205−implFileName :: Text -> FilePath
116+outdir :: FilePath
206−implFileName mn = ((\c -> if c == '.' then '_' else c) <$> T.unpack mn) <> ".go"
117+outdir = "src"
118+
119+interfaceFileName :: String -> FilePath
120+interfaceFileName mn = mn <> ".go"
207
121
208−projectEnv :: IO Text
122+implFileName :: Text -> FilePath
209−projectEnv = do
123+implFileName mn = T.unpack $ mn <> ".go"
210− T.pack . fromMaybe defaultProject <$> lookupEnv goproject
211
124
212help :: String
125help :: String
213help = "Usage: psgo OPTIONS COREFN-FILES\n\
126help = "Usage: psgo OPTIONS COREFN-FILES\n\
214− \ PureScript to native (via go) compiler\n\n\
127+ \ PureScript-to-go compiler\n\n\
215 \Available options:\n\
128 \Available options:\n\
216 \ --help Show this help text\n\n\
129 \ --help Show this help text\n\n\
217− \ --version Show the version number\n\n\
130+ \ --makefile Generate a GNU Makefile which can be used for compiling\n\
218− \ --run Run the generated go code directly, without building an\n\
131+ \ a PureScript program and libraries to a native binary via\n\
219− \ executable\n\
132+ \ purs corefn output and C++\n\n\
220− \ --no-build Generate go source files, but do not build an executable\n\
221 \ --tests Run test cases (under construction)\n\n\
133 \ --tests Run test cases (under construction)\n\n\
222 \See also:\n\
134 \See also:\n\
223 \ purs compile --help\n"
135 \ 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.nixdeleted−23
@@ -1,23 +0,0 @@
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+6−9
@@ -9,8 +9,7 @@ copyright: "2018 Andy Arvanitis"
9extra-source-files:
9extra-source-files:
10- README.md
10- README.md
11- ChangeLog.md
11- ChangeLog.md
12−- stack.yaml
12+- runtime/*.go
13−- support/*
14
13
15# Metadata used when publishing your package
14# Metadata used when publishing your package
16# synopsis: Short description of your package
15# synopsis: Short description of your package
@@ -24,7 +23,7 @@ description: Please see the README on Github at <https://github.com/andy
24dependencies:
23dependencies:
25- base >= 4.7 && < 5
24- base >= 4.7 && < 5
26- bytestring >= 0.10.8.2 && < 0.11
25- bytestring >= 0.10.8.2 && < 0.11
27−- purescript
26+- purescript -any
28- base-compat >=0.6.0
27- base-compat >=0.6.0
29- protolude >=0.1.6
28- protolude >=0.1.6
30- text
29- text
@@ -35,12 +34,10 @@ dependencies:
35- safe >=0.3.9 && <0.4
34- safe >=0.3.9 && <0.4
36- transformers >=0.3.0 && <0.6
35- transformers >=0.3.0 && <0.6
37- mtl >=2.1.0 && <2.3.0
36- mtl >=2.1.0 && <2.3.0
38−- aeson >=1.0 && <1.5
37+- aeson >=1.0 && <1.4
39−- directory
38+- directory -any
40−- process
39+- process -any
41−- file-embed
40+- file-embed -any
42−- filemanip
43−- gitrev
44
41
45library:
42library:
46 source-dirs: src
43 source-dirs: src
psgo.cabaldeleted−145
@@ -1,145 +0,0 @@
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/purescript.gonew file+54
@@ -0,0 +1,54 @@
1+package purescript
2+
3+//go:generate purs --version
4+
5+import "sync"
6+
7+type Any interface{}
8+
9+type Fn = func(Any) Any
10+type EffFn = func() Any
11+
12+type Once = sync.Once
13+
14+type IGNORE_UNUSED_RUNTIME = bool
15+
16+const Undefined = "undefined"
17+
18+func Apply(f Any, args ...Any) Any {
19+ result := f
20+ for _, arg := range args {
21+ fn, _ := result.(Fn)
22+ result = fn(arg)
23+ }
24+ return result
25+}
26+
27+func Run(f Any, args ...Any) Any {
28+ fn, _ := f.(EffFn)
29+ return fn()
30+}
31+
32+func Get(dict Any, key string) Any {
33+ d, _ := dict.(map[string]Any)
34+ return d[key]
35+}
36+
37+func SafeGet(dict map[string]Any, key string) Any {
38+ value, ok := dict[key]
39+ if !ok {
40+ panic("Foreign value '" + key + "' not defined")
41+ }
42+ return value
43+}
44+
45+func Contains(dict Any, key string) bool {
46+ d, _ := dict.(map[string]Any)
47+ _, found := d[key]
48+ return found
49+}
50+
51+func Length(arr Any) Any {
52+ a, _ := arr.([]Any)
53+ return len(a)
54+}
src/CodeGen/IL.hs+67−20
@@ -40,6 +40,7 @@ import CodeGen.IL.Optimizer
40import CodeGen.IL.Printer
40import CodeGen.IL.Printer
41
41
42data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)
42data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)
43+data ImportType = Imported | Ignored
43
44
44-- | Generate code in the simplified intermediate representation for all declarations in a
45-- | Generate code in the simplified intermediate representation for all declarations in a
45-- module.
46-- module.
@@ -48,19 +49,24 @@ moduleToIL
48 -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
49 -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
49 . (Monad m, MonadSupply m)
50 . (Monad m, MonadSupply m)
50 => Module Ann
51 => Module Ann
51− -> Text
52+ -> Maybe AST
52 -> m (Text, [Text], [AST], Text, Text)
53 -> m (Text, [Text], [AST], Text, Text)
53−moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =
54+moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =
54 do
55 do
56+ let usedNames = concatMap getNames decls
57+ let mnLookup = renameImports usedNames imps
58+ imports <- traverse (importToIL Imported mnLookup) . (\\ (mn : C.primModules)) . (\\ [mn]) $ ordNub $ map snd imps
59+ ignoredImports <- traverse (importToIL Ignored mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ (mn : C.primModules)) $ ordNub $ map snd imps
60+ interfaceImport <- importToIL Imported (renameImports [] [(emptyAnn, mn)]) mn
61+ let decls' = renameModules mnLookup decls
55− ilDecls <- mapM (bindToIL ModuleDecl) decls
62+ ilDecls <- mapM (bindToIL ModuleDecl) decls'
56 optimized <- traverse (traverse (optimize modName')) ilDecls
63 optimized <- traverse (traverse (optimize modName')) ilDecls
57 let optimized' = concat optimized
64 let optimized' = concat optimized
58 values = annotValue <$> optimized'
65 values = annotValue <$> optimized'
59 foreigns' = moduleIdentToIL <$> foreigns
66 foreigns' = moduleIdentToIL <$> foreigns
60 interface = interfaceSource modName values foreigns
67 interface = interfaceSource modName values foreigns
61− imports = nub . concat $ importToIL <$> optimized'
62− implHeader = implHeaderSource modName imports project
68+ implHeader = implHeaderSource modName (imports ++ ignoredImports) interfaceImport
63− implFooter = implFooterSource (runModuleName mn) foreigns
69+ implFooter = implFooterSource modName foreigns
64 return $ (interface, foreigns', optimized', implHeader, implFooter)
70 return $ (interface, foreigns', optimized', implHeader, implFooter)
65 where
71 where
66 modName = moduleNameToIL mn
72 modName = moduleNameToIL mn
@@ -77,16 +83,55 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =
77 getNames (NonRec _ ident _) = [ident]
83 getNames (NonRec _ ident _) = [ident]
78 getNames (Rec vals) = map (snd . fst) vals
84 getNames (Rec vals) = map (snd . fst) vals
79
85
86+ -- | Creates alternative names for each module to ensure they don't collide
87+ -- with declaration names.
88+ renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
89+ renameImports = go M.empty
90+ where
91+ go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
92+ go acc used ((ann, mn') : mns') =
93+ let mni = Ident $ runModuleName mn'
94+ in if mn' /= mn && mni `elem` used
95+ then let newName = freshModuleName 1 mn' used
96+ in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'
97+ else go (M.insert mn' (ann, mn') acc) used mns'
98+ go acc _ [] = acc
99+
100+ freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
101+ freshModuleName i mn'@(ModuleName pns) used =
102+ let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) <> "_" <> T.pack (show i)]
103+ in if Ident (runModuleName newName) `elem` used
104+ then freshModuleName (i + 1) mn' used
105+ else newName
106+
80− -- | Generates IL code for a module import
107+ -- | Generates IL code for a module import, binding the required module
81− --
108+ -- to the alternative
82− importToIL :: AST -> [Text]
109+ importToIL :: ImportType -> M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m Text
83− importToIL = AST.everything (++) modRef
110+ importToIL t mnLookup mn' = do
111+ let ((_, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
112+ mname = moduleNameToIL mnSafe
113+ pure $ case t of
114+ Imported -> "import \"" <> mname <> "\"\n"
115+ Ignored -> "type _ = " <> mname <> ".IGNORE_UNUSED_IMPORTS\n"
116+
117+ -- | Replaces the `ModuleName`s in the AST so that the generated code refers to
118+ -- the collision-avoiding renamed module imports.
119+ renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]
120+ renameModules mnLookup binds =
121+ let (f, _, _) = everywhereOnValues id ilExpr goBinder
122+ in map f binds
84 where
123 where
85− modRef (AST.Indexer _ (AST.Var _ _) (AST.Var _ mname))
124+ ilExpr :: Expr a -> Expr a
86− | not $ T.null mname = [extract mname]
125+ ilExpr (Var ann q) = Var ann (renameQual q)
87− modRef _ = []
126+ ilExpr e = e
88− extract :: Text -> Text
127+ goBinder :: Binder a -> Binder a
89− extract = T.replace "_" "." . T.dropWhileEnd (=='_')
128+ goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs
129+ goBinder b = b
130+ renameQual :: Qualified a -> Qualified a
131+ renameQual (Qualified (Just mn') a) =
132+ let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
133+ in Qualified (Just mnSafe) a
134+ renameQual q = q
90
135
91 -- |
136 -- |
92 -- Generate code in the simplified intermediate representation for a declaration
137 -- Generate code in the simplified intermediate representation for a declaration
@@ -137,7 +182,7 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =
137 updates <- mapM (sndM valueToIL) ps
182 updates <- mapM (sndM valueToIL) ps
138 obj' <- freshName'
183 obj' <- freshName'
139 let objVar = AST.Var Nothing obj'
184 let objVar = AST.Var Nothing obj'
140− copy = AST.VariableIntroduction Nothing obj' (Just $ copyDict obj)
185+ copy = AST.VariableIntroduction Nothing obj' (Just $ AST.App Nothing (AST.Var Nothing (unbox dictType)) [obj])
141 assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
186 assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
142 sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
187 sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
143 return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
188 return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
@@ -201,7 +246,7 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =
201 -- | Generate code in the simplified intermediate representation for a reference to a
246 -- | Generate code in the simplified intermediate representation for a reference to a
202 -- variable that may have a qualified name.
247 -- variable that may have a qualified name.
203 qualifiedToIL :: (a -> Ident) -> Qualified a -> AST
248 qualifiedToIL :: (a -> Ident) -> Qualified a -> AST
204− qualifiedToIL f (Qualified (Just (ModuleName mn')) a) | mn' == C.prim = AST.Var Nothing . moduleIdentToIL $ f a
249+ qualifiedToIL f (Qualified (Just (ModuleName [ProperName 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'))
250 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 "")
251 qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing "")
207
252
@@ -228,7 +273,7 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =
228 go _ _ _ = internalError "Invalid arguments to bindersToIL"
273 go _ _ _ = internalError "Invalid arguments to bindersToIL"
229
274
230 failedPatternMessage :: Text
275 failedPatternMessage :: Text
231− failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss
276+ failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss <> ": "
232
277
233 guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
278 guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
234 guardsToIL (Left gs) = traverse genGuard gs where
279 guardsToIL (Left gs) = traverse genGuard gs where
@@ -317,5 +362,7 @@ arrayLength :: AST -> AST
317arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
362arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
318-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")
363-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")
319
364
320−copyDict :: AST -> AST
365+freshName' :: MonadSupply m => m Text
321−copyDict a = AST.App Nothing (AST.Var Nothing copyDictFn) [a]
366+freshName' = do
367+ name <- freshName
368+ return $ T.replace "$" "ᵗ" name
src/CodeGen/IL/Common.hs+29−46
@@ -3,9 +3,7 @@ module CodeGen.IL.Common where
3
3
4import Prelude.Compat
4import Prelude.Compat
5
5
6−import Control.Monad.Supply.Class (MonadSupply, freshName)
7import Data.Char
6import Data.Char
8−import Data.Maybe (maybe)
9import Data.Monoid ((<>))
7import Data.Monoid ((<>))
10import Data.Text (Text)
8import Data.Text (Text)
11import qualified Data.Text as T
9import qualified Data.Text as T
@@ -16,12 +14,13 @@ import Language.PureScript.Names
16import qualified Language.PureScript.Constants as C
14import qualified Language.PureScript.Constants as C
17
15
18moduleNameToIL :: ModuleName -> Text
16moduleNameToIL :: ModuleName -> Text
19−moduleNameToIL (ModuleName mn) =
17+moduleNameToIL (ModuleName pns) =
20− let name = T.replace "." "_" mn
18+ let name = T.intercalate "_" (runProperName `map` pns)
21− in if nameIsILBuiltIn name then (name <> moduleRenamerMarker) else name
19+ in moduleNameToIL' name
22
20
23−moduleNameToIL' :: ModuleName -> Text
21+moduleNameToIL' :: Text -> Text
24−moduleNameToIL' (ModuleName mn) = T.replace "_" "." mn
22+moduleNameToIL' name =
23+ if moduleIsReserved name then (name <> "_") else name
25
24
26-- | Convert an 'Ident' into a valid IL identifier:
25-- | Convert an 'Ident' into a valid IL identifier:
27--
26--
@@ -32,7 +31,7 @@ moduleNameToIL' (ModuleName mn) = T.replace "_" "." mn
32identToIL :: Ident -> Text
31identToIL :: Ident -> Text
33identToIL UnusedIdent = unusedName
32identToIL UnusedIdent = unusedName
34identToIL (Ident "$__unused") = unusedName
33identToIL (Ident "$__unused") = unusedName
35−identToIL (Ident name) | name == C.undefined = undefinedName -- Note: done in Printer.hs too
34+identToIL (Ident name) | name == C.undefined = undefinedName
36identToIL (Ident name) = properToIL name
35identToIL (Ident name) = properToIL name
37identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
36identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
38
37
@@ -50,17 +49,16 @@ unusedName = "_"
50
49
51properToIL :: Text -> Text
50properToIL :: Text -> Text
52properToIL name
51properToIL name
53− | nameIsILReserved name = "ˉ" <> name
52+ | nameIsILReserved name || nameIsILBuiltIn name || prefixIsReserved name = name <> "ˉ"
54 | otherwise = T.concatMap identCharToText name
53 | otherwise = T.concatMap identCharToText name
55
54
56-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the
55-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the
57-- ordinal value.
56-- ordinal value.
58identCharToText :: Char -> Text
57identCharToText :: Char -> Text
59−identCharToText 'ṩ' = "_ṩ"
60identCharToText c | isAlphaNum c = T.singleton c
58identCharToText c | isAlphaNum c = T.singleton c
61identCharToText '_' = "_"
59identCharToText '_' = "_"
62−identCharToText '\'' = "ꞌ" -- lowercase saltillo
60+identCharToText '\'' = "ʹ"
63−identCharToText c = error (show (ord c)) -- TODO: should never occur now(?)
61+identCharToText c = "ᵤ" <> T.pack (show (ord c))
64
62
65moduleProperToIL :: Text -> Text
63moduleProperToIL :: Text -> Text
66moduleProperToIL = T.concatMap identCharToText
64moduleProperToIL = T.concatMap identCharToText
@@ -74,21 +72,7 @@ nameIsILReserved name =
74nameIsILBuiltIn :: Text -> Bool
72nameIsILBuiltIn :: Text -> Bool
75nameIsILBuiltIn name =
73nameIsILBuiltIn name =
76 name `elem`
74 name `elem`
77− [ "Any"
75+ [
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 ]
76 ]
93
77
94ilAnyReserved :: [Text]
78ilAnyReserved :: [Text]
@@ -127,6 +111,16 @@ ilKeywords =
127 , "var"
111 , "var"
128 ]
112 ]
129
113
114+moduleIsReserved :: Text -> Bool
115+moduleIsReserved "Main" = False
116+moduleIsReserved name = not $ T.isInfixOf "_" name
117+
118+prefixIsReserved :: Text -> Bool
119+prefixIsReserved name =
120+ any (`T.isPrefixOf` name)
121+ [
122+ ]
123+
130ilLiterals :: [Text]
124ilLiterals :: [Text]
131ilLiterals =
125ilLiterals =
132 [ "init"
126 [ "init"
@@ -152,19 +146,16 @@ ilLiterals =
152 ]
146 ]
153
147
154withPrefix :: Text -> Text
148withPrefix :: Text -> Text
155−withPrefix s = "Ꞌ" <> s -- uppercase saltillo
149+withPrefix s = "PS__" <> s
156
150
157anyType :: Text
151anyType :: Text
158anyType = "Any"
152anyType = "Any"
159
153
160dictType :: Text
154dictType :: Text
161−dictType = "Dict"
155+dictType = "map[string]Any"
162
156
163arrayType :: Text
157arrayType :: Text
164−arrayType = "[]" <> anyType
158+arrayType = "[]Any"
165−
166−uncurriedFnType :: Int -> Text
167−uncurriedFnType i = "Fn" <> (T.pack . show $ i)
168
159
169int :: Text
160int :: Text
170int = "int"
161int = "int"
@@ -178,19 +169,11 @@ bool = "bool"
178string :: Text
169string :: Text
179string = "string"
170string = "string"
180
171
172+unbox :: Text -> Text
173+unbox t = ".(" <> t <> ")"
174+
181arrayLengthFn :: Text
175arrayLengthFn :: Text
182arrayLengthFn = "Length"
176arrayLengthFn = "Length"
183
177
184−indexFn :: Text
178+tcoLoop :: Text
185−indexFn = "Index"
179+tcoLoop = "ᵗᶜloop"
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.hs+94−35
@@ -8,30 +8,31 @@ import Data.Text (Text)
8import Language.PureScript.CoreImp.AST
8import Language.PureScript.CoreImp.AST
9import Language.PureScript.CoreImp.Optimizer.Blocks
9import Language.PureScript.CoreImp.Optimizer.Blocks
10import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
10import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
11−import Language.PureScript.CoreImp.Optimizer.Inliner (etaConvert, evaluateIifes, inlineVariables, unThunk)
11+import Language.PureScript.CoreImp.Optimizer.Inliner hiding (inlineUnsafeCoerce, inlineUnsafePartial)
12import Language.PureScript.CoreImp.Optimizer.Unused
12import Language.PureScript.CoreImp.Optimizer.Unused
13+import Language.PureScript.PSString (PSString, decodeString)
13
14
14−import CodeGen.IL.Common (unusedName)
15+import CodeGen.IL.Common (moduleNameToIL', undefinedName, unusedName)
15−import CodeGen.IL.Optimizer.Inliner
16−import CodeGen.IL.Optimizer.MagicDo
17import CodeGen.IL.Optimizer.TCO
16import CodeGen.IL.Optimizer.TCO
18
17
19import qualified Language.PureScript.Constants as C
18import qualified Language.PureScript.Constants as C
20
19
20+
21−-- | Apply a series of optimizer passes to simplified IL code
21+-- | Apply a series of optimizer passes to simplified C++ code
22optimize :: MonadSupply m => AST -> AST -> m AST
22optimize :: MonadSupply m => AST -> AST -> m AST
23+-- optimize = untilFixedPoint $ return . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . tco
23optimize mn il = do
24optimize mn il = do
24− il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il
25+ il' <- untilFixedPoint (return . inlineApply . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il
25− il'' <- untilFixedPoint (return . ignoreUnusedResults . inlineCommonValues . inlineCommonOperators . tidyUp) . tco mn . inlineST
26+ untilFixedPoint (return . tidyUp) . tco mn
26− =<< untilFixedPoint (return . magicDoST)
27+ =<< untilFixedPoint (return . magicDo')
27− =<< untilFixedPoint (return . magicDoEff)
28− =<< untilFixedPoint (return . magicDoEffect) il'
28+ =<< untilFixedPoint (return . magicDo) il'
29− untilFixedPoint (return . collapseVarDeclarations) il''
29+
30+
30 where
31 where
31 tidyUp :: AST -> AST
32 tidyUp :: AST -> AST
32 tidyUp = applyAll
33 tidyUp = applyAll
33 [ collapseNestedBlocks
34 [ collapseNestedBlocks
34− , collapseNestedIfs
35+ -- , collapseNestedIfs
35 , collapseIfChecks
36 , collapseIfChecks
36 , removeCodeAfterReturnStatements
37 , removeCodeAfterReturnStatements
37 , unThunk
38 , unThunk
@@ -47,6 +48,34 @@ untilFixedPoint f = go
47 a' <- f a
48 a' <- f a
48 if a' == a then return a' else go a'
49 if a' == a then return a' else go a'
49
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 undefinedName ]
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+
50collapseIfChecks :: AST -> AST
79collapseIfChecks :: AST -> AST
51collapseIfChecks = everywhere collapse where
80collapseIfChecks = everywhere collapse where
52 collapse :: AST -> AST
81 collapse :: AST -> AST
@@ -55,27 +84,57 @@ collapseIfChecks = everywhere collapse where
55 | prop == "otherwise" && val == "Data_Boolean" = exprs
84 | prop == "otherwise" && val == "Data_Boolean" = exprs
56 collapse exprs = exprs
85 collapse exprs = exprs
57
86
58−collapseVarDeclarations :: AST -> AST
87+magicDo :: AST -> AST
59−collapseVarDeclarations = everywhere collapse where
88+magicDo = magicDo'' C.eff C.effDictionaries
89+
60− collapse :: AST -> AST
90+magicDo' :: AST -> AST
61− collapse (Block ss sts) = Block ss (go Nothing sts)
91+magicDo' = magicDo'' C.effect C.effectDictionaries
62− collapse s = s
92+
63−
93+magicDo'' :: Text -> C.EffectDictionaries -> AST -> AST
64− go :: Maybe Text -> [AST] -> [AST]
94+magicDo'' effectModule C.EffectDictionaries{..} = everywhereTopDown convert
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
95 where
96+ -- Desugar monomorphic calls to >>= and return for the Eff monad
74− go :: [AST] -> [AST]
97+ convert :: AST -> AST
75− go [] = []
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 il)]) | isDiscard bind && unused == unusedName =
102+ Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns il )
103+ -- Desugar bind
104+ convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 il)]) | isBind bind =
76− go (VariableIntroduction ss var (Just s) : sts)
105+ Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns il)
77− | not $ any (everything (||) (isUsed var)) sts = sts'
106+ -- Inline double applications
78− where
107+ convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
79− sts' | App{} <- s = s : (go sts)
108+ App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
80− | otherwise = go sts
109+ convert other = other
81− go (s:sts) = s : go sts
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 ils) = Block ss (map applyReturns ils)
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 == moduleNameToIL' moduleName
140+ isDict _ _ = False
src/CodeGen/IL/Optimizer/Common.hsdeleted−18
@@ -1,18 +0,0 @@
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.hsdeleted−435
@@ -1,435 +0,0 @@
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.hsdeleted−146
@@ -1,146 +0,0 @@
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/IL/Optimizer/TCO.hs+17−15
@@ -1,4 +1,4 @@
1−module CodeGen.IL.Optimizer.TCO (tco, tcoLoop) where
1+module CodeGen.IL.Optimizer.TCO (tco) where
2
2
3import Prelude.Compat
3import Prelude.Compat
4
4
@@ -11,22 +11,19 @@ import CodeGen.IL.Common
11
11
12import qualified Language.PureScript.Constants as C
12import qualified Language.PureScript.Constants as C
13
13
14−tcoLoop :: Text
15−tcoLoop = "ṩtco_loop"
16−
17tco :: AST -> AST -> AST
14tco :: AST -> AST -> AST
18tco mn = everywhere convert where
15tco mn = everywhere convert where
19 tcoVar :: Text -> Text
16 tcoVar :: Text -> Text
20− tcoVar arg = "ṩtco_var_" <> arg
17+ tcoVar arg = "ᵗ" <> arg
21
18
22 copyVar :: Text -> Text
19 copyVar :: Text -> Text
23− copyVar arg = "ṩcopy_" <> arg
20+ copyVar arg = "ᶜ" <> arg
24
21
25 tcoDone :: Text
22 tcoDone :: Text
26− tcoDone = "ṩtco_done"
23+ tcoDone = "ᵗᶜdone"
27
24
28 tcoResult :: Text
25 tcoResult :: Text
29− tcoResult = "ṩtco_result"
26+ tcoResult = "ᵗᶜresult"
30
27
31 convert :: AST -> AST
28 convert :: AST -> AST
32 convert fn@(Function ss (Just name) args _)
29 convert fn@(Function ss (Just name) args _)
@@ -40,6 +37,7 @@ tco mn = everywhere convert where
40 | isTailRecursive name body'
37 | isTailRecursive name body'
41 = Assignment ss (Var ss name) (replace (toLoop name outerArgs innerArgs body'))
38 = Assignment ss (Var ss name) (replace (toLoop name outerArgs innerArgs body'))
42 where
39 where
40+ -- fn = Function ss' Nothing args (Block ss' stmts)
43 innerArgs = headDef [] argss
41 innerArgs = headDef [] argss
44 outerArgs = concat . reverse $ tailSafe argss
42 outerArgs = concat . reverse $ tailSafe argss
45 (argss, body', replace) = collectAllFunctionArgs [] id fn
43 (argss, body', replace) = collectAllFunctionArgs [] id fn
@@ -92,14 +90,18 @@ tco mn = everywhere convert where
92 toLoop :: Text -> [Text] -> [Text] -> AST -> AST
90 toLoop :: Text -> [Text] -> [Text] -> AST -> AST
93 toLoop ident outerArgs innerArgs js =
91 toLoop ident outerArgs innerArgs js =
94 Block rootSS $
92 Block rootSS $
95− concatMap (\arg -> [ VariableIntroduction rootSS (tcoVar arg) . Just $
93+ concatMap (\arg -> [ VariableIntroduction rootSS (tcoVar arg) Nothing
96− Var rootSS (copyVar arg) ]) (outerArgs ++ innerArgs) ++
94+ , Assignment rootSS (Var rootSS (tcoVar arg)) (Var rootSS (copyVar arg)) ]) (outerArgs ++ innerArgs) ++
95+ -- [ VariableIntroduction rootSS (blockDecl <> tcoDone) Nothing
96+ [ Var rootSS (tcoDone <> " := false")
97− [ Assignment rootSS (Var rootSS $ "var " <> tcoDone) $ BooleanLiteral Nothing False
97+ -- , Assignment rootSS (Var rootSS tcoDone) (BooleanLiteral rootSS False)
98+ -- , Assignment rootSS (Var rootSS tcoDone) (Var rootSS "NO")
98 , VariableIntroduction rootSS tcoResult Nothing
99 , VariableIntroduction rootSS tcoResult Nothing
99− , Assignment rootSS (Var rootSS $ "var " <> tcoLoop) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))
100+ , Assignment rootSS (Var rootSS ("var " <> tcoLoop)) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))
101+ -- , While rootSS (Binary Nothing EqualTo (Var rootSS tcoDone) (BooleanLiteral Nothing False))
100 , While rootSS (Unary Nothing Not (Var rootSS tcoDone))
102 , While rootSS (Unary Nothing Not (Var rootSS tcoDone))
101 (Block rootSS
103 (Block rootSS
102− [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))])
104+ [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . tcoVar) innerArgs))))])
103 , Return rootSS (Var rootSS tcoResult)
105 , Return rootSS (Var rootSS tcoResult)
104 ]
106 ]
105 where
107 where
@@ -115,7 +117,7 @@ tco mn = everywhere convert where
115 zipWith (\val arg ->
117 zipWith (\val arg ->
116 Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
118 Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
117 ++ zipWith (\val arg ->
119 ++ zipWith (\val arg ->
118− Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
120+ Assignment ss (Var ss (tcoVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
119 ++ [ ReturnNoResult ss ]
121 ++ [ ReturnNoResult ss ]
120 | otherwise = Block ss [ markDone ss, Return ss ret ]
122 | otherwise = Block ss [ markDone ss, Return ss ret ]
121 loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]
123 loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]
@@ -128,6 +130,7 @@ tco mn = everywhere convert where
128
130
129 markDone :: Maybe SourceSpan -> AST
131 markDone :: Maybe SourceSpan -> AST
130 markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True)
132 markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True)
133+ -- markDone ss = Assignment ss (Var ss tcoDone) (Var ss "YES")
131
134
132 collectArgs :: [[AST]] -> AST -> [[AST]]
135 collectArgs :: [[AST]] -> AST -> [[AST]]
133 collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn
136 collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn
@@ -135,7 +138,6 @@ tco mn = everywhere convert where
135
138
136 isSelfCall :: Text -> AST -> Bool
139 isSelfCall :: Text -> AST -> Bool
137 isSelfCall ident (App _ (Var _ ident') _) = ident == ident'
140 isSelfCall ident (App _ (Var _ ident') _) = ident == ident'
138− isSelfCall ident (App _ (Indexer _ (Var _ ident') (Var _ mn')) _) = mn' == "" && ident == ident'
139 isSelfCall ident (App _ (Indexer _ (Var _ ident') mn') _) = mn' == mn && ident == ident'
141 isSelfCall ident (App _ (Indexer _ (Var _ ident') mn') _) = mn' == mn && ident == ident'
140 isSelfCall ident (App _ fn _) = isSelfCall ident fn
142 isSelfCall ident (App _ fn _) = isSelfCall ident fn
141 isSelfCall _ _ = False
143 isSelfCall _ _ = False
src/CodeGen/IL/Printer.hs+143−115
@@ -7,9 +7,6 @@ module CodeGen.IL.Printer
7 , implHeaderSource
7 , implHeaderSource
8 , implFooterSource
8 , implFooterSource
9 , isLiteral
9 , isLiteral
10− , modLabel
11− , modPrefix
12− , ffiLoader
13 ) where
10 ) where
14
11
15import Prelude.Compat
12import Prelude.Compat
@@ -33,9 +30,7 @@ import Language.PureScript.Crash
33import Language.PureScript.Names (Ident, runIdent)
30import Language.PureScript.Names (Ident, runIdent)
34import Language.PureScript.Pretty.Common
31import Language.PureScript.Pretty.Common
35import Language.PureScript.PSString (PSString, decodeString, mkString)
32import Language.PureScript.PSString (PSString, decodeString, mkString)
36−
37import CodeGen.IL.Common
33import CodeGen.IL.Common
38−import CodeGen.IL.Optimizer.TCO (tcoLoop)
39
34
40import qualified Language.PureScript.Constants as C
35import qualified Language.PureScript.Constants as C
41
36
@@ -77,7 +72,6 @@ literals = mkPattern' match'
77 , currentIndent
72 , currentIndent
78 , return $ emit "}"
73 , return $ emit "}"
79 ]
74 ]
80− match (Var _ ident) | ident == C.undefined = return $ emit undefinedName
81 match (Var _ ident) = return $ emit ident
75 match (Var _ ident) = return $ emit ident
82 match (VariableIntroduction _ ident value) = mconcat <$> sequence
76 match (VariableIntroduction _ ident value) = mconcat <$> sequence
83 [ return . emit $ varDecl <> " " <> ident <> " " <> anyType
77 [ return . emit $ varDecl <> " " <> ident <> " " <> anyType
@@ -93,47 +87,41 @@ literals = mkPattern' match'
93 , prettyPrintIL' val
87 , prettyPrintIL' val
94 , return $ emit ")"
88 , return $ emit ")"
95 ]
89 ]
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
90 match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence
104− [ return $ emit fn
91+ [ return $ emit arrayLengthFn
105 , return $ emit "("
92 , return $ emit "("
106 , prettyPrintIL' arg
93 , prettyPrintIL' arg
107 , return $ emit ")"
94 , return $ emit ")"
108 ]
95 ]
109− match (App _ (Var _ fn) args) | fn == indexFn = mconcat <$> sequence
96+ match (App _ (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [x]) [y])
110− [ return $ emit fn
97+ | fnMod == dictMod
111− , return $ emit "("
98+ , dictMod == C.dataEq || dictMod == C.dataSemiring || dictMod == C.dataRing ||
112− , intercalate (emit ", ") <$> forM args prettyPrintIL'
99+ dictMod == C.dataEuclideanRing || dictMod == C.dataHeytingAlgebra || dictMod == C.dataOrd
113− , return $ emit ")"
100+ , Just op <- renderOp fn
114− ]
101+ , Just t <- unboxType dict
115− match (App _ (Var _ fn) args) | fn == tcoLoop = mconcat <$> sequence
102+ = mconcat <$> sequence
116− [ return $ emit fn
103+ [ return $ emit $ unbox' t x
117− , return $ emit "("
104+ , return $ emit op
118− , intercalate (emit ", ") <$> forM args prettyPrintIL'
105+ , return $ emit $ unbox' t y
119− , return $ emit ")"
120− ]
106+ ]
121− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn@Function{}]) args)
107+ match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])
122− | Just ftype <- decodeString fnx
108+ | fnMod == dictMod
109+ , dictMod == C.dataRing
110+ , fn == C.negate
111+ , Just t <- unboxType dict
123− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
112+ = mconcat <$> sequence
124− [ prettyPrintIL' fn
125− , return $ emit "("
113+ [ return $ emit "-("
126− , intercalate (emit ", ") <$> forM args prettyPrintIL'
114+ , return $ emit $ unbox' t n
127 , return $ emit ")"
115 , return $ emit ")"
128 ]
116 ]
129− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn]) args)
117+ match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])
130− | Just ftype <- decodeString fnx
118+ | fnMod == dictMod
119+ , dictMod == C.dataHeytingAlgebra
120+ , fn == properToIL C.not
121+ , Just t <- unboxType dict
131− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
122+ = mconcat <$> sequence
132− [ prettyPrintIL' fn
133− , return $ emit ".("
123+ [ return $ emit "!("
134− , return $ emit ftype
124+ , return $ emit $ unbox' t n
135− , return $ emit ")("
136− , intercalate (emit ", ") <$> forM args prettyPrintIL'
137 , return $ emit ")"
125 , return $ emit ")"
138 ]
126 ]
139 match app@(App{})
127 match app@(App{})
@@ -205,36 +193,15 @@ literals = mkPattern' match'
205 , prettyPrintIL' (Var Nothing $ withPrefix name)
193 , prettyPrintIL' (Var Nothing $ withPrefix name)
206 , return $ emit "()"
194 , return $ emit "()"
207 ]
195 ]
208− match (Indexer _ prop@StringLiteral{} val@ObjectLiteral{}) = mconcat <$> sequence
196+ match (Indexer _ prop val) = mconcat <$> sequence
209− [ prettyPrintIL' val
210− , return $ emit "["
197+ [ return $ emit "Get("
211− , prettyPrintIL' prop
198+ , prettyPrintIL' val
212− , return $ emit "]"
213− ]
214− match (Indexer _ prop@StringLiteral{} val) = mconcat <$> sequence
215− [ prettyPrintIL' val
216− , return $ emit ".("
199+ , return $ emit ", "
217− , return $ emit dictType
218− , return $ emit ")["
219 , prettyPrintIL' prop
200 , prettyPrintIL' prop
220− , return $ emit "]"
201+ , 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 ]
202 ]
236 match (InstanceOf _ val ty) = mconcat <$> sequence
203 match (InstanceOf _ val ty) = mconcat <$> sequence
237− [ return $ emit "Is("
204+ [ return $ emit "Contains("
238 , prettyPrintIL' val
205 , prettyPrintIL' val
239 , return $ emit ", "
206 , return $ emit ", "
240 , prettyPrintIL' ty
207 , prettyPrintIL' ty
@@ -260,20 +227,53 @@ literals = mkPattern' match'
260 , return $ emit " "
227 , return $ emit " "
261 , prettyPrintIL' sts
228 , prettyPrintIL' sts
262 ]
229 ]
263− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
230+ match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses)
231+ | (App _ (App _ (App _ (Indexer _ (Var _ _) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [x]) [y]) <- cond
232+ , fnMod == dictMod
233+ , dictMod == C.dataEq || dictMod == C.dataOrd
234+ , Just _ <- unboxTypeInt dict
235+ = mconcat <$> sequence
264 [ return $ emit "if "
236 [ return $ emit "if "
265 , prettyPrintIL' cond
237 , prettyPrintIL' cond
266 , return $ emit " "
238 , return $ emit " "
267 , prettyPrintIL' thens
239 , prettyPrintIL' thens
268 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
240 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
269 ]
241 ]
242+ match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
243+ [ return $ emit "if "
244+ , return $ emit $ unbox' "bool" cond
245+ , return $ emit " "
246+ , prettyPrintIL' thens
247+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
248+ ]
270− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
249+ match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
271 [ return $ emit "if !("
250 [ return $ emit "if !("
272− , prettyPrintIL' cond
251+ , return $ emit $ unbox' "bool" cond
273 , return $ emit ") "
252 , return $ emit ") "
274 , prettyPrintIL' thens
253 , prettyPrintIL' thens
275 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
254 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
276 ]
255 ]
256+ match (IfElse _ (Binary _ EqualTo x y@(NumericLiteral _ n)) thens elses) = mconcat <$> sequence
257+ [ return $ emit "if "
258+ , return $ emit $ unbox' t x
259+ , return $ emit $ " == "
260+ , prettyPrintIL' y
261+ , return $ emit " "
262+ , prettyPrintIL' thens
263+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
264+ ]
265+ where
266+ t | Left _ <- n = int
267+ | Right _ <- n = float
268+ match (IfElse _ (Binary _ EqualTo a b@StringLiteral{}) thens elses) = mconcat <$> sequence
269+ [ return $ emit "if "
270+ , return $ emit $ unbox' string a
271+ , return $ emit $ " == "
272+ , prettyPrintIL' b
273+ , return $ emit " "
274+ , prettyPrintIL' thens
275+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
276+ ]
277 match (IfElse _ cond thens elses) = mconcat <$> sequence
277 match (IfElse _ cond thens elses) = mconcat <$> sequence
278 [ return $ emit "if "
278 [ return $ emit "if "
279 , prettyPrintIL' cond
279 , prettyPrintIL' cond
@@ -289,6 +289,8 @@ literals = mkPattern' match'
289 -- match (Throw _ _) = return mempty
289 -- match (Throw _ _) = return mempty
290 match (Throw _ value) = mconcat <$> sequence
290 match (Throw _ value) = mconcat <$> sequence
291 [ return $ emit "panic("
291 [ return $ emit "panic("
292+ , return $ emit "\"PatternMatchFailure: \""
293+ , return $ emit " + "
292 , prettyPrintIL' value
294 , prettyPrintIL' value
293 , return $ emit ")"
295 , return $ emit ")"
294 ]
296 ]
@@ -328,7 +330,7 @@ literals = mkPattern' match'
328 Nothing -> ""
330 Nothing -> ""
329
331
330unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
332unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
331−unary' op mkStr = Wrap match (<>)
333+unary' op mkStr = Wrap match (const)
332 where
334 where
333 match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
335 match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
334 match = mkPattern match'
336 match = mkPattern match'
@@ -337,7 +339,7 @@ unary' op mkStr = Wrap match (<>)
337 match' _ = Nothing
339 match' _ = Nothing
338
340
339unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
341unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
340−unary op str = unary' op (const str)
342+unary op str = unary' op (\v -> str <> "(" <> prettyPrintIL1 v <> ")")
341
343
342negateOperator :: (Emit gen) => Operator PrinterState AST gen
344negateOperator :: (Emit gen) => Operator PrinterState AST gen
343negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
345negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
@@ -396,7 +398,7 @@ prettyPrintIL' = A.runKleisli $ runPattern matchValue
396 matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
398 matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
397 operators :: (Emit gen) => OperatorTable PrinterState AST gen
399 operators :: (Emit gen) => OperatorTable PrinterState AST gen
398 operators =
400 operators =
399− OperatorTable [ [ unary New "?" ]
401+ OperatorTable [ [ unary New "box" ]
400 , [ unary Not "!"
402 , [ unary Not "!"
401 , unary BitwiseNot "~"
403 , unary BitwiseNot "~"
402 , unary Positive "+"
404 , unary Positive "+"
@@ -407,7 +409,8 @@ prettyPrintIL' = A.runKleisli $ runPattern matchValue
407 , [ binary Add "+"
409 , [ binary Add "+"
408 , binary Subtract "-" ]
410 , binary Subtract "-" ]
409 , [ binary ShiftLeft "<<"
411 , [ binary ShiftLeft "<<"
410− , binary ShiftRight ">>" ]
412+ , binary ShiftRight ">>"
413+ , binary ZeroFillShiftRight ">>>" ]
411 , [ binary LessThan "<"
414 , [ binary LessThan "<"
412 , binary LessThanOrEqualTo "<="
415 , binary LessThanOrEqualTo "<="
413 , binary GreaterThan ">"
416 , binary GreaterThan ">"
@@ -442,29 +445,69 @@ stringLiteral pss | Just s <- decodeString pss = stringLiteral' s
442 encodeChar c = T.singleton $ c
445 encodeChar c = T.singleton $ c
443stringLiteral _ = "\"\\uFFFD\""
446stringLiteral _ = "\"\\uFFFD\""
444
447
448+unbox' :: Text -> AST -> Text
449+unbox' _ v@(NumericLiteral{}) = prettyPrintIL1 v
450+unbox' _ v@(BooleanLiteral{}) = prettyPrintIL1 v
451+unbox' _ v@(StringLiteral{}) = prettyPrintIL1 v
452+unbox' t v = "(" <> prettyPrintIL1 v <> ")" <> unbox t -- unbox t <> "(" <> prettyPrintIL1 v <> ")"
453+
454+unboxType :: Text -> Maybe Text
455+unboxType t
456+ | t == C.eqInt ||
457+ t == C.semiringInt ||
458+ t == C.ringInt ||
459+ t == C.ordInt
460+ = Just int
461+ | t == C.semiringNumber ||
462+ t == C.ringNumber ||
463+ t == C.euclideanRingNumber
464+ = Just float
465+ | t == C.heytingAlgebraBoolean
466+ = Just bool
467+ | otherwise = Nothing
468+
469+unboxTypeInt :: Text -> Maybe Text
470+unboxTypeInt t
471+ | t == C.eqInt ||
472+ t == C.semiringInt ||
473+ t == C.ringInt ||
474+ t == C.ordInt
475+ = Just int
476+ | otherwise = Nothing
477+
478+renderOp :: Text -> Maybe Text
479+renderOp op
480+ | op == C.eq = Just " == "
481+ | op == C.notEq = Just " != "
482+ | op == C.lessThan = Just " < "
483+ | op == C.lessThanOrEq = Just " <= "
484+ | op == C.greaterThan = Just " > "
485+ | op == C.greaterThanOrEq = Just " >= "
486+ | op == C.add = Just " + "
487+ | op == C.sub = Just " - "
488+ | op == C.mul = Just " * "
489+ | op == C.div = Just " / "
490+ | op == C.conj = Just " && "
491+ | op == C.disj = Just "|| "
492+ | otherwise = Nothing
493+
445interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
494interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
446interfaceSource _ _ _ = ""
495interfaceSource _ _ _ = ""
447
496
448implHeaderSource :: Text -> [Text] -> Text -> Text
497implHeaderSource :: Text -> [Text] -> Text -> Text
449−implHeaderSource mn imports otherPrefix =
498+implHeaderSource mn imports _ =
450 "// Code generated by psgo. DO NOT EDIT.\n\n" <>
499 "// Code generated by psgo. DO NOT EDIT.\n\n" <>
451− "package " <> (if mn == "Main" || mn == "Test_Main" then "main" else mn) <> "\n\n" <>
500+ "package " <> (if mn == "Main" then "main" else mn) <> "\n\n" <>
452− "import . \"" <> runtime <> "\"\n" <>
501+ "import . \"purescript\"\n" <>
453− (if mn == "Main" || mn == "Test_Main"
502+ (if mn == "Main"
454− then "import _ \"" <> otherPrefix <> "/" <> ffiLoader <> "\"\n"
503+ then "import \"purescript_ffi\"\n"
455− else "\n") <>
504+ else "") <>
456− "import (\n" <>
457− (T.concat $ formatImport <$> imports) <> ")\n\n" <>
505+ T.concat imports <> "\n" <>
458− "type _ = Any\n\n"
506+ "type IGNORE_UNUSED_IMPORTS = bool\n" <>
459− where
507+ "type _ = IGNORE_UNUSED_RUNTIME\n" <>
460− formatImport :: Text -> Text
508+ (if mn == "Main"
461− formatImport s =
509+ then "\nconst _ = purescript_ffi.Loader\n\n"
462− "\t\"" <> otherPrefix <> "/" <> modPrefix <> "/" <> moduleRenamer s <> "\"\n"
510+ else "\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
511
469implFooterSource :: Text -> [Ident] -> Text
512implFooterSource :: Text -> [Ident] -> Text
470implFooterSource mn foreigns =
513implFooterSource mn foreigns =
@@ -472,7 +515,7 @@ implFooterSource mn foreigns =
472 (if null foreigns
515 (if null foreigns
473 then ""
516 then ""
474 else ("// Foreign values\n\n" <>
517 else ("// Foreign values\n\n" <>
475− "var " <> foreignDict <> " = "<> foreignMod <> "(\"" <> mn <> "\")\n\n" <>
518+ "var " <> foreignDict <> " = " <> dictType <> "{}\n\n" <>
476 (T.concat $ (\foreign' ->
519 (T.concat $ (\foreign' ->
477 let name = moduleIdentToIL foreign' in
520 let name = moduleIdentToIL foreign' in
478 varDecl <> " " <> initName name <> " Once\n" <>
521 varDecl <> " " <> initName name <> " Once\n" <>
@@ -482,17 +525,17 @@ implFooterSource mn foreigns =
482 "() Any { \n" <>
525 "() Any { \n" <>
483 " " <> initName name <> ".Do(func() {\n" <>
526 " " <> initName name <> ".Do(func() {\n" <>
484 " " <> valueName name <> " = " <>
527 " " <> valueName name <> " = " <>
485− "Get(" <> foreignDict <> ", " <>
528+ "SafeGet(" <> foreignDict <> ", " <>
486− (stringLiteral . mkString $ runIdent foreign') <> ")\n" <>
529+ (stringLiteral $ mkString name) <> ")\n" <>
487 " })\n" <>
530 " })\n" <>
488 " return " <> valueName name <> "\n" <>
531 " return " <> valueName name <> "\n" <>
489 "}\n\n") <$> foreigns))) <>
532 "}\n\n") <$> foreigns))) <>
490− if mn == "Main" || mn == "Test.Main" then mainSource else "\n"
533+ if mn == "Main" then mainSource else "\n"
491 where
534 where
492 mainSource :: Text
535 mainSource :: Text
493 mainSource = "\
536 mainSource = "\
494 \func main() {\n\
537 \func main() {\n\
495− \ Run(Ꞌmain())\n\
538+ \ Run(PS__main())\n\
496 \}\n\n\
539 \}\n\n\
497 \"
540 \"
498
541
@@ -502,26 +545,11 @@ varDecl = "var"
502renderArg :: Text -> Text -> Text
545renderArg :: Text -> Text -> Text
503renderArg decl arg = arg <> " " <> decl
546renderArg decl arg = arg <> " " <> decl
504
547
505−foreignMod :: Text
506−foreignMod = "Foreign"
507−
508foreignDict :: Text
548foreignDict :: Text
509−foreignDict = "foreign"
549+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
550
523initName :: Text -> Text
551initName :: Text -> Text
524−initName s = "ᛌ" <> s <> "_once"
552+initName s = "ₒ" <> s
525
553
526valueName :: Text -> Text
554valueName :: Text -> Text
527−valueName s = "ᛧ" <> s
555+valueName s = "ₐ" <> s
src/Tests.hs+12−11
@@ -31,13 +31,18 @@ runTests = do
31 let srcDir = outputDir </> "src"
31 let srcDir = outputDir </> "src"
32 createDirectory srcDir
32 createDirectory srcDir
33
33
34− callProcess "git" ["clone", "--branch", "v0.13.8", "--depth", "1", "https://github.com/purescript/purescript.git"]
34+ callProcess "git" ["clone", "--branch", "v0.13.0", "--depth", "1", "https://github.com/purescript/purescript.git"]
35 let passingDir = baseDir </> "purescript" </> "tests" </> "purs" </> "passing"
35 let passingDir = baseDir </> "purescript" </> "tests" </> "purs" </> "passing"
36 passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passingDir
36 passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passingDir
37
37
38 setCurrentDirectory outputDir
38 setCurrentDirectory outputDir
39+ callProcess "pscpp" ["--makefile"]
39
40
40 fetchPackages
41 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.13.0/prelude/v4.1.0"]
45+ callProcess "git" ["clone", "--branch", "v4.1.1", "--depth", "1", "https://github.com/purescript/purescript-prelude.git", ".psc-package/psc-0.13.0/prelude/v4.1.0"]
41
46
42 let tests = filter (`notElem` skipped) passingTestCases
47 let tests = filter (`notElem` skipped) passingTestCases
43
48
@@ -60,15 +65,14 @@ runTests = do
60 testCaseDirExists <- doesDirectoryExist testCaseDir
65 testCaseDirExists <- doesDirectoryExist testCaseDir
61 when testCaseDirExists $ callProcess "cp" ["-R", testCaseDir, srcDir]
66 when testCaseDirExists $ callProcess "cp" ["-R", testCaseDir, srcDir]
62
67
63− callProcess "rm" ["-rf", "output"]
68+ callProcess "make" ["clean"]
64− callProcess "rm" ["-rf", "Main"]
69+ callProcess "make" ["debug", "-j8"]
65− callProcess "spago" ["build"]
66 --
70 --
67− -- Run executable file
71+ -- Run C++ files
68 --
72 --
69 outputFile <- openFile (tmp </> logpath </> logfile) AppendMode
73 outputFile <- openFile (tmp </> logpath </> logfile) AppendMode
70 hPutStrLn outputFile ("\n" ++ inputFile ++ ":")
74 hPutStrLn outputFile ("\n" ++ inputFile ++ ":")
71− proc <- runProcess ("./" </> "Main") [] Nothing Nothing Nothing (Just outputFile) Nothing
75+ proc <- runProcess ("output" </> "bin" </> "main") [] Nothing Nothing Nothing (Just outputFile) Nothing
72
76
73 removeFile (srcDir </> inputFile)
77 removeFile (srcDir </> inputFile)
74 when testCaseDirExists $ callProcess "rm" ["-rf", srcDir </> (takeWhile (/='.') inputFile)]
78 when testCaseDirExists $ callProcess "rm" ["-rf", srcDir </> (takeWhile (/='.') inputFile)]
@@ -112,11 +116,8 @@ packages =
112fetchPackages :: IO ()
116fetchPackages :: IO ()
113-------------------------------------------------------------------------------
117-------------------------------------------------------------------------------
114fetchPackages = do
118fetchPackages = do
115− callProcess "spago" ["init"]
119+ callProcess "psc-package" ["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
120+ mapM (callProcess "psc-package" . (\p -> ["install", p])) packages
120 return ()
121 return ()
121
122
122-------------------------------------------------------------------------------
123-------------------------------------------------------------------------------
stack.nix+3−18
@@ -1,23 +1,8 @@
1−#
1+{ pkgs ? import <nixpkgs> {}, ghc ? pkgs.ghc }:
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
2
18pkgs.haskell.lib.buildStackProject {
3pkgs.haskell.lib.buildStackProject {
19 name = "default-stack-shell";
4 name = "default-stack-shell";
20− ghc = pkgs.haskell.compiler.ghc865;
5+ inherit ghc;
21− buildInputs = with pkgs; [git git-lfs gmp ncurses zlib];
6+ buildInputs = with pkgs; [git git-lfs gmp zlib];
22 LANG = "en_US.UTF-8";
7 LANG = "en_US.UTF-8";
23}
8}
stack.yaml+65−16
@@ -1,24 +1,73 @@
1−resolver: lts-13.26
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/
2
6
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.
3packages:
38packages:
4- .
39- .
5−
40+# Dependency packages to be pulled from upstream that are not in the resolver
41+# (e.g., acme-missiles-0.3)
6extra-deps:
42extra-deps:
7−- git: https://github.com/purescript/purescript
43+- git: https://github.com/purescript/purescript
8− commit: 9cad73ed8ea7df3011032ddbd2f3de5a0c08629c
44+ commit: b35412a9ea49a46d315a0214cd2c3908442ab7a7
9−- happy-1.19.9
45+- pipes-http-1.0.5
10−- language-javascript-0.7.0.0
46+
11−- network-3.0.1.1
47+# Override default flag values for local packages and extra-deps
12−- these-1.0.1
48+# flags: {}
13−- semialign-1
49+
50+# Extra package databases containing global packages
51+# extra-package-dbs: []
52+
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
14
70
15nix:
71nix:
16− enable: false
17 shell-file: stack.nix
72 shell-file: stack.nix
18
73
19−flags:
20− aeson-pretty:
21− lib-only: true
22− these:
23− assoc: false
24− quickcheck: false
support/Makefilenew file+129
@@ -0,0 +1,129 @@
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.godeleted−30
@@ -1,30 +0,0 @@
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-loaderdeleted−2
@@ -1,2 +0,0 @@
1−module $PROJECT/purescript-native/ffi-loader
2−
support/go.mod.outputdeleted−2
@@ -1,2 +0,0 @@
1−module $PROJECT/purescript-native/output
2−
support/go.mod.workingdeleted−1
@@ -1 +0,0 @@
1−module $PROJECT/example