golang..0cd4f99 · rowtype-yoga/purescript-native

.gitignore+2−2

since splitsnapshots

unifiedsplit

@@ -12,12 +12,12 @@ cabal.sandbox.config

12.test_modules/

13bower_components/

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)

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

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

11import Data.Char

12import Data.FileEmbed (embedFile)

13−import Data.List (delete, intercalate, isPrefixOf, nub, partition, (\\))

13+import Data.List (delete, isPrefixOf, partition)

14import Data.Maybe

15import Data.Monoid ((<>))

16import Data.Version

@@ -19,10 +19,8 @@ import Control.Monad.Supply.Class

19import Text.Printf

20

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)

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+5−6

@@ -10,6 +10,7 @@ extra-source-files:

10- README.md

11- ChangeLog.md

12- stack.yaml

13+- runtime/*

13- support/*

14- support/*

14

15

15# Metadata used when publishing your package

16# Metadata used when publishing your package

@@ -24,7 +25,7 @@ description: Please see the README on Github at <https://github.com/andy

24dependencies:

25dependencies:

25- base >= 4.7 && < 5

26- base >= 4.7 && < 5

26- bytestring >= 0.10.8.2 && < 0.11

27- bytestring >= 0.10.8.2 && < 0.11

27−- purescript

28+- purescript -any

28- base-compat >=0.6.0

29- base-compat >=0.6.0

29- protolude >=0.1.6

30- protolude >=0.1.6

30- text

31- text

@@ -36,11 +37,9 @@ dependencies:

36- transformers >=0.3.0 && <0.6

37- transformers >=0.3.0 && <0.6

37- mtl >=2.1.0 && <2.3.0

38- mtl >=2.1.0 && <2.3.0

38- aeson >=1.0 && <1.5

39- aeson >=1.0 && <1.5

39−- directory

40+- directory -any

40−- process

41+- process -any

41−- file-embed

42+- file-embed -any

42−- filemanip

43−- gitrev

44

43

45library:

44library:

46 source-dirs: src

45 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+63−21

@@ -40,6 +40,7 @@ import CodeGen.IL.Optimizer

40import CodeGen.IL.Printer

41

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.StringLiteral Nothing (mkString 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

@@ -316,6 +361,3 @@ emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)

316arrayLength :: AST -> AST

361arrayLength :: 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−

320−copyDict :: AST -> AST

321−copyDict a = AST.App Nothing (AST.Var Nothing copyDictFn) [a]

src/CodeGen/IL/Common.hs+27−40

@@ -16,12 +16,13 @@ import Language.PureScript.Names

16import qualified Language.PureScript.Constants as C

17

18moduleNameToIL :: ModuleName -> Text

19−moduleNameToIL (ModuleName mn) =

19+moduleNameToIL (ModuleName pns) =

20− let name = T.replace "." "_" mn

20+ let name = T.intercalate "_" (runProperName `map` pns)

21− in if nameIsILBuiltIn name then (name <> moduleRenamerMarker) else name

21+ in moduleNameToIL' name

22

23−moduleNameToIL' :: ModuleName -> Text

23+moduleNameToIL' :: Text -> Text

24−moduleNameToIL' (ModuleName mn) = T.replace "_" "." mn

24+moduleNameToIL' name =

25+ if moduleIsReserved name then (name <> "_") else name

25

26

26-- | Convert an 'Ident' into a valid IL identifier:

27-- | Convert an 'Ident' into a valid IL identifier:

27--

28--

@@ -32,7 +33,7 @@ moduleNameToIL' (ModuleName mn) = T.replace "_" "." mn

32identToIL :: Ident -> Text

33identToIL :: Ident -> Text

33identToIL UnusedIdent = unusedName

34identToIL UnusedIdent = unusedName

34identToIL (Ident "$__unused") = unusedName

35identToIL (Ident "$__unused") = unusedName

35−identToIL (Ident name) | name == C.undefined = undefinedName -- Note: done in Printer.hs too

36+identToIL (Ident name) | name == C.undefined = undefinedName

36identToIL (Ident name) = properToIL name

37identToIL (Ident name) = properToIL name

37identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"

38identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"

38

39

@@ -50,17 +51,16 @@ unusedName = "_"

50

51

51properToIL :: Text -> Text

52properToIL :: Text -> Text

52properToIL name

53properToIL name

53− | nameIsILReserved name = "ˉ" <> name

54+ | nameIsILReserved name || nameIsILBuiltIn name || prefixIsReserved name = name <> "ˉ"

54 | otherwise = T.concatMap identCharToText name

55 | otherwise = T.concatMap identCharToText name

55

56

56-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the

57-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the

57-- ordinal value.

58-- ordinal value.

58identCharToText :: Char -> Text

59identCharToText :: Char -> Text

59−identCharToText 'ṩ' = "_ṩ"

60identCharToText c | isAlphaNum c = T.singleton c

61identCharToText '_' = "_"

62−identCharToText '\'' = "ꞌ" -- lowercase saltillo

62+identCharToText '\'' = "ʹ"

63−identCharToText c = error (show (ord c)) -- TODO: should never occur now(?)

63+identCharToText c = "ᵤ" <> T.pack (show (ord c))

64

65moduleProperToIL :: Text -> Text

66moduleProperToIL = T.concatMap identCharToText

@@ -74,21 +74,7 @@ nameIsILReserved name =

74nameIsILBuiltIn :: Text -> Bool

75nameIsILBuiltIn name =

76 name `elem`

77− [ "Any"

77+ [

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 ]

78 ]

93

79

94ilAnyReserved :: [Text]

80ilAnyReserved :: [Text]

@@ -127,6 +113,16 @@ ilKeywords =

127 , "var"

113 , "var"

128 ]

114 ]

129

115

116+moduleIsReserved :: Text -> Bool

117+moduleIsReserved "Main" = False

118+moduleIsReserved name = not $ T.isInfixOf "_" name

119+

120+prefixIsReserved :: Text -> Bool

121+prefixIsReserved name =

122+ any (`T.isPrefixOf` name)

123+ [

124+ ]

125+

130ilLiterals :: [Text]

126ilLiterals :: [Text]

131ilLiterals =

127ilLiterals =

132 [ "init"

128 [ "init"

@@ -152,19 +148,16 @@ ilLiterals =

152 ]

148 ]

153

149

154withPrefix :: Text -> Text

150withPrefix :: Text -> Text

155−withPrefix s = "Ꞌ" <> s -- uppercase saltillo

151+withPrefix s = "PS__" <> s

156

152

157anyType :: Text

153anyType :: Text

158anyType = "Any"

154anyType = "Any"

159

155

160dictType :: Text

156dictType :: Text

161−dictType = "Dict"

157+dictType = "map[string]Any"

162

158

163arrayType :: Text

159arrayType :: Text

164−arrayType = "[]" <> anyType

160+arrayType = "[]Any"

165−

166−uncurriedFnType :: Int -> Text

167−uncurriedFnType i = "Fn" <> (T.pack . show $ i)

168

161

169int :: Text

162int :: Text

170int = "int"

163int = "int"

@@ -181,16 +174,10 @@ string = "string"

181arrayLengthFn :: Text

174arrayLengthFn :: Text

182arrayLengthFn = "Length"

175arrayLengthFn = "Length"

183

176

184−indexFn :: Text

177+tcoLoop :: Text

185−indexFn = "Index"

178+tcoLoop = "ᵗᶜloop"

186−

187−copyDictFn :: Text

188−copyDictFn = "CopyDict"

189

179

190freshName' :: MonadSupply m => m Text

180freshName' :: MonadSupply m => m Text

191freshName' = do

181freshName' = do

192 name <- freshName

182 name <- freshName

193− return $ T.replace "$" "ṩ" name

183+ return $ T.replace "$" "ᵗ" name

194−

195−moduleRenamerMarker :: Text

196−moduleRenamerMarker = "__"

src/CodeGen/IL/Optimizer.hs+23−22

@@ -8,10 +8,10 @@ import Data.Text (Text)

8import Language.PureScript.CoreImp.AST

9import Language.PureScript.CoreImp.Optimizer.Blocks

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 (inlineCommonOperators, inlineCommonValues, inlineUnsafeCoerce, inlineUnsafePartial)

12import Language.PureScript.CoreImp.Optimizer.Unused

13

14−import CodeGen.IL.Common (unusedName)

14+import CodeGen.IL.Common (moduleNameToIL', undefinedName, unusedName)

15import CodeGen.IL.Optimizer.Inliner

16import CodeGen.IL.Optimizer.MagicDo

17import CodeGen.IL.Optimizer.TCO

@@ -21,19 +21,23 @@ import qualified Language.PureScript.Constants as C

21-- | Apply a series of optimizer passes to simplified IL code

22optimize :: MonadSupply m => AST -> AST -> m AST

23optimize mn il = do

24− il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il

24+ il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . applyAll

25− il'' <- untilFixedPoint (return . ignoreUnusedResults . inlineCommonValues . inlineCommonOperators . tidyUp) . tco mn . inlineST

25+ [ inlineCommonValues

26+ , inlineCommonOperators

27+ ]) il

28+ untilFixedPoint (return . tidyUp) . tco mn . inlineST

26 =<< untilFixedPoint (return . magicDoST)

29 =<< untilFixedPoint (return . magicDoST)

27 =<< untilFixedPoint (return . magicDoEff)

30 =<< untilFixedPoint (return . magicDoEff)

28 =<< untilFixedPoint (return . magicDoEffect) il'

31 =<< untilFixedPoint (return . magicDoEffect) il'

29− untilFixedPoint (return . collapseVarDeclarations) il''

30 where

32 where

31 tidyUp :: AST -> AST

33 tidyUp :: AST -> AST

32 tidyUp = applyAll

34 tidyUp = applyAll

33 [ collapseNestedBlocks

35 [ collapseNestedBlocks

34 , collapseNestedIfs

36 , collapseNestedIfs

35 , collapseIfChecks

37 , collapseIfChecks

38+ , ignoreUnusedResults

36 , removeCodeAfterReturnStatements

39 , removeCodeAfterReturnStatements

40+ -- , removeUndefinedApp

37 , unThunk

41 , unThunk

38 , etaConvert

42 , etaConvert

39 , evaluateIifes

43 , evaluateIifes

@@ -47,6 +51,18 @@ untilFixedPoint f = go

47 a' <- f a

51 a' <- f a

48 if a' == a then return a' else go a'

52 if a' == a then return a' else go a'

49

53

54+-- | Overridden from CoreImp

55+

56+-- inlineApply :: AST -> AST

57+-- inlineApply = everywhereTopDown convert where

58+-- convert (App ss (App _ (Indexer _ (Var _ apply) (Var _ dataFunction)) [ f ]) [ arg ])

59+-- | apply == C.apply && dataFunction == C.dataFunction

60+-- = App ss f [ arg ]

61+-- convert (App ss (App _ (Indexer _ (Var _ applyFlipped) (Var _ dataFunction)) [ arg ]) [ f ])

62+-- | applyFlipped == C.applyFlipped && dataFunction == C.dataFunction

63+-- = App ss f [ arg ]

64+-- convert other = other

65+

50collapseIfChecks :: AST -> AST

66collapseIfChecks :: AST -> AST

51collapseIfChecks = everywhere collapse where

67collapseIfChecks = everywhere collapse where

52 collapse :: AST -> AST

68 collapse :: AST -> AST

@@ -55,27 +71,12 @@ collapseIfChecks = everywhere collapse where

55 | prop == "otherwise" && val == "Data_Boolean" = exprs

71 | prop == "otherwise" && val == "Data_Boolean" = exprs

56 collapse exprs = exprs

72 collapse exprs = exprs

57

73

58−collapseVarDeclarations :: AST -> AST

59−collapseVarDeclarations = everywhere collapse where

60− collapse :: AST -> AST

61− collapse (Block ss sts) = Block ss (go Nothing sts)

62− collapse s = s

63−

64− go :: Maybe Text -> [AST] -> [AST]

65− go _ [] = []

66− go Nothing (decl@(VariableIntroduction _ var (Just _)) : sts) = decl : go (Just var) (go Nothing sts)

67− go (Just var') ((VariableIntroduction ss var (Just val)) : sts)

68− | var == var' = (Assignment ss (Var Nothing var) val) : go (Just var') sts

69− go var' (s:sts) = s : go var' sts

70

74

71ignoreUnusedResults :: AST -> AST

75ignoreUnusedResults :: AST -> AST

72ignoreUnusedResults = everywhere $ removeFromBlock go

76ignoreUnusedResults = everywhere $ removeFromBlock go

73 where

77 where

74 go :: [AST] -> [AST]

78 go :: [AST] -> [AST]

75 go [] = []

79 go [] = []

76− go (VariableIntroduction ss var (Just s) : sts)

80+ go (VariableIntroduction ss var s@(Just _) : sts)

77− | not $ any (everything (||) (isUsed var)) sts = sts'

81+ | not $ any (everything (||) (isUsed var)) sts = (VariableIntroduction ss unusedName s) : sts

78− where

79− sts' | App{} <- s = s : (go sts)

80− | otherwise = go sts

81 go (s:sts) = s : go sts

82 go (s:sts) = s : go sts

src/CodeGen/IL/Optimizer/Common.hs+3−1

@@ -8,9 +8,11 @@ import Data.Text (Text)

8import Language.PureScript.CoreImp.AST

9import Language.PureScript.PSString (PSString, decodeString)

10

11+import CodeGen.IL.Common (moduleNameToIL')

12+

11isDict :: (Text, PSString) -> AST -> Bool

13isDict :: (Text, PSString) -> AST -> Bool

12isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =

14isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =

13− Just x == decodeString dictName && y == moduleName

15+ Just x == decodeString dictName && y == moduleNameToIL' moduleName

14isDict _ _ = False

16isDict _ _ = False

15

17

16isDict' :: [(Text, PSString)] -> AST -> Bool

18isDict' :: [(Text, PSString)] -> AST -> Bool

src/CodeGen/IL/Optimizer/Inliner.hs+18−34

@@ -2,7 +2,7 @@

2module CodeGen.IL.Optimizer.Inliner

3 ( inlineCommonValues

4 , inlineCommonOperators

5− , inlineFnComposition

5+ -- , inlineFnComposition

6 , inlineUnsafeCoerce

7 , inlineUnsafePartial

8 ) where

@@ -48,7 +48,7 @@ inlineCommonValues = everywhere convert

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)

51+ | isDict ringInt dict && isDict fnNegate fn = Unary ss Negate x -- (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

@@ -117,11 +117,12 @@ inlineCommonOperators = everywhereTopDown $ applyAll $

117 , binary' C.dataIntBits C.xor BitwiseXor

118 , binary' C.dataIntBits C.shl ShiftLeft

119 , binary' C.dataIntBits C.shr ShiftRight

120+ , binary' C.dataIntBits C.zshr ZeroFillShiftRight

120 , unary' C.dataIntBits C.complement BitwiseNot

121 , unary' C.dataIntBits C.complement BitwiseNot

121

122

122 , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x]

123 , 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 , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x]

124− , inlineUnsafeIndex (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)

125+ , inlineNonClassFunction (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)

125 ] ++

126 ] ++

126 [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++

127 [ 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.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++

@@ -136,10 +137,8 @@ inlineCommonOperators = everywhereTopDown $ applyAll $

136 binary' :: Text -> PSString -> BinaryOperator -> AST -> AST

137 binary' :: Text -> PSString -> BinaryOperator -> AST -> AST

137 binary' moduleName opString op = convert where

138 binary' moduleName opString op = convert where

138 convert :: AST -> AST

139 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 (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op (unbox x opString) (unbox y opString)

140 convert other = other

141 convert other = other

141− mn :: PSString

142− mn = mkString moduleName

143 unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST

142 unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST

144 unary dicts@(_, d) fns op = convert where

143 unary dicts@(_, d) fns op = convert where

145 convert :: AST -> AST

144 convert :: AST -> AST

@@ -178,21 +177,16 @@ inlineCommonOperators = everywhereTopDown $ applyAll $

178 collectArgs _ _ _ = Nothing

177 collectArgs _ _ _ = Nothing

179

178

180 isNFn :: Text -> Text -> Int -> AST -> Bool

179 isNFn :: Text -> Text -> Int -> AST -> Bool

181− isNFn expectMod prefix n (Indexer _ (Var _ name) (Var _ modName)) | modName == expectMod =

180+ isNFn expectMod prefix n (Indexer _ (StringLiteral _ name) (Var _ modName)) | modName == expectMod =

182 name == fromString (T.unpack prefix <> show n)

181 name == fromString (T.unpack prefix <> show n)

183 isNFn _ _ _ _ = False

182 isNFn _ _ _ _ = False

184

183

185 runFn :: Int -> AST -> AST

184 runFn :: Int -> AST -> AST

186− runFn = runFn' C.dataFunctionUncurried C.runFn (\ss f args ->

185+ runFn = runFn' C.dataFunctionUncurried C.runFn App

187− let len = length args

186+

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

187 runEffFn :: Text -> Text -> Int -> AST -> AST

193 runEffFn modName fnName = runFn' modName fnName $ \ss fn acc ->

188 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)])

189+ Function ss Nothing [] (Block ss [Return ss (App ss fn acc)])

196

190

197 runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST

191 runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST

198 runFn' modName runFnName res n = convert where

192 runFn' modName runFnName res n = convert where

@@ -211,23 +205,14 @@ inlineCommonOperators = everywhereTopDown $ applyAll $

211 convert (App _ (App _ op' [x]) [y]) | p op' = f x y

205 convert (App _ (App _ op' [x]) [y]) | p op' = f x y

212 convert other = other

206 convert other = other

213

207

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

208 isModFn :: (Text, PSString) -> AST -> Bool

224− isModFn (m, op) (Indexer _ (Var _ op') (Var _ m')) =

209+ isModFn (m, op) (Indexer _ (StringLiteral _ op') (Var _ m')) =

225− m == m' && decodeString op == Just op'

210+ m == m' && op == op'

226 isModFn _ _ = False

211 isModFn _ _ = False

227

212

228 isModFnWithDict :: (Text, PSString) -> AST -> Bool

213 isModFnWithDict :: (Text, PSString) -> AST -> Bool

229− isModFnWithDict (m, op) (App _ (Indexer _ (Var _ op') (Var _ m')) [Var _ _]) =

214+ isModFnWithDict (m, op) (App _ (Indexer _ (StringLiteral _ op') (Var _ m')) [Var _ _]) =

230− m == m' && decodeString op == Just op'

215+ m == m' && op == op'

231 isModFnWithDict _ _ = False

216 isModFnWithDict _ _ = False

232

217

233-- (f <<< g $ x) = f (g x)

218-- (f <<< g $ x) = f (g x)

@@ -280,12 +265,11 @@ inlineUnsafeCoerce = everywhereTopDown convert where

280

265

281inlineUnsafePartial :: AST -> AST

266inlineUnsafePartial :: AST -> AST

282inlineUnsafePartial = everywhereTopDown convert where

267inlineUnsafePartial = everywhereTopDown convert where

283− convert (App ss fn [ comp ])

268+ convert (App ss (Indexer _ (Var _ unsafePartial) (Var _ partialUnsafe)) [ comp ])

284− | isDict fnUnsafePartial fn

269+ | unsafePartial == C.unsafePartial && partialUnsafe == C.partialUnsafe

285− = App ss comp []

270+ -- Apply to undefined here, the application should be optimized away

286− where

271+ -- if it is safe to do so

287− fnUnsafePartial :: forall a b. (IsString a, IsString b) => (a, b)

272+ = App ss comp [ Var ss undefinedName ]

288− fnUnsafePartial = (C.partialUnsafe, C.unsafePartial)

289 convert other = other

273 convert other = other

290

274

291semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)

275semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)

src/CodeGen/IL/Optimizer/MagicDo.hs+1−1

@@ -13,7 +13,7 @@ import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)

13import Language.PureScript.PSString (PSString, decodeString, mkString)

14import qualified Language.PureScript.Constants as C

15

16−import CodeGen.IL.Common (undefinedName, unusedName)

16+import CodeGen.IL.Common (moduleNameToIL', undefinedName, unusedName)

17import CodeGen.IL.Optimizer.Common

18

19-- | Inline type class dictionaries for >>= and return for the Eff monad

src/CodeGen/IL/Optimizer/TCO.hs+5−9

@@ -1,4 +1,4 @@

1−module CodeGen.IL.Optimizer.TCO (tco, tcoLoop) where

1+module CodeGen.IL.Optimizer.TCO (tco) where

2

3import Prelude.Compat

4

@@ -11,22 +11,19 @@ import CodeGen.IL.Common

11

12import qualified Language.PureScript.Constants as C

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 _)

@@ -135,7 +132,6 @@ tco mn = everywhere convert where

135

132

136 isSelfCall :: Text -> AST -> Bool

133 isSelfCall :: Text -> AST -> Bool

137 isSelfCall ident (App _ (Var _ ident') _) = ident == ident'

134 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'

135 isSelfCall ident (App _ (Indexer _ (Var _ ident') mn') _) = mn' == mn && ident == ident'

140 isSelfCall ident (App _ fn _) = isSelfCall ident fn

136 isSelfCall ident (App _ fn _) = isSelfCall ident fn

141 isSelfCall _ _ = False

137 isSelfCall _ _ = False

src/CodeGen/IL/Printer.hs+31−100

@@ -7,9 +7,6 @@ module CodeGen.IL.Printer

7 , implHeaderSource

8 , implFooterSource

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

@@ -106,36 +100,12 @@ literals = mkPattern' match'

106 , prettyPrintIL' arg

100 , prettyPrintIL' arg

107 , return $ emit ")"

101 , return $ emit ")"

108 ]

102 ]

109− match (App _ (Var _ fn) args) | fn == indexFn = mconcat <$> sequence

110− [ return $ emit fn

111− , return $ emit "("

112− , intercalate (emit ", ") <$> forM args prettyPrintIL'

113− , return $ emit ")"

114− ]

115 match (App _ (Var _ fn) args) | fn == tcoLoop = mconcat <$> sequence

103 match (App _ (Var _ fn) args) | fn == tcoLoop = mconcat <$> sequence

116 [ return $ emit fn

104 [ return $ emit fn

117 , return $ emit "("

105 , return $ emit "("

118 , intercalate (emit ", ") <$> forM args prettyPrintIL'

106 , intercalate (emit ", ") <$> forM args prettyPrintIL'

119 , return $ emit ")"

107 , return $ emit ")"

120 ]

108 ]

121− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn@Function{}]) args)

122− | Just ftype <- decodeString fnx

123− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence

124− [ prettyPrintIL' fn

125− , return $ emit "("

126− , intercalate (emit ", ") <$> forM args prettyPrintIL'

127− , return $ emit ")"

128− ]

129− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn]) args)

130− | Just ftype <- decodeString fnx

131− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence

132− [ prettyPrintIL' fn

133− , return $ emit ".("

134− , return $ emit ftype

135− , return $ emit ")("

136− , intercalate (emit ", ") <$> forM args prettyPrintIL'

137− , return $ emit ")"

138− ]

139 match app@(App{})

109 match app@(App{})

140 | (val, args) <- unApp app []

110 | (val, args) <- unApp app []

141 , length args > 1

111 , length args > 1

@@ -205,36 +175,15 @@ literals = mkPattern' match'

205 , prettyPrintIL' (Var Nothing $ withPrefix name)

175 , prettyPrintIL' (Var Nothing $ withPrefix name)

206 , return $ emit "()"

176 , return $ emit "()"

207 ]

177 ]

208− match (Indexer _ prop@StringLiteral{} val@ObjectLiteral{}) = mconcat <$> sequence

178+ match (Indexer _ prop val) = mconcat <$> sequence

209− [ prettyPrintIL' val

210− , return $ emit "["

179+ [ return $ emit "Get("

211− , prettyPrintIL' prop

180+ , prettyPrintIL' val

212− , return $ emit "]"

213− ]

214− match (Indexer _ prop@StringLiteral{} val) = mconcat <$> sequence

215− [ prettyPrintIL' val

216− , return $ emit ".("

181+ , return $ emit ", "

217− , return $ emit dictType

218− , return $ emit ")["

219 , prettyPrintIL' prop

182 , prettyPrintIL' prop

220− , return $ emit "]"

183+ , 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 ]

184 ]

236 match (InstanceOf _ val ty) = mconcat <$> sequence

185 match (InstanceOf _ val ty) = mconcat <$> sequence

237− [ return $ emit "Is("

186+ [ return $ emit "Contains("

238 , prettyPrintIL' val

187 , prettyPrintIL' val

239 , return $ emit ", "

188 , return $ emit ", "

240 , prettyPrintIL' ty

189 , prettyPrintIL' ty

@@ -289,6 +238,8 @@ literals = mkPattern' match'

289 -- match (Throw _ _) = return mempty

238 -- match (Throw _ _) = return mempty

290 match (Throw _ value) = mconcat <$> sequence

239 match (Throw _ value) = mconcat <$> sequence

291 [ return $ emit "panic("

240 [ return $ emit "panic("

241+ , return $ emit "\"PatternMatchFailure: \""

242+ , return $ emit " + "

292 , prettyPrintIL' value

243 , prettyPrintIL' value

293 , return $ emit ")"

244 , return $ emit ")"

294 ]

245 ]

@@ -396,7 +347,7 @@ prettyPrintIL' = A.runKleisli $ runPattern matchValue

396 matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)

347 matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)

397 operators :: (Emit gen) => OperatorTable PrinterState AST gen

348 operators :: (Emit gen) => OperatorTable PrinterState AST gen

398 operators =

349 operators =

399− OperatorTable [ [ unary New "?" ]

350+ OperatorTable [ [ unary New "box" ]

400 , [ unary Not "!"

351 , [ unary Not "!"

401 , unary BitwiseNot "~"

352 , unary BitwiseNot "~"

402 , unary Positive "+"

353 , unary Positive "+"

@@ -407,7 +358,8 @@ prettyPrintIL' = A.runKleisli $ runPattern matchValue

407 , [ binary Add "+"

358 , [ binary Add "+"

408 , binary Subtract "-" ]

359 , binary Subtract "-" ]

409 , [ binary ShiftLeft "<<"

360 , [ binary ShiftLeft "<<"

410− , binary ShiftRight ">>" ]

361+ , binary ShiftRight ">>"

362+ , binary ZeroFillShiftRight ">>>" ]

411 , [ binary LessThan "<"

363 , [ binary LessThan "<"

412 , binary LessThanOrEqualTo "<="

364 , binary LessThanOrEqualTo "<="

413 , binary GreaterThan ">"

365 , binary GreaterThan ">"

@@ -446,25 +398,19 @@ interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text

446interfaceSource _ _ _ = ""

398interfaceSource _ _ _ = ""

447

399

448implHeaderSource :: Text -> [Text] -> Text -> Text

400implHeaderSource :: Text -> [Text] -> Text -> Text

449−implHeaderSource mn imports otherPrefix =

401+implHeaderSource mn imports _ =

450 "// Code generated by psgo. DO NOT EDIT.\n\n" <>

402 "// Code generated by psgo. DO NOT EDIT.\n\n" <>

451− "package " <> (if mn == "Main" || mn == "Test_Main" then "main" else mn) <> "\n\n" <>

403+ "package " <> (if mn == "Main" then "main" else mn) <> "\n\n" <>

452− "import . \"" <> runtime <> "\"\n" <>

404+ "import . \"purescript\"\n" <>

453− (if mn == "Main" || mn == "Test_Main"

405+ (if mn == "Main"

454− then "import _ \"" <> otherPrefix <> "/" <> ffiLoader <> "\"\n"

406+ then "import \"ffi\"\n"

455− else "\n") <>

407+ else "") <>

456− "import (\n" <>

457− (T.concat $ formatImport <$> imports) <> ")\n\n" <>

408+ T.concat imports <> "\n" <>

458− "type _ = Any\n\n"

409+ "type IGNORE_UNUSED_IMPORTS = bool\n" <>

459− where

410+ "type _ = IGNORE_UNUSED_RUNTIME\n" <>

460− formatImport :: Text -> Text

411+ (if mn == "Main"

461− formatImport s =

412+ then "\nconst _ = ffi.Loader\n\n"

462− "\t\"" <> otherPrefix <> "/" <> modPrefix <> "/" <> moduleRenamer s <> "\"\n"

413+ 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

414

469implFooterSource :: Text -> [Ident] -> Text

415implFooterSource :: Text -> [Ident] -> Text

470implFooterSource mn foreigns =

416implFooterSource mn foreigns =

@@ -472,7 +418,7 @@ implFooterSource mn foreigns =

472 (if null foreigns

418 (if null foreigns

473 then ""

419 then ""

474 else ("// Foreign values\n\n" <>

420 else ("// Foreign values\n\n" <>

475− "var " <> foreignDict <> " = "<> foreignMod <> "(\"" <> mn <> "\")\n\n" <>

421+ "var " <> foreignDict <> " = " <> dictType <> "{}\n\n" <>

476 (T.concat $ (\foreign' ->

422 (T.concat $ (\foreign' ->

477 let name = moduleIdentToIL foreign' in

423 let name = moduleIdentToIL foreign' in

478 varDecl <> " " <> initName name <> " Once\n" <>

424 varDecl <> " " <> initName name <> " Once\n" <>

@@ -482,17 +428,17 @@ implFooterSource mn foreigns =

482 "() Any { \n" <>

428 "() Any { \n" <>

483 " " <> initName name <> ".Do(func() {\n" <>

429 " " <> initName name <> ".Do(func() {\n" <>

484 " " <> valueName name <> " = " <>

430 " " <> valueName name <> " = " <>

485− "Get(" <> foreignDict <> ", " <>

431+ "SafeGet(" <> foreignDict <> ", " <>

486− (stringLiteral . mkString $ runIdent foreign') <> ")\n" <>

432+ (stringLiteral $ mkString name) <> ")\n" <>

487 " })\n" <>

433 " })\n" <>

488 " return " <> valueName name <> "\n" <>

434 " return " <> valueName name <> "\n" <>

489 "}\n\n") <$> foreigns))) <>

435 "}\n\n") <$> foreigns))) <>

490− if mn == "Main" || mn == "Test.Main" then mainSource else "\n"

436+ if mn == "Main" then mainSource else "\n"

491 where

437 where

492 mainSource :: Text

438 mainSource :: Text

493 mainSource = "\

439 mainSource = "\

494 \func main() {\n\

440 \func main() {\n\

495− \ Run(Ꞌmain())\n\

441+ \ Run(PS__main())\n\

496 \}\n\n\

442 \}\n\n\

497 \"

443 \"

498

444

@@ -502,26 +448,11 @@ varDecl = "var"

502renderArg :: Text -> Text -> Text

448renderArg :: Text -> Text -> Text

503renderArg decl arg = arg <> " " <> decl

449renderArg decl arg = arg <> " " <> decl

504

450

505−foreignMod :: Text

506−foreignMod = "Foreign"

507−

508foreignDict :: Text

451foreignDict :: Text

509−foreignDict = "foreign"

452+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

453

523initName :: Text -> Text

454initName :: Text -> Text

524−initName s = "ᛌ" <> s <> "_once"

455+initName s = "ₒ" <> s

525

456

526valueName :: Text -> Text

457valueName :: Text -> Text

527−valueName s = "ᛧ" <> s

458+valueName s = "ₐ" <> s

src/Tests.hs+12−11

@@ -31,13 +31,18 @@ runTests = do

31 let srcDir = outputDir </> "src"

32 createDirectory srcDir

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"

36 passingTestCases <- sort . filter (".purs" `isSuffixOf`) <$> getDirectoryContents passingDir

37

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−15

@@ -1,24 +1,74 @@

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-13.12

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: 738aaa2f21097c7f18aa8100b16ae52316addb04

9−- happy-1.19.9

10−- language-javascript-0.7.0.0

11- network-3.0.1.1

45- network-3.0.1.1

12−- these-1.0.1

46+- pipes-http-1.0.5

13−- semialign-1

47+

48+# Override default flag values for local packages and extra-deps

49+# flags: {}

50+

51+# Extra package databases containing global packages

52+# extra-package-dbs: []

53+

54+# Control whether we use the GHC we find on the path

55+# system-ghc: true

56+#

57+# Require a specific version of stack, using version ranges

58+# require-stack-version: -any # Default

59+# require-stack-version: ">=1.6"

60+#

61+# Override the architecture used by stack, especially useful on Windows

62+# arch: i386

63+# arch: x86_64

64+#

65+# Extra directories used by stack for building

66+# extra-include-dirs: [/path/to/dir]

67+# extra-lib-dirs: [/path/to/dir]

68+#

69+# Allow a newer minor version of GHC than the snapshot specifies

70+# compiler-check: newer-minor

14

71

15nix:

72nix:

16− enable: false

17 shell-file: stack.nix

73 shell-file: stack.nix

18

74

19−flags:

20− aeson-pretty:

21− lib-only: true

22− these:

23− assoc: false

24− quickcheck: false

support/Makefilenew file+124

@@ -0,0 +1,124 @@

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+PSGO := psgo

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+DEBUG := "-DDEBUG -g"

30+RELEASE := "-DNDEBUG -O3"

31+

32+INCLUDES := -I $(CC_SRC)

33+BIN_DIR := $(OUTPUT)/bin

34+

35+PACKAGE_SOURCES = $(subst \,/,$(shell $(PSC_PACKAGE) sources))

36+PURESCRIPT_PKGS := $(firstword $(subst /, ,$(PACKAGE_SOURCES)))

37+

38+## Not all environments support globstar (** dir pattern)

39+rwildcard=$(wildcard $1$2) $(foreach d,$(wildcard $1*),$(call rwildcard,$d/,$2))

40+

41+unspecified:

42+ @echo

43+ @echo "Please specify the type of build you want: 'debug' or 'release'"

44+ @echo

45+ @echo " debug => not optimized (your app will run slower), good for"

46+ @echo " running in a source-level debugger, more (descriptive)"

47+ @echo " runtime exceptions"

48+ @echo

49+ @echo " release => optimized (your app will run faster), less helpful when debugging"

50+ @echo

51+

52+debug: codegen

53+ go build -o $(BIN_DIR)/$(BIN) $(BIN)

54+

55+release: codegen

56+ go build -o $(BIN_DIR)/$(BIN) $(BIN)

57+

58+.PHONY: corefn

59+corefn: PURESCRIPT_PKG_SRCS=$(foreach d,$(PACKAGE_SOURCES),$(call rwildcard,$(firstword $(subst *, ,$(d))),*.purs))

60+corefn: PURESCRIPT_SRCS=$(call rwildcard,$(SRC)/,*.purs)

61+corefn: $(PURESCRIPT_PKGS)

62+ @$(PURS) $(PURSFLAGS) --output $(OUTPUT) $(PURESCRIPT_PKG_SRCS) $(PURESCRIPT_SRCS)

63+

64+.PHONY: codegen

65+codegen: COREFN_SRCS=$(call rwildcard,$(OUTPUT)/,corefn.json)

66+codegen: corefn

67+ @$(PSGO) $(PSGOFLAGS) $(COREFN_SRCS)

68+

69+$(PURESCRIPT_PKGS):

70+ @echo "Getting packages using" $(PSC_PACKAGE) "..."

71+ @$(PSC_PACKAGE) update

72+

73+SRCS := $(call rwildcard,$(CC_SRC)/,*.cpp)

74+SRCS += $(call rwildcard,$(FFI_SRC)/,*.cpp)

75+SRCS += $(call rwildcard,$(FFI_SRC)/,*.cc)

76+SRCS += $(call rwildcard,$(FFI_SRC)/,*.mm)

77+SRCS += $(call rwildcard,$(FFI_SRC)/,*.c)

78+SRCS += $(call rwildcard,$(FFI_SRC)/,*.m)

79+

80+OBJS1 = $(SRCS:.cpp=.o)

81+OBJS2 = $(OBJS1:.cc=.o)

82+OBJS3 = $(OBJS2:.mm=.o)

83+OBJS4 = $(OBJS3:.c=.o)

84+OBJS = $(OBJS4:.m=.o)

85+DEPS = $(OBJS:.o=.d)

86+

87+$(BIN): $(OBJS)

88+ @echo "Linking" $(BIN_DIR)/$(BIN)

89+ @mkdir -p $(BIN_DIR)

90+ @$(CXX) $^ -o $(BIN_DIR)/$@ $(LDFLAGS)

91+

92+-include $(DEPS)

93+

94+%.o: %.cpp

95+ @echo "Creating" $@ "(C++)"

96+ @$(CXX) $(CXXFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@

97+

98+%.o: %.cc

99+ @echo "Creating" $@ "(C++)"

100+ @$(CXX) $(CXXFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@

101+

102+%.o: %.mm

103+ @echo "Creating" $@ "(Objective-C++)"

104+ @$(CXX) $(CXXFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@

105+

106+%.o: %.c

107+ @echo "Creating" $@ "(C)"

108+ @$(CXX) $(CFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@

109+

110+%.o: %.m

111+ @echo "Creating" $@ "(Objective-C)"

112+ @$(CXX) $(CFLAGS) $(INCLUDES) -MMD -MP -c $< -o $@

113+

114+.PHONY: all

115+all: release

116+

117+.PHONY: clean

118+clean:

119+ @-rm -f $(OBJS) $(DEPS)

120+ @-rm -rf $(OUTPUT)

121+

122+.PHONY: run

123+run:

124+ @$(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