golang..fab29cb · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on fab29cb help sign in

.gitignore−2

since splitsnapshots

unifiedsplit

@@ -14,10 +14,8 @@ bower_components/

14node_modules

15tmp/

16.stack-work/

17−stack.yaml.lock

18output

17output

19examples/docs/docs/

18examples/docs/docs/

20core-tests/full-core-docs.md

19core-tests/full-core-docs.md

21.psc-ide-port

20.psc-ide-port

22.vscode/

21.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)

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.

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

7+### **Please note that this project supersedes [pure11](https://github.com/pure11/pure11) (they are no longer the same)**

9+#### Please see [changes](https://github.com/andyarvanitis/purescript-native/wiki/changes) for more details.

10+

11+---

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

15+ * macOS High Sierra, Xcode 9.4.1's clang (full test suite)

10− * For C++, Xcode 10.2.1's `clang` was used

11− * For Go, `go` version 1.12.7 was used

12− * Windows 10 x64 – full test suite

13− * C++: Visual Studio 2017 and `clang`

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::deque`](http://en.cppreference.com/w/cpp/container/deque) (random access *O(1)*)

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

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.

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

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.

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.

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.

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.

63+5. Use PureScript's standard [`psc-package`](https://psc-package.readthedocs.io/en/latest/) utility to add and manage package dependencies.

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`. If your machine has multiple cores, you might want to use `make -jN`, where `N` is the number of cores.

38−* [`psgo`](https://github.com/andyarvanitis/purescript-native/blob/golang/README-go.md)

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

41---

70---

app/Main.hs+77−168

@@ -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,32 +19,26 @@ import Control.Monad.Supply.Class

19import Text.Printf

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

27import Data.Text (Text)

25import Data.Text (Text)

28import qualified Data.Text as T

26import qualified Data.Text as T

29import qualified Data.Text.Encoding as T

27import qualified Data.Text.Encoding as T

28+import qualified Data.Text.IO as T

30import qualified Data.Text.Lazy as L

29import qualified Data.Text.Lazy as L

31import qualified Data.Text.Lazy.Encoding as L

30import qualified Data.Text.Lazy.Encoding as L

32−import qualified Data.ByteString as B

33−

34−import Development.GitRev

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

40−import CodeGen.IL

36+import CodeGen.Cpp

41−import CodeGen.IL.Common

37+import CodeGen.Cpp.Common

42−import CodeGen.IL.Printer

38+import CodeGen.Cpp.Printer

44import Tests

40import Tests

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,197 +48,112 @@ 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')

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+ T.writeFile "Makefile" $ T.decodeUtf8 $(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

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

156

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.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 (moduleToCpp module' Nothing)

163− let mn = moduleNameToIL' $ moduleName module'

97+ let mn = moduleNameToCpp $ moduleName module'

164− implementation = prettyPrintIL asts

98+ implementation = prettyPrintCpp 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+ T.writeFile interfacePath $ conv interface

168 putStrLn implPath

105 putStrLn implPath

169− B.writeFile implPath $ T.encodeUtf8 (implHeader <> implementation <> implFooter)

106+ T.writeFile implPath $ conv (implHeader <> implementation <> implFooter)

107+ where

108+ conv :: Text -> Text

109+ conv

110+ | "--ucns" `elem` opts = toUCNs

111+ | otherwise = id

170

112

171−writeSupportFiles :: FilePath -> IO ()

113+writeRuntimeFiles :: FilePath -> IO ()

172−writeSupportFiles baseOutpath = do

114+writeRuntimeFiles baseOutpath = do

173− currentDir <- getCurrentDirectory

174− let outputdir = T.pack $ baseOutpath \\ currentDir

175− ffiOutpath = currentDir </> subdir

176 createDirectoryIfMissing True baseOutpath

115 createDirectoryIfMissing True baseOutpath

177− createDirectoryIfMissing True ffiOutpath

116+ let runtime = baseOutpath </> "purescript.h"

178− writeModuleFile outputdir currentDir $(embedFile "support/go.mod.working")

117+ dep = baseOutpath </> "string_literal_dict.h"

179− writeModuleFile outputdir baseOutpath $(embedFile "support/go.mod.output")

118+ runtimeExists <- doesFileExist runtime

180− writeModuleFile outputdir ffiOutpath $(embedFile "support/go.mod.ffi-loader")

119+ when (not runtimeExists) $ do

181− writeLoaderFile ffiOutpath $(embedFile "support/ffi-loader.go")

120+ T.writeFile runtime $ T.decodeUtf8 $(embedFile "runtime/purescript.h")

182− where

121+ T.writeFile dep $ T.decodeUtf8 $(embedFile "runtime/string_literal_dict.h")

183− writeModuleFile :: Text -> FilePath -> B.ByteString -> IO ()

122+

184− writeModuleFile outputdir path modText = do

123+outdir :: FilePath

185− let goModSource = path </> "go.mod"

124+outdir = "src"

186− goModSourceExists <- doesFileExist goModSource

125+

187− when (not goModSourceExists) $ do

126+interfaceFileName :: String -> FilePath

188− project <- projectEnv

127+interfaceFileName mn = mn <> ".h"

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

128

205implFileName :: Text -> FilePath

129implFileName :: Text -> FilePath

206−implFileName mn = ((\c -> if c == '.' then '_' else c) <$> T.unpack mn) <> ".go"

130+implFileName mn = T.unpack $ mn <> ".cpp"

131+

132+escape :: Text -> Text

133+escape = T.concatMap go

134+ where

135+ go :: Char -> Text

136+ go c = T.pack $ printf "0x%04x," (ord c)

207

137

208−projectEnv :: IO Text

138+

209−projectEnv = do

139+toUCNs :: Text -> Text

210− T.pack . fromMaybe defaultProject <$> lookupEnv goproject

140+toUCNs = T.pack . concatMap toUCN . T.unpack

141+

142+toUCN :: Char -> String

143+toUCN c | isAscii c = [c]

144+toUCN c = printf "\\U%08x" $ ord c

211

145

212help :: String

146help :: String

213−help = "Usage: psgo OPTIONS COREFN-FILES\n\

147+help = "Usage: pscpp OPTIONS COREFN-FILES\n\

214− \ PureScript to native (via go) compiler\n\n\

148+ \ PureScript-to-C++ compiler\n\n\

215 \Available options:\n\

149 \Available options:\n\

216 \ --help Show this help text\n\n\

150 \ --help Show this help text\n\n\

217− \ --version Show the version number\n\n\

151+ \ --makefile Generate a GNU Makefile which can be used for compiling\n\

218− \ --run Run the generated go code directly, without building an\n\

152+ \ a PureScript program and libraries to a native binary via\n\

219− \ executable\n\

153+ \ purs corefn output and C++\n\n\

220− \ --no-build Generate go source files, but do not build an executable\n\

154+ \ --ucns Use UCN encoding of unicode characters in literals and\n\

155+ \ strings in generated C++ code (for compilers that do not\n\

156+ \ support unicode literals, such as gcc)\n\n\

221 \ --tests Run test cases (under construction)\n\n\

157 \ --tests Run test cases (under construction)\n\n\

222 \See also:\n\

158 \See also:\n\

223 \ purs compile --help\n"

159 \ 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+12−17

@@ -1,6 +1,6 @@

1−name: psgo

1+name: pscpp

2version: 0.1.0.0

3−github: "andyarvanitis/purescript-native"

3+github: "andyarvanitis/purescript-cpp"

4license: BSD3

5author: "Andy Arvanitis"

6maintainer: "example@example.com"

@@ -9,8 +9,6 @@ copyright: "2018 Andy Arvanitis"

9extra-source-files:

10- README.md

11- ChangeLog.md

12−- stack.yaml

13−- support/*

15# Metadata used when publishing your package

13# Metadata used when publishing your package

16# synopsis: Short description of your package

14# synopsis: Short description of your package

@@ -19,12 +17,11 @@ extra-source-files:

19# To avoid duplicated efforts in documentation and dealing with the

17# To avoid duplicated efforts in documentation and dealing with the

20# complications of embedding Haddock markup inside cabal files, it is

18# complications of embedding Haddock markup inside cabal files, it is

21# common to point users to the README.md file.

19# common to point users to the README.md file.

22−description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>

20+description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-cpp#readme>

24dependencies:

22dependencies:

25- base >= 4.7 && < 5

23- base >= 4.7 && < 5

26−- bytestring >= 0.10.8.2 && < 0.11

27−- purescript

24+- purescript -any

28- base-compat >=0.6.0

25- base-compat >=0.6.0

29- protolude >=0.1.6

26- protolude >=0.1.6

30- text

27- text

@@ -35,12 +32,10 @@ dependencies:

35- safe >=0.3.9 && <0.4

32- safe >=0.3.9 && <0.4

36- transformers >=0.3.0 && <0.6

33- transformers >=0.3.0 && <0.6

37- mtl >=2.1.0 && <2.3.0

34- mtl >=2.1.0 && <2.3.0

38−- aeson >=1.0 && <1.5

35+- aeson >=1.0 && <1.3

39−- directory

36+- directory -any

40−- process

37+- process -any

41−- file-embed

38+- file-embed -any

42−- filemanip

43−- gitrev

45library:

40library:

46 source-dirs: src

41 source-dirs: src

@@ -64,7 +59,7 @@ library:

64 - ViewPatterns

59 - ViewPatterns

66executables:

61executables:

67− psgo:

62+ pscpp:

68 main: Main.hs

63 main: Main.hs

69 source-dirs: app

64 source-dirs: app

70 ghc-options:

65 ghc-options:

@@ -72,10 +67,10 @@ executables:

72 - -rtsopts

67 - -rtsopts

73 - -with-rtsopts=-N

68 - -with-rtsopts=-N

74 dependencies:

69 dependencies:

75− - psgo

70+ - pscpp

77tests:

72tests:

78− psgo-test:

73+ pscpp-test:

79 main: Spec.hs

74 main: Spec.hs

80 source-dirs: test

75 source-dirs: test

81 ghc-options:

76 ghc-options:

@@ -83,4 +78,4 @@ tests:

83 - -rtsopts

78 - -rtsopts

84 - -with-rtsopts=-N

79 - -with-rtsopts=-N

85 dependencies:

80 dependencies:

86− - psgo

81+ - pscpp

psgo.cabal → pscpp.cabalrenamed+24−56

@@ -1,14 +1,16 @@

1cabal-version: 1.12

3−-- This file has been generated from package.yaml by hpack version 0.35.0.

3+-- This file has been generated from package.yaml by hpack version 0.31.0.

4--

5-- see: https://github.com/sol/hpack

6+--

7+-- hash: 21aa75281e615d7fe3001877e6820efd2dd2a33cf67fa7b101603e042139495e

7−name: psgo

9+name: pscpp

8version: 0.1.0.0

10version: 0.1.0.0

9−description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>

11+description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-cpp#readme>

10−homepage: https://github.com/andyarvanitis/purescript-native#readme

12+homepage: https://github.com/andyarvanitis/purescript-cpp#readme

11−bug-reports: https://github.com/andyarvanitis/purescript-native/issues

13+bug-reports: https://github.com/andyarvanitis/purescript-cpp/issues

12author: Andy Arvanitis

14author: Andy Arvanitis

13maintainer: example@example.com

15maintainer: example@example.com

14copyright: 2018 Andy Arvanitis

16copyright: 2018 Andy Arvanitis

@@ -18,60 +20,32 @@ build-type: Simple

18extra-source-files:

20extra-source-files:

19 README.md

21 README.md

20 ChangeLog.md

22 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

27source-repository head

24source-repository head

28 type: git

25 type: git

29− location: https://github.com/andyarvanitis/purescript-native

26+ location: https://github.com/andyarvanitis/purescript-cpp

31library

28library

32 exposed-modules:

29 exposed-modules:

33− CodeGen.IL

30+ CodeGen.Cpp

34− CodeGen.IL.Common

35− CodeGen.IL.Optimizer

31+ CodeGen.Cpp.Common

36− CodeGen.IL.Optimizer.Common

37− CodeGen.IL.Optimizer.Inliner

38− CodeGen.IL.Optimizer.MagicDo

32+ CodeGen.Cpp.Optimizer

39− CodeGen.IL.Optimizer.TCO

33+ CodeGen.Cpp.Optimizer.TCO

40− CodeGen.IL.Printer

34+ CodeGen.Cpp.Printer

41 Tests

35 Tests

42 other-modules:

36 other-modules:

43− Paths_psgo

37+ Paths_pscpp

44 hs-source-dirs:

38 hs-source-dirs:

45 src

39 src

46− default-extensions:

40+ default-extensions: ConstraintKinds DataKinds DeriveFunctor EmptyDataDecls FlexibleContexts KindSignatures LambdaCase MultiParamTypeClasses NoImplicitPrelude PatternGuards PatternSynonyms RankNTypes RecordWildCards OverloadedStrings ScopedTypeVariables TupleSections ViewPatterns

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:

41 build-depends:

65− aeson >=1.0 && <1.5

42+ aeson >=1.0 && <1.3

66 , base >=4.7 && <5

43 , base >=4.7 && <5

67 , base-compat >=0.6.0

44 , base-compat >=0.6.0

68− , bytestring >=0.10.8.2 && <0.11

69 , containers

45 , containers

70 , directory

46 , directory

71 , file-embed

47 , file-embed

72− , filemanip

73 , filepath

48 , filepath

74− , gitrev

75 , monad-parallel >=0.7.2.2 && <0.8

49 , monad-parallel >=0.7.2.2 && <0.8

76 , mtl >=2.1.0 && <2.3.0

50 , mtl >=2.1.0 && <2.3.0

77 , pattern-arrows >=0.0.2 && <0.1

51 , pattern-arrows >=0.0.2 && <0.1

@@ -83,61 +57,55 @@ library

83 , transformers >=0.3.0 && <0.6

57 , transformers >=0.3.0 && <0.6

84 default-language: Haskell2010

58 default-language: Haskell2010

86−executable psgo

60+executable pscpp

87 main-is: Main.hs

61 main-is: Main.hs

88 other-modules:

62 other-modules:

89− Paths_psgo

63+ Paths_pscpp

90 hs-source-dirs:

64 hs-source-dirs:

91 app

65 app

92 ghc-options: -threaded -rtsopts -with-rtsopts=-N

66 ghc-options: -threaded -rtsopts -with-rtsopts=-N

93 build-depends:

67 build-depends:

94− aeson >=1.0 && <1.5

68+ aeson >=1.0 && <1.3

95 , base >=4.7 && <5

69 , base >=4.7 && <5

96 , base-compat >=0.6.0

70 , base-compat >=0.6.0

97− , bytestring >=0.10.8.2 && <0.11

98 , containers

71 , containers

99 , directory

72 , directory

100 , file-embed

73 , file-embed

101− , filemanip

102 , filepath

74 , filepath

103− , gitrev

104 , monad-parallel >=0.7.2.2 && <0.8

75 , monad-parallel >=0.7.2.2 && <0.8

105 , mtl >=2.1.0 && <2.3.0

76 , mtl >=2.1.0 && <2.3.0

106 , pattern-arrows >=0.0.2 && <0.1

77 , pattern-arrows >=0.0.2 && <0.1

107 , process

78 , process

108 , protolude >=0.1.6

79 , protolude >=0.1.6

109− , psgo

80+ , pscpp

110 , purescript

81 , purescript

111 , safe >=0.3.9 && <0.4

82 , safe >=0.3.9 && <0.4

112 , text

83 , text

113 , transformers >=0.3.0 && <0.6

84 , transformers >=0.3.0 && <0.6

114 default-language: Haskell2010

85 default-language: Haskell2010

115

116−test-suite psgo-test

87+test-suite pscpp-test

117 type: exitcode-stdio-1.0

88 type: exitcode-stdio-1.0

118 main-is: Spec.hs

89 main-is: Spec.hs

119 other-modules:

90 other-modules:

120− Paths_psgo

91+ Paths_pscpp

121 hs-source-dirs:

92 hs-source-dirs:

122 test

93 test

123 ghc-options: -threaded -rtsopts -with-rtsopts=-N

94 ghc-options: -threaded -rtsopts -with-rtsopts=-N

124 build-depends:

95 build-depends:

125− aeson >=1.0 && <1.5

96+ aeson >=1.0 && <1.3

126 , base >=4.7 && <5

97 , base >=4.7 && <5

127 , base-compat >=0.6.0

98 , base-compat >=0.6.0

128− , bytestring >=0.10.8.2 && <0.11

129 , containers

99 , containers

130 , directory

100 , directory

131 , file-embed

101 , file-embed

132− , filemanip

133 , filepath

102 , filepath

134− , gitrev

135 , monad-parallel >=0.7.2.2 && <0.8

103 , monad-parallel >=0.7.2.2 && <0.8

136 , mtl >=2.1.0 && <2.3.0

104 , mtl >=2.1.0 && <2.3.0

137 , pattern-arrows >=0.0.2 && <0.1

105 , pattern-arrows >=0.0.2 && <0.1

138 , process

106 , process

139 , protolude >=0.1.6

107 , protolude >=0.1.6

140− , psgo

108+ , pscpp

141 , purescript

109 , purescript

142 , safe >=0.3.9 && <0.4

110 , safe >=0.3.9 && <0.4

143 , text

111 , text

runtime/purescript.hnew file+251

@@ -0,0 +1,251 @@

1+///////////////////////////////////////////////////////////////////////////////

2+//

3+// Module : purescript.h

4+// Copyright : (c) Andy Arvanitis 2018

5+// License : BSD

6+//

7+// Maintainer : Andy Arvanitis

8+// Stability : experimental

9+// Portability :

10+//

11+// Basic types and functions to support purescript-to-C++ rendering

12+//

13+///////////////////////////////////////////////////////////////////////////////

14+//

15+#ifndef purescript_H

16+#define purescript_H

17+

18+#include <memory>

19+#include <functional>

20+#include <deque>

21+#include <string>

22+#include <limits>

23+#include "string_literal_dict.h"

24+

25+

26+namespace purescript {

27+

28+ using std::string;

29+

30+ class boxed {

31+ std::shared_ptr<void> shared;

32+ public:

33+ using fn_t = std::function<boxed(const boxed&)>;

34+ using eff_fn_t = std::function<boxed(void)>;

35+ using dict_t = string_literal_dict_t<boxed>;

36+ using array_t = std::deque<boxed>;

37+

38+ public:

39+ boxed() noexcept : shared() {}

40+ boxed(const std::nullptr_t) noexcept : shared() {}

41+

42+ template <typename T>

43+ boxed(std::shared_ptr<T>&& other) : shared(std::move(other)) {}

44+

45+ template <typename T>

46+ boxed(const std::shared_ptr<T>& other) : shared(other) {}

47+

48+ boxed(const int n) : shared(std::make_shared<int>(n)) {}

49+

50+ boxed(const long n) : shared(std::make_shared<int>(static_cast<int>(n))) {

51+#if !defined(NDEBUG) // if debug build

52+ if (n < std::numeric_limits<int>::min() || n > std::numeric_limits<int>::max()) {

53+ throw std::runtime_error("integer out of range");

54+ }

55+#endif // !defined(NDEBUG)

56+ }

57+

58+ boxed(const unsigned long n) : shared(std::make_shared<int>(static_cast<int>(n))) {

59+#if !defined(NDEBUG) // if debug build

60+ if (n > std::numeric_limits<int>::max()) {

61+ throw std::runtime_error("integer out of range");

62+ }

63+#endif // !defined(NDEBUG)

64+ }

65+

66+ boxed(const double n) : shared(std::make_shared<double>(n)) {}

67+ boxed(const bool b) : shared(std::make_shared<bool>(b)) {}

68+ boxed(const char s[]) : shared(std::make_shared<string>(s)) {}

69+ boxed(string&& s) : shared(std::make_shared<string>(std::move(s))) {}

70+ boxed(const string& s) : shared(std::make_shared<string>(s)) {}

71+ boxed(array_t&& l) : shared(std::make_shared<array_t>(std::move(l))) {}

72+ boxed(const array_t& l) : shared(std::make_shared<array_t>(l)) {}

73+ boxed(dict_t&& m) : shared(std::make_shared<dict_t>(std::move(m))) {}

74+ boxed(const dict_t& m) : shared(std::make_shared<dict_t>(m)) {}

75+

76+ template <typename T,

77+ typename = typename std::enable_if<!std::is_same<boxed,T>::value>::type>

78+ boxed(const T& f,

79+ typename std::enable_if<std::is_assignable<std::function<boxed(boxed)>,T>::value>::type* = 0)

80+ : shared(std::make_shared<fn_t>(f)) {

81+ }

82+

83+ template <typename T,

84+ typename = typename std::enable_if<!std::is_same<boxed,T>::value>::type>

85+ boxed(const T& f,

86+ typename std::enable_if<std::is_assignable<std::function<boxed(void)>,T>::value>::type* = 0)

87+ : shared(std::make_shared<eff_fn_t>(f)) {

88+ }

89+

90+ inline auto get() const noexcept -> void * {

91+ return shared.get();

92+ }

93+

94+ auto operator()(const boxed& arg) const -> boxed {

95+ auto& f = *static_cast<fn_t*>(shared.get());

96+ return f(arg);

97+ }

98+

99+ auto operator()() const -> boxed {

100+ auto& f = *static_cast<eff_fn_t*>(shared.get());

101+ return f();

102+ }

103+

104+ auto operator[](const char key[]) const -> const boxed& {

105+ return (*static_cast<const dict_t*>(shared.get()))[key];

106+ }

107+

108+ auto operator[](const char key[]) -> boxed& {

109+ return (*static_cast<dict_t*>(shared.get()))[key];

110+ }

111+

112+#if !defined(NDEBUG) // if debug build

113+ auto operator[](const int index) const -> const boxed& {

114+ return static_cast<const array_t*>(shared.get())->at(index);

115+ }

116+

117+ auto operator[](const int index) -> boxed& {

118+ return static_cast<array_t*>(shared.get())->at(index);

119+ }

120+#else // not debug build

121+ auto operator[](const int index) const -> const boxed& {

122+ return (*static_cast<const array_t*>(shared.get()))[index];

123+ }

124+

125+ auto operator[](const int index) -> boxed& {

126+ return (*static_cast<array_t*>(shared.get()))[index];

127+ }

128+#endif // !defined(NDEBUG)

129+

130+ class weak {

131+ std::weak_ptr<void> wptr;

132+

133+ public:

134+ weak() = delete;

135+ weak(boxed& b) : wptr(b.shared) {}

136+

137+ operator boxed() const {

138+#if defined(NDEBUG)

139+ return wptr.lock();

140+#else

141+ return static_cast<std::shared_ptr<void>>(wptr);

142+#endif

143+ }

144+

145+ }; // class boxed::weak

146+

147+ class recur {

148+ std::shared_ptr<boxed> sptr;

149+ std::shared_ptr<boxed::weak> wptr;

150+

151+ public:

152+ recur() : sptr(std::make_shared<boxed>())

153+ , wptr(std::make_shared<boxed::weak>(*sptr)) {}

154+

155+ operator const boxed&() const {

156+ return *sptr;

157+ }

158+

159+ operator boxed&() {

160+ return *sptr;

161+ }

162+

163+ auto operator()() const -> boxed {

164+ return (*sptr)();

165+ }

166+

167+ auto operator()(const boxed& arg) const -> boxed {

168+ return (*sptr)(arg);

169+ }

170+

171+ template <typename T>

172+ auto operator=(T&& right) -> recur& {

173+ *sptr = std::forward<T>(right);

174+ *wptr = *sptr;

175+ return *this;

176+ }

177+

178+ class weak {

179+ std::shared_ptr<boxed::weak> wptr;

180+ public:

181+ weak(const recur& r) : wptr(r.wptr) {}

182+

183+ operator boxed() const {

184+ return *wptr;

185+ }

186+

187+ auto operator()() const -> boxed {

188+ return static_cast<boxed>(*wptr)();

189+ }

190+

191+ auto operator()(const boxed& arg) const -> boxed {

192+ return static_cast<boxed>(*wptr)(arg);

193+ }

194+ }; // class recur::weak

195+ }; // class boxed::recur

196+

197+ }; // class boxed

198+

199+ using fn_t = boxed::fn_t;

200+ using eff_fn_t = boxed::eff_fn_t;

201+ using dict_t = boxed::dict_t;

202+ using array_t = boxed::array_t;

203+

204+ template <typename T, typename... Args>

205+ inline auto box(Args&&... args) -> boxed {

206+ return std::make_shared<T>(std::forward<Args>(args)...);

207+ }

208+

209+ template <typename T>

210+ constexpr auto unbox(const boxed& b) -> const T& {

211+ return *static_cast<const T*>(b.get());

212+ }

213+

214+ template <typename T>

215+ constexpr auto unbox(boxed& b) -> T& {

216+ return *static_cast<T*>(b.get());

217+ }

218+

219+ template <typename T>

220+ constexpr auto unbox(const T value) -> T {

221+ return value;

222+ }

223+

224+ template <typename T,

225+ typename = typename std::enable_if<std::is_same<T, int>::value>::type>

226+ constexpr auto unbox(const std::size_t value) -> long long {

227+ return value;

228+ }

229+

230+ inline auto array_length(const boxed& a) -> boxed::array_t::size_type {

231+ return unbox<boxed::array_t>(a).size();

232+ }

233+

234+ constexpr auto undefined = nullptr;

235+

236+} // namespace purescript

237+

238+#define DEFINE_FOREIGN_DICTIONARY_AND_ACCESSOR() \

239+ inline auto foreign() -> dict_t& {\

240+ static dict_t $dict$;\

241+ return $dict$;\

242+ }

243+

244+#define FOREIGN_BEGIN(NS) namespace NS {\

245+ using namespace purescript;\

246+ DEFINE_FOREIGN_DICTIONARY_AND_ACCESSOR()\

247+ static const auto $foreign_exports_init$ = ([]() -> char {\

248+ dict_t& exports = foreign();

249+#define FOREIGN_END return 0; }()); }

250+

251+#endif // purescript_H

runtime/string_literal_dict.hnew file+86

@@ -0,0 +1,86 @@

1+///////////////////////////////////////////////////////////////////////////////

2+//

3+// Module : string_literal_dict.h

4+// Copyright : (c) Andy Arvanitis 2018

5+// License : BSD

6+//

7+// Maintainer : Andy Arvanitis

8+// Stability : experimental

9+// Portability :

10+//

11+// A simple dictionary optimized for this runtime's particular use –

12+// *not* intended for general use or as a replacement for containers

13+// such as std::map or std::unordered_map. It relies on the following

14+// assumptions:

15+//

16+// 1) Keys are C-type string literals. No copying or (memory management)

17+// of the keys occurs

18+// 2) The number of elements in the container is generally small – say,

19+// under 20. There is no sorting and a linear search is used to

20+// locate elements

21+//

22+///////////////////////////////////////////////////////////////////////////////

23+//

24+#ifndef string_literal_dict_H

25+#define string_literal_dict_H

26+

27+#include <cstring>

28+#include <vector>

29+#include <utility>

30+#if !defined(NDEBUG)

31+#include <string>

32+#endif

33+

34+template <typename T>

35+class string_literal_dict_t : public std::vector<std::pair<const char *, T>> {

36+

37+ static auto null() -> const T& {

38+ static const T value;

39+ return value;

40+ }

41+

42+ public:

43+ using std::vector<std::pair<const char *, T>>::vector;

44+

45+ auto operator[](const char key[]) const -> const T& {

46+ for (auto it = this->cbegin(), end=this->cend(); it != end; it++) {

47+ const auto& elem_key = it->first;

48+ if (elem_key == key || !std::strcmp(elem_key, key)) {

49+ return it->second;

50+ }

51+ }

52+#if !defined(NDEBUG) // if debug build

53+ throw std::runtime_error("dictionary key \"" + std::string(key) + "\" not found");

54+#endif

55+ return null();

56+ }

57+

58+ auto at(const char key[]) const -> const T& {

59+ return (*this)[key];

60+ }

61+

62+ auto operator[](const char key[]) -> T& {

63+ const auto end = this->end();

64+ for (auto it = this->begin(); it != end; it++) {

65+ const auto& elem_key = it->first;

66+ if (elem_key == key || !std::strcmp(elem_key, key)) {

67+ return it->second;

68+ }

69+ }

70+ return this->emplace(end, key, T())->second;

71+ }

72+

73+ auto contains(const char key[]) const -> bool {

74+ for (auto it = this->cbegin(), end=this->cend(); it != end; it++) {

75+ const auto& elem_key = it->first;

76+ if (elem_key == key || !std::strcmp(elem_key, key)) {

77+ return true;

78+ }

79+ }

80+ return false;

81+ }

82+

83+};

84+

85+

86+#endif // string_literal_dict_H

src/CodeGen/Cpp.hsnew file+424

@@ -0,0 +1,424 @@

1+-- | This module generates code in the core imperative representation from

2+-- elaborated PureScript code.

3+module CodeGen.Cpp

4+ ( module AST

5+ , module Common

6+ , moduleToCpp

7+ ) where

9+import Prelude.Compat

10+import Protolude (ordNub)

11+

12+import Control.Arrow ((&&&))

13+import Control.Monad (forM, liftM, replicateM, void)

14+import Control.Monad.Supply.Class

15+

16+import Data.List ((\\), delete, intersect, nub)

17+import qualified Data.Foldable as F

18+import qualified Data.Map as M

19+import Data.Maybe (fromMaybe, isNothing, mapMaybe)

20+import Data.Monoid ((<>))

21+import Data.String (fromString)

22+import Data.Text (Text)

23+import qualified Data.Text as T

24+

25+import Language.PureScript.AST.SourcePos

26+import Language.PureScript.CoreImp.AST (AST)

27+import qualified Language.PureScript.CoreImp.AST as AST

28+import Language.PureScript.CoreFn

29+import Language.PureScript.Crash

30+import Language.PureScript.Names

31+import Language.PureScript.Options

32+import Language.PureScript.PSString (PSString, mkString)

33+import Language.PureScript.Traversals (sndM)

34+import qualified Language.PureScript.Constants as C

35+

36+import System.FilePath.Posix ((</>))

37+

38+import CodeGen.Cpp.Common as Common

39+import CodeGen.Cpp.Optimizer

40+import CodeGen.Cpp.Printer

41+

42+data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)

43+

44+-- | Generate code in the simplified intermediate representation for all declarations in a

45+-- module.

46+moduleToCpp

47+ :: forall m

48+ -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)

49+ . (Monad m, MonadSupply m)

50+ => Module Ann

51+ -> Maybe AST

52+ -> m (Text, [Text], [AST], Text, Text)

53+moduleToCpp (Module _ coms mn _ imps _ foreigns decls) _ =

54+ do

55+ let usedNames = concatMap getNames decls

56+ let mnLookup = renameImports usedNames imps

57+ cppImports <- traverse (importToCpp mnLookup) . (\\ (mn : C.primModules)) . (\\ [mn]) $ ordNub $ map snd imps

58+ interfaceImport <- importToCpp (renameImports [] [(emptyAnn, mn)]) mn

59+ let decls' = renameModules mnLookup decls

60+ cppDecls <- mapM (bindToCpp ModuleDecl) decls'

61+ optimized <- traverse (traverse (optimize modName')) cppDecls

62+ let optimized' = concat optimized

63+ values = annotValue <$> optimized'

64+ foreigns' = identToCpp <$> foreigns

65+ interface = interfaceSource modName values foreigns

66+ implHeader = implHeaderSource modName cppImports interfaceImport

67+ implFooter = implFooterSource modName foreigns

68+ return $ (interface, foreigns', optimized', implHeader, implFooter)

69+ where

70+ modName = moduleNameToCpp mn

71+ modName' = AST.Var Nothing modName

72+

73+ annotValue :: AST -> (Text, Bool)

74+ annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))

75+ | isLiteral ret = (name, True)

76+ annotValue (AST.Function _ (Just name) [] _) = (name, False)

77+ annotValue _ = error "Unexpected top-level value form"

78+

79+ -- | Extracts all declaration names from a binding group.

80+ getNames :: Bind Ann -> [Ident]

81+ getNames (NonRec _ ident _) = [ident]

82+ getNames (Rec vals) = map (snd . fst) vals

83+

84+ -- | Creates alternative names for each module to ensure they don't collide

85+ -- with declaration names.

86+ renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)

87+ renameImports = go M.empty

88+ where

89+ go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)

90+ go acc used ((ann, mn') : mns') =

91+ let mni = Ident $ runModuleName mn'

92+ in if mn' /= mn && mni `elem` used

93+ then let newName = freshModuleName 1 mn' used

94+ in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'

95+ else go (M.insert mn' (ann, mn') acc) used mns'

96+ go acc _ [] = acc

97+

98+ freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName

99+ freshModuleName i mn'@(ModuleName pns) used =

100+ let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) <> "_" <> T.pack (show i)]

101+ in if Ident (runModuleName newName) `elem` used

102+ then freshModuleName (i + 1) mn' used

103+ else newName

104+

105+ -- | Generates C++ code for a module import, binding the required module

106+ -- to the alternative

107+ importToCpp :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m Text

108+ importToCpp mnLookup mn' = do

109+ let ((_, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

110+ mname = moduleNameToCpp mnSafe

111+ pure $ "#include \"" <> mname <> "/" <> mname <> ".h\"\n"

112+

113+ -- | Replaces the `ModuleName`s in the AST so that the generated code refers to

114+ -- the collision-avoiding renamed module imports.

115+ renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]

116+ renameModules mnLookup binds =

117+ let (f, _, _) = everywhereOnValues id goExpr goBinder

118+ in map f binds

119+ where

120+ goExpr :: Expr a -> Expr a

121+ goExpr (Var ann q) = Var ann (renameQual q)

122+ goExpr e = e

123+ goBinder :: Binder a -> Binder a

124+ goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs

125+ goBinder b = b

126+ renameQual :: Qualified a -> Qualified a

127+ renameQual (Qualified (Just mn') a) =

128+ let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup

129+ in Qualified (Just mnSafe) a

130+ renameQual q = q

131+

132+ -- |

133+ -- Generate code in the simplified intermediate representation for a declaration

134+ --

135+ bindToCpp :: DeclType -> Bind Ann -> m [AST]

136+ bindToCpp dt (NonRec ann ident val) = return <$> nonRecToCpp dt ann ident val

137+ bindToCpp dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToCpp dt')

138+ where

139+ dt' = if dt == LetDecl then RecLetDecl else dt

140+

141+ -- | Generate code in the simplified intermediate representation for a single non-recursive

142+ -- declaration.

143+ --

144+ -- The main purpose of this function is to handle code generation for comments.

145+ nonRecToCpp :: DeclType -> Ann -> Ident -> Expr Ann -> m AST

146+ nonRecToCpp dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

147+ -- withoutComment <- asks optionsNoComments

148+ let withoutComment = False

149+ if withoutComment

150+ then nonRecToCpp dt a i (modifyAnn removeComments e)

151+ else AST.Comment Nothing com <$> nonRecToCpp dt a i (modifyAnn removeComments e)

152+ nonRecToCpp ModuleDecl (ss, _, _, _) ident val = do

153+ cpp <- valueToCpp val

154+ pure $ AST.Function Nothing (Just $ identToCpp ident) [] (AST.Block Nothing [AST.Return Nothing cpp])

155+ nonRecToCpp RecLetDecl (ss, _, _, _) ident val = do

156+ cpp <- valueToCpp val

157+ pure $

158+ let retainedName = identToCpp ident

159+ retained = AST.Var Nothing $ retainedName

160+ unretainedName = retainedName <> unretainedSuffix

161+ unretained = AST.Var Nothing $ unretainedName

162+ boxed = AST.Var Nothing . -- Note: prevents optimizer from eliminating this

163+ prettyPrintCpp1 $

164+ AST.VariableIntroduction

165+ Nothing

166+ retainedName

167+ (Just unretained)

168+ alias = AST.Var Nothing $ "auto& " <> retainedName <> " = " <> unretainedName

169+ in

170+ case cpp of

171+ AST.Function _ name args (AST.Block Nothing cpps) ->

172+ AST.Assignment Nothing

173+ retained

174+ (AST.Function Nothing

175+ name

176+ args

177+ (AST.Block Nothing (boxed : cpps)))

178+ _ ->

179+ AST.Assignment Nothing

180+ retained

181+ (AST.App Nothing

182+ (AST.Function Nothing

183+ Nothing

184+ []

185+ (AST.Block Nothing ([ alias

186+ , AST.Return Nothing cpp

187+ ])))

188+ [])

189+ nonRecToCpp _ (ss, _, _, _) ident val = do

190+ cpp <- valueToCpp val

191+ pure $ AST.VariableIntroduction Nothing (identToCpp ident) (Just cpp)

192+

193+ -- | Generate code in the simplified intermediate representation for a variable based on a

194+ -- PureScript identifier.

195+ var :: Ident -> AST

196+ var = AST.Var Nothing . identToCpp

197+

198+ -- | Generate code in the simplified intermediate representation for an accessor based on

199+ -- a PureScript identifier. If the name is not valid in C++ (symbol based, reserved name) an

200+ -- indexer is returned.

201+ accessor :: Ident -> AST -> AST

202+ accessor (Ident prop) = accessorString $ mkString prop

203+ accessor (GenIdent _ _) = internalError "GenIdent in accessor"

204+ accessor UnusedIdent = internalError "UnusedIdent in accessor"

205+

206+ accessorString :: PSString -> AST -> AST

207+ accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)

208+

209+ -- | Generate code in the simplified intermediate representation for a value or expression.

210+

211+ valueToCpp :: Expr Ann -> m AST

212+ valueToCpp (Literal (pos, _, _, _) l) = literalToValueCpp pos l

213+ valueToCpp (Accessor _ prop val) =

214+ accessorString prop <$> valueToCpp val

215+ valueToCpp (ObjectUpdate _ o ps) = do

216+ obj <- valueToCpp o

217+ updates <- mapM (sndM valueToCpp) ps

218+ obj' <- freshName

219+ let objVar = AST.Var Nothing obj'

220+ copy = AST.VariableIntroduction Nothing obj' (Just $ AST.App Nothing (AST.Var Nothing (unbox dictType)) [obj])

221+ assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v

222+ sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]

223+ return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []

224+ valueToCpp (Abs _ arg val) = do

225+ ret <- valueToCpp val

226+ let cppArg = case arg of

227+ UnusedIdent -> []

228+ _ -> [identToCpp arg]

229+ return $ AST.Function Nothing Nothing cppArg (AST.Block Nothing [AST.Return Nothing ret])

230+ valueToCpp e@App{} = do

231+ let (f, args) = unApp e []

232+ args' <- mapM valueToCpp args

233+ case f of

234+ Var (_, _, _, Just IsNewtype) _ -> return (head args')

235+ _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToCpp f

236+ where

237+ unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

238+ unApp (App _ val arg) args = unApp val (arg : args)

239+ unApp other args = (other, args)

240+ -- valueToCpp (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =

241+ -- return $ if mn' == mn

242+ -- then AST.Var Nothing (moduleNameToCpp mn' <> "::" <> identToCpp ident)

243+ -- else varToCpp qi

244+ -- valueToCpp (Var (_, _, _, Just IsForeign) (Qualified (Just mn') ident)) =

245+ -- return $ AST.Var Nothing (moduleNameToCpp mn' <> "::" <> identToCpp ident)

246+ -- valueToCpp (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =

247+ -- return $ if mn' == mn

248+ -- then foreignIdent ident

249+ -- else varToCpp qi

250+ -- valueToCpp (Var (_, _, _, Just IsForeign) ident) =

251+ -- internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident)

252+ valueToCpp (Var _ ident) = return $ varToCpp ident

253+ valueToCpp (Case (ss, _, _, _) values binders) = do

254+ vals <- mapM valueToCpp values

255+ bindersToCpp ss binders vals

256+ valueToCpp (Let _ ds val) = do

257+ let recurs = concatMap getNames $ filter isRec ds

258+ recurDs = (\v -> AST.Var Nothing $ "boxed::recur " <> identToCpp v) <$> recurs

259+ recurDsWeak = (\v -> AST.Var

260+ Nothing

261+ ("boxed::recur::weak " <> identToCpp v <> unretainedSuffix <> "(" <> identToCpp v <> ")")

262+ ) <$> recurs

263+ mutualRecurWarning = if any isMutRec $ filter isRec ds

264+ then [AST.Var Nothing "#pragma message(\"Mutually recursive lets will cause retain cycles (memory leaks)\") //"]

265+ else []

266+ ds' <- concat <$> mapM (bindToCpp LetDecl) ds

267+ ret <- valueToCpp val

268+ return $

269+ AST.App Nothing

270+ (AST.Function Nothing

271+ Nothing

272+ []

273+ (AST.Block Nothing (recurDs ++ recurDsWeak ++ mutualRecurWarning ++ ds' ++ [AST.Return Nothing ret])))

274+ []

275+ where

276+ isRec :: Bind Ann -> Bool

277+ isRec (Rec _) = True

278+ isRec _ = False

279+ isMutRec :: Bind Ann -> Bool

280+ isMutRec b | (length . nub $ getNames b) > 1 = True

281+ | otherwise = False

282+ valueToCpp (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"

283+ valueToCpp (Constructor _ _ (ProperName ctor) fields) =

284+ let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :

285+ ((\field -> (mkString (identToCpp field), var field)) `map` fields)

286+ fn = foldr (\f inner -> AST.Function Nothing Nothing [identToCpp f] (AST.Block Nothing [AST.Return Nothing inner])) body fields

287+ in return fn

288+

289+

290+ iife :: Text -> [AST] -> AST

291+ iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []

292+

293+ literalToValueCpp :: SourceSpan -> Literal (Expr Ann) -> m AST

294+ literalToValueCpp ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)

295+ literalToValueCpp ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)

296+ literalToValueCpp ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s

297+ literalToValueCpp ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])

298+ literalToValueCpp ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b

299+ literalToValueCpp ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToCpp xs

300+ literalToValueCpp ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToCpp) ps

301+

302+ -- | Generate code in the simplified intermediate representation for a reference to a

303+ -- variable.

304+ varToCpp :: Qualified Ident -> AST

305+ varToCpp (Qualified Nothing ident) = var ident

306+ varToCpp qual = qualifiedToCpp id qual

307+

308+ -- | Generate code in the simplified intermediate representation for a reference to a

309+ -- variable that may have a qualified name.

310+ qualifiedToCpp :: (a -> Ident) -> Qualified a -> AST

311+ qualifiedToCpp f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = AST.Var Nothing . runIdent $ f a

312+ qualifiedToCpp f (Qualified (Just mn') a) = AST.Indexer Nothing (AST.Var Nothing . identToCpp $ f a) (AST.Var Nothing (moduleNameToCpp mn'))

313+ qualifiedToCpp f (Qualified _ a) = AST.Var Nothing $ identToCpp (f a)

314+

315+ -- foreignIdent :: Ident -> AST

316+ -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")

317+

318+ -- | Generate code in the simplified intermediate representation for pattern match binders

319+ -- and guards.

320+ bindersToCpp :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST

321+ bindersToCpp ss binders vals = do

322+ valNames <- replicateM (length vals) freshName

323+ let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)

324+ cpps <- forM binders $ \(CaseAlternative bs result) -> do

325+ ret <- guardsToCpp result

326+ go valNames ret bs

327+ return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat cpps ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))

328+ []

329+ where

330+ go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]

331+ go _ done [] = return done

332+ go (v:vs) done' (b:bs) = do

333+ done'' <- go vs done' bs

334+ binderToCpp v done'' b

335+ go _ _ _ = internalError "Invalid arguments to bindersToCpp"

336+

337+ failedPatternMessage :: Text

338+ failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss <> ": "

339+

340+ guardsToCpp :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]

341+ guardsToCpp (Left gs) = traverse genGuard gs where

342+ genGuard (cond, val) = do

343+ cond' <- valueToCpp cond

344+ val' <- valueToCpp val

345+ return

346+ (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))

347+ (AST.Block Nothing [AST.Return Nothing val']) Nothing)

348+

349+ guardsToCpp (Right v) = return . AST.Return Nothing <$> valueToCpp v

350+

351+ -- | Generate code in the simplified intermediate representation for a pattern match

352+ -- binder.

353+ binderToCpp :: Text -> [AST] -> Binder Ann -> m [AST]

354+ binderToCpp _ done NullBinder{} = return done

355+ binderToCpp varName done (LiteralBinder _ l) =

356+ literalToBinderCpp varName done l

357+ binderToCpp varName done (VarBinder _ ident) =

358+ return (AST.VariableIntroduction Nothing (identToCpp ident) (Just (AST.Var Nothing varName)) : done)

359+ binderToCpp varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =

360+ binderToCpp varName done b

361+ binderToCpp varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do

362+ cpp <- go (zip fields bs) done

363+ return $ case ctorType of

364+ ProductType -> cpp

365+ SumType ->

366+ [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))

367+ (AST.Block Nothing cpp)

368+ Nothing]

369+ where

370+ go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]

371+ go [] done' = return done'

372+ go ((field, binder) : remain) done' = do

373+ argVar <- freshName

374+ done'' <- go remain done'

375+ cpp <- binderToCpp argVar done'' binder

376+ return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToCpp field) $ AST.Var Nothing varName) : cpp)

377+

378+ binderToCpp _ _ ConstructorBinder{} =

379+ internalError "binderToCpp: Invalid ConstructorBinder in binderToCpp"

380+ binderToCpp varName done (NamedBinder _ ident binder) = do

381+ cpp <- binderToCpp varName done binder

382+ return (AST.VariableIntroduction Nothing (identToCpp ident) (Just (AST.Var Nothing varName)) : cpp)

383+

384+ literalToBinderCpp :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]

385+ literalToBinderCpp varName done (NumericLiteral num) =

386+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]

387+ literalToBinderCpp varName done (CharLiteral c) =

388+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]

389+ literalToBinderCpp varName done (StringLiteral str) =

390+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]

391+ literalToBinderCpp varName done (BooleanLiteral True) =

392+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]

393+ literalToBinderCpp varName done (BooleanLiteral False) =

394+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]

395+ -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]

396+ literalToBinderCpp varName done (ObjectLiteral bs) = go done bs

397+ where

398+ go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]

399+ go done' [] = return done'

400+ go done' ((prop, binder):bs') = do

401+ propVar <- freshName

402+ done'' <- go done' bs'

403+ cpp <- binderToCpp propVar done'' binder

404+ return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : cpp)

405+ literalToBinderCpp varName done (ArrayLiteral bs) = do

406+ cpp <- go done 0 bs

407+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo

408+ (arrayLength $ AST.Var Nothing varName)

409+ (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))

410+ (AST.Block Nothing cpp) Nothing]

411+ where

412+ go :: [AST] -> Integer -> [Binder Ann] -> m [AST]

413+ go done' _ [] = return done'

414+ go done' index (binder:bs') = do

415+ elVar <- freshName

416+ done'' <- go done' (index + 1) bs'

417+ cpp <- binderToCpp elVar done'' binder

418+ return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : cpp)

419+

420+emptyAnn :: Ann

421+emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)

422+

423+arrayLength :: AST -> AST

424+arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]

src/CodeGen/Cpp/Common.hsnew file+223

@@ -0,0 +1,223 @@

1+-- | Common code generation utility functions

2+module CodeGen.Cpp.Common where

4+import Prelude.Compat

6+import Data.Char

7+import Data.Monoid ((<>))

8+import Data.Text (Text)

9+import qualified Data.Text as T

10+

11+import Language.PureScript.Crash

12+import Language.PureScript.Names

13+

14+moduleNameToCpp :: ModuleName -> Text

15+moduleNameToCpp (ModuleName pns) =

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

17+ in if nameIsCppBuiltIn name then "$$" <> name else name

18+

19+-- | Convert an 'Ident' into a valid C++ identifier:

20+--

21+-- * Alphanumeric characters are kept unmodified.

22+--

23+-- * Reserved C++ identifiers are prefixed with '$$'.

24+--

25+-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.

26+identToCpp :: Ident -> Text

27+identToCpp UnusedIdent = unusedName

28+identToCpp (Ident "$__unused") = unusedName

29+identToCpp (Ident name) = properToCpp name

30+identToCpp (GenIdent _ _) = internalError "GenIdent in identToCpp"

31+

32+unusedName :: Text

33+unusedName = "$unused$"

34+

35+properToCpp :: Text -> Text

36+properToCpp name

37+ | nameIsCppReserved name || nameIsCppBuiltIn name || prefixIsReserved name = "$$" <> name

38+ | otherwise = T.concatMap identCharToText name

39+

40+-- | Test if a string is a valid AST identifier without escaping.

41+identNeedsEscaping :: Text -> Bool

42+identNeedsEscaping s = s /= properToCpp s || T.null s

43+

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

45+-- ordinal value.

46+identCharToText :: Char -> Text

47+identCharToText c | isAlphaNum c = T.singleton c

48+identCharToText '_' = "_"

49+identCharToText '\'' = "$prime"

50+identCharToText '$' = "$"

51+identCharToText c = '$' `T.cons` T.pack (show (ord c))

52+

53+-- | Checks whether an identifier name is reserved in C++.

54+nameIsCppReserved :: Text -> Bool

55+nameIsCppReserved name =

56+ name `elem` cppAnyReserved

57+

58+-- | Checks whether a name matches a built-in value in C++.

59+nameIsCppBuiltIn :: Text -> Bool

60+nameIsCppBuiltIn name =

61+ name `elem`

62+ [ "final"

63+ , "override"

64+ , "posix"

65+ , "std"

66+ ]

67+

68+cppAnyReserved :: [Text]

69+cppAnyReserved =

70+ concat

71+ [ cppKeywords

72+ , cppLiterals

73+ ]

74+

75+cppKeywords :: [Text]

76+cppKeywords =

77+ [ "alignas"

78+ , "alignof"

79+ , "and"

80+ , "and_eq"

81+ , "asm"

82+ , "assert"

83+ , "atomic_cancel"

84+ , "atomic_commit"

85+ , "atomic_noexcept"

86+ , "auto"

87+ , "bitand"

88+ , "bitor"

89+ , "bool"

90+ , "break"

91+ , "case"

92+ , "catch"

93+ , "char"

94+ , "char16_t"

95+ , "char32_t"

96+ , "class"

97+ , "compl"

98+ , "concept"

99+ , "const"

100+ , "constexpr"

101+ , "const_cast"

102+ , "continue"

103+ , "concept"

104+ , "decltype"

105+ , "default"

106+ , "delete"

107+ , "do"

108+ , "double"

109+ , "dynamic_cast"

110+ , "else"

111+ , "enum"

112+ , "explicit"

113+ , "export"

114+ , "extern"

115+ , "false"

116+ , "float"

117+ , "for"

118+ , "friend"

119+ , "goto"

120+ , "if"

121+ , "import"

122+ , "inline"

123+ , "int"

124+ , "long"

125+ , "module"

126+ , "mutable"

127+ , "namespace"

128+ , "new"

129+ , "noexcept"

130+ , "not"

131+ , "not_eq"

132+ , "nullptr"

133+ , "nullptr_t"

134+ , "operator"

135+ , "or"

136+ , "or_eq"

137+ , "private"

138+ , "protected"

139+ , "public"

140+ , "register"

141+ , "reinterpret_cast"

142+ , "requires"

143+ , "return"

144+ , "short"

145+ , "signed"

146+ , "sizeof"

147+ , "static"

148+ , "static_assert"

149+ , "static_cast"

150+ , "struct"

151+ , "switch"

152+ , "synchronized"

153+ , "template"

154+ , "this"

155+ , "thread_local"

156+ , "throw"

157+ , "true"

158+ , "try"

159+ , "typedef"

160+ , "typeid"

161+ , "typename"

162+ , "typeof"

163+ , "union"

164+ , "unsigned"

165+ , "using"

166+ , "virtual"

167+ , "void"

168+ , "volatile"

169+ , "wchar_t"

170+ , "while"

171+ , "xor"

172+ , "xor_eq"

173+ ]

174+

175+prefixIsReserved :: Text -> Bool

176+prefixIsReserved name =

177+ any (`T.isPrefixOf` name)

178+ [ "__"

179+ ]

180+

181+cppLiterals :: [Text]

182+cppLiterals =

183+ [ "box"

184+ , "boxed"

185+ , "copy"

186+ , "errno"

187+ , "peek"

188+ , "purescript"

189+ , "runtime_error"

190+ , "setjmp"

191+ , "string"

192+ , "unbox"

193+ ]

194+

195+dictType :: Text

196+dictType = "dict_t"

197+

198+arrayType :: Text

199+arrayType = "array_t"

200+

201+int :: Text

202+int = "int"

203+

204+float :: Text

205+float = "double"

206+

207+bool :: Text

208+bool = "bool"

209+

210+string :: Text

211+string = "string"

212+

213+unbox :: Text -> Text

214+unbox t = "unbox<" <> t <> ">"

215+

216+arrayLengthFn :: Text

217+arrayLengthFn = "array_length"

218+

219+unretainedSuffix :: Text

220+unretainedSuffix = "$weak"

221+

222+tcoLoop :: Text

223+tcoLoop = "$TCO_loop$"

src/CodeGen/Cpp/Optimizer.hsnew file+140

@@ -0,0 +1,140 @@

1+-- | This module optimizes code in the intermediate representation.

2+module CodeGen.Cpp.Optimizer (optimize) where

4+import Prelude.Compat

6+import Control.Monad.Supply.Class (MonadSupply)

7+import Data.Text (Text)

8+import Language.PureScript.CoreImp.AST

9+import Language.PureScript.CoreImp.Optimizer.Blocks

10+import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)

11+import Language.PureScript.CoreImp.Optimizer.Inliner hiding (inlineUnsafeCoerce, inlineUnsafePartial)

12+import Language.PureScript.CoreImp.Optimizer.Unused

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

14+

15+import CodeGen.Cpp.Common (unusedName)

16+import CodeGen.Cpp.Optimizer.TCO

17+

18+import qualified Language.PureScript.Constants as C

19+

20+

21+-- | Apply a series of optimizer passes to simplified Objective-C code

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

23+-- optimize = untilFixedPoint $ return . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp . tco

24+optimize mn cpp = do

25+ cpp' <- untilFixedPoint (return . inlineApply . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) cpp

26+ untilFixedPoint (return . tidyUp) . tco mn

27+ =<< untilFixedPoint (return . magicDo')

28+ =<< untilFixedPoint (return . magicDo) cpp'

29+

30+

31+ where

32+ tidyUp :: AST -> AST

33+ tidyUp = applyAll

34+ [ collapseNestedBlocks

35+ -- , collapseNestedIfs

36+ , collapseIfChecks

37+ , removeCodeAfterReturnStatements

38+ , unThunk

39+ , etaConvert

40+ , evaluateIifes

41+ , inlineVariables

42+ ]

43+

44+untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a

45+untilFixedPoint f = go

46+ where

47+ go a = do

48+ a' <- f a

49+ if a' == a then return a' else go a'

50+

51+-- | Overridden from CoreImp

52+

53+inlineUnsafePartial :: AST -> AST

54+inlineUnsafePartial = everywhereTopDown convert where

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

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

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

58+ -- if it is safe to do so

59+ = App ss comp [ Var ss C.undefined ]

60+ convert other = other

61+

62+inlineUnsafeCoerce :: AST -> AST

63+inlineUnsafeCoerce = everywhereTopDown convert where

64+ convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])

65+ | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce

66+ = comp

67+ convert other = other

68+

69+inlineApply :: AST -> AST

70+inlineApply = everywhereTopDown convert where

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

72+ | apply == C.apply && dataFunction == C.dataFunction

73+ = App ss f [ arg ]

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

75+ | applyFlipped == C.applyFlipped && dataFunction == C.dataFunction

76+ = App ss f [ arg ]

77+ convert other = other

78+

79+collapseIfChecks :: AST -> AST

80+collapseIfChecks = everywhere collapse where

81+ collapse :: AST -> AST

82+ collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs

83+ collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)

84+ | prop == "otherwise" && val == "Data_Boolean" = exprs

85+ collapse exprs = exprs

86+

87+magicDo :: AST -> AST

88+magicDo = magicDo'' C.eff C.effDictionaries

89+

90+magicDo' :: AST -> AST

91+magicDo' = magicDo'' C.effect C.effectDictionaries

92+

93+magicDo'' :: Text -> C.EffectDictionaries -> AST -> AST

94+magicDo'' effectModule C.EffectDictionaries{..} = everywhereTopDown convert

95+ where

96+ -- Desugar monomorphic calls to >>= and return for the Eff monad

97+ convert :: AST -> AST

98+ -- Desugar pure

99+ convert (App _ (App _ pure' [val]) []) | isPure pure' = val

100+ -- Desugar discard

101+ convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 cpp)]) | isDiscard bind && unused == unusedName =

102+ Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns cpp )

103+ -- Desugar bind

104+ convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 cpp)]) | isBind bind =

105+ Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns cpp)

106+ -- Inline double applications

107+ convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =

108+ App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []

109+ convert other = other

110+

111+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad

112+ isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True

113+ isBind _ = False

114+ -- Check if an expression represents a call to @discard@

115+ isDiscard (App _ (App _ fn [dict1]) [dict2])

116+ | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&

117+ isDict (effectModule, edBindDict) dict2 &&

118+ isDiscardPoly fn = True

119+ isDiscard _ = False

120+ -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative

121+ isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True

122+ isPure _ = False

123+ -- Check if an expression represents the polymorphic >>= function

124+ isBindPoly = isDict (C.controlBind, C.bind)

125+ -- Check if an expression represents the polymorphic pure function

126+ isPurePoly = isDict (C.controlApplicative, C.pure')

127+ -- Check if an expression represents the polymorphic discard function

128+ isDiscardPoly = isDict (C.controlBind, C.discard)

129+

130+

131+ applyReturns :: AST -> AST

132+ applyReturns (Return ss ret) = Return ss (App ss ret [])

133+ applyReturns (Block ss cpps) = Block ss (map applyReturns cpps)

134+ applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)

135+ applyReturns other = other

136+

137+ isDict :: (Text, PSString) -> AST -> Bool

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

139+ Just x == decodeString dictName && y == moduleName

140+ isDict _ _ = False

src/CodeGen/IL/Optimizer/TCO.hs → src/CodeGen/Cpp/Optimizer/TCO.hsrenamed+18−16

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

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

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

3import Prelude.Compat

@@ -7,26 +7,23 @@ import Data.Monoid ((<>))

7import Language.PureScript.CoreImp.AST

8import Language.PureScript.AST.SourcePos (SourceSpan)

9import Safe (headDef, tailSafe)

10−import CodeGen.IL.Common

10+import CodeGen.Cpp.Common

12import qualified Language.PureScript.Constants as C

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 = "$TCO_" <> arg <> "$"

22 copyVar :: Text -> Text

19 copyVar :: Text -> Text

23− copyVar arg = "ṩcopy_" <> arg

20+ copyVar arg = "$TCO_copy_" <> arg <> "$"

25 tcoDone :: Text

22 tcoDone :: Text

26− tcoDone = "ṩtco_done"

23+ tcoDone = "$TCO_done$"

28 tcoResult :: Text

25 tcoResult :: Text

29− tcoResult = "ṩtco_result"

26+ tcoResult = "$TCO_result$"

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

97− [ Assignment rootSS (Var rootSS $ "var " <> tcoDone) $ BooleanLiteral Nothing False

95+ -- [ VariableIntroduction rootSS (blockDecl <> tcoDone) Nothing

96+ [ Var rootSS ("bool " <> tcoDone <> " = false")

97+ -- , Assignment rootSS (Var rootSS tcoDone) (BooleanLiteral rootSS False)

98+ -- , Assignment rootSS (Var rootSS tcoDone) (Var rootSS "NO")

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 ("const auto " <> tcoLoop)) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))

101+ -- , While rootSS (Binary Nothing EqualTo (Var rootSS tcoDone) (BooleanLiteral Nothing False))

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/Cpp/Printer.hsnew file+501

@@ -0,0 +1,501 @@

1+-- | Pretty printer for the AST

2+module CodeGen.Cpp.Printer

3+ ( prettyPrintCpp

4+ , prettyPrintCpp1

5+ , prettyPrintCppWithSourceMaps

6+ , interfaceSource

7+ , implHeaderSource

8+ , implFooterSource

9+ , isLiteral

10+ ) where

11+

12+import Prelude.Compat

13+

14+import Control.Arrow ((<+>))

15+import Control.Monad (forM, mzero)

16+import Control.Monad.State (StateT, evalStateT)

17+import Control.PatternArrows

18+import Data.Char (isAscii)

19+import Data.List (filter, (\\))

20+import qualified Control.Arrow as A

21+

22+import Data.Maybe (fromMaybe)

23+import Data.Monoid ((<>))

24+import Data.Text (Text)

25+import qualified Data.Text as T

26+

27+import Language.PureScript.AST (SourceSpan(..))

28+import Language.PureScript.CoreImp.AST

29+import Language.PureScript.Comments

30+import Language.PureScript.Crash

31+import Language.PureScript.Names (Ident, runIdent)

32+import Language.PureScript.Pretty.Common

33+import Language.PureScript.PSString (PSString, decodeString, mkString)

34+import CodeGen.Cpp.Common

35+

36+import qualified Language.PureScript.Constants as C

37+

38+-- TODO (Christoph): Get rid of T.unpack / pack

39+

40+literals :: (Emit gen) => Pattern PrinterState AST gen

41+literals = mkPattern' match'

42+ where

43+ match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen

44+ match' cpp = (addMapping' (getSourceSpan cpp) <>) <$> match cpp

45+

46+ match :: (Emit gen) => AST -> StateT PrinterState Maybe gen

47+ match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n

48+ match (StringLiteral _ s) = return $ emit $ stringLiteral s

49+ match (BooleanLiteral _ True) = return $ emit "true"

50+ match (BooleanLiteral _ False) = return $ emit "false"

51+ match (ArrayLiteral _ xs) = mconcat <$> sequence

52+ [ return . emit $ arrayType <> "{ "

53+ , intercalate (emit ", ") <$> forM xs prettyPrintCpp'

54+ , return $ emit " }"

55+ ]

56+ -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"

57+ match (ObjectLiteral _ ps) = mconcat <$> sequence

58+ [ return . emit $ dictType <> "{\n"

59+ , withIndent $ do

60+ cpps <- forM ps $ \(key, value) -> do

61+ value' <- prettyPrintCpp' value

62+ return $ emit "{ " <> objectPropertyToString key <> value' <> emit " }"

63+ indentString <- currentIndent

64+ return $ intercalate (emit ",\n") $ map (indentString <>) cpps

65+ , return $ emit "\n"

66+ , currentIndent

67+ , return $ emit "}"

68+ ]

69+ where

70+ objectPropertyToString :: (Emit gen) => PSString -> gen

71+ objectPropertyToString s = emit $ stringLiteral s <> ", "

72+ match (Block _ sts) = mconcat <$> sequence

73+ [ return $ emit "{\n"

74+ , withIndent $ prettyStatements sts

75+ , return $ emit "\n"

76+ , currentIndent

77+ , return $ emit "}"

78+ ]

79+ match (Var _ ident) = return $ emit ident

80+ match (VariableIntroduction _ ident value) = mconcat <$> sequence

81+ [ return $ emit $ "boxed " <> ident

82+ , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintCpp') value

83+ ]

84+ match (Assignment _ target value) = mconcat <$> sequence

85+ [ prettyPrintCpp' target

86+ , return $ emit " = "

87+ , prettyPrintCpp' value

88+ ]

89+ match (App _ val []) = mconcat <$> sequence

90+ [ prettyPrintCpp' val

91+ , return $ emit "()"

92+ ]

93+ match (App ss (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [x]) [y])

94+ | fnMod == dictMod

95+ , dictMod == C.dataEq || dictMod == C.dataSemiring || dictMod == C.dataRing || dictMod == C.dataEuclideanRing

96+ , Just op <- renderOp fn

97+ , Just t <- unboxType dict

98+ = mconcat <$> sequence

99+ [ return $ emit $ unbox' t x

100+ , return $ emit op

101+ , return $ emit $ unbox' t y

102+ ]

103+ match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])

104+ | fnMod == dictMod

105+ , dictMod == C.dataRing

106+ , fn == C.negate

107+ , Just t <- unboxType dict

108+ = mconcat <$> sequence

109+ [ return $ emit "-"

110+ , return $ emit $ unbox' t n

111+ ]

112+ match (App _ val args) = mconcat <$> sequence

113+ [ prettyPrintCpp' val

114+ , return $ emit "("

115+ , intercalate (emit ", ") <$> forM args prettyPrintCpp'

116+ , return $ emit ")"

117+ ]

118+ match (Function _ (Just name) [] (Block _ [Return _ ret]))

119+ | isLiteral ret = mconcat <$> sequence

120+ [ return $ emit "auto "

121+ , return $ emit name

122+ , return $ emit "() -> const boxed& "

123+ , return $ emit "{\n"

124+ , withIndent $ do

125+ indentString <- currentIndent

126+ return $ indentString <> emit staticValueBegin

127+ , withIndent $ do

128+ case ret of

129+ Function _ Nothing args body -> mconcat <$> sequence

130+ [ return $ emit "[]("

131+ , return $ emit $ intercalate ", " (renderArg <$> args)

132+ , return $ emit ") -> boxed "

133+ , prettyPrintCpp' body

134+ ]

135+ _ -> do

136+ prettyPrintCpp' ret

137+ , return $ emit ";\n"

138+ , withIndent $ do

139+ indentString <- currentIndent

140+ return $ indentString <> emit staticValueEnd

141+ , return $ emit "\n}"

142+ ]

143+ match (Function _ (Just name) [] ret) = mconcat <$> sequence

144+ [ return $ emit "auto "

145+ , return $ emit name

146+ , return $ emit "() -> boxed "

147+ , prettyPrintCpp' ret

148+ ]

149+ match (Function _ name args ret) = mconcat <$> sequence

150+ [ return $ emit captures

151+ , return $ emit "("

152+ , return $ emit $ intercalate ", " (render <$> args)

153+ , return $ emit ") -> boxed "

154+ , prettyPrintCpp' ret

155+ ]

156+ where

157+ (captures, render)

158+ | name == Just tcoLoop = ("[&]", renderArgByVal)

159+ | otherwise = ("[=]", renderArg)

160+ match (Indexer _ prop@(Var _ name) val) = mconcat <$> sequence

161+ [ prettyPrintCpp' val

162+ , return $ emit "::"

163+ , prettyPrintCpp' prop

164+ , return $ emit "()"

165+ ]

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

167+ [ prettyPrintCpp' val

168+ , return $ emit "["

169+ , prettyPrintCpp' prop

170+ , return $ emit "]"

171+ ]

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

173+ [ return . emit $ unbox' dictType val

174+ , return $ emit ".contains("

175+ , prettyPrintCpp' ty

176+ , return $ emit ")"

177+ ]

178+ match (While _ cond sts) = mconcat <$> sequence

179+ [ return $ emit "while ("

180+ , prettyPrintCpp' cond

181+ , return $ emit ") "

182+ , prettyPrintCpp' sts

183+ ]

184+ match (For _ ident start end sts) = mconcat <$> sequence

185+ [ return $ emit $ "for (boxed " <> ident <> " = "

186+ , prettyPrintCpp' start

187+ , return $ emit $ "; " <> ident <> " < "

188+ , prettyPrintCpp' end

189+ , return $ emit $ "; " <> ident <> "++) "

190+ , prettyPrintCpp' sts

191+ ]

192+ match (ForIn _ ident obj sts) = mconcat <$> sequence

193+ [ return $ emit $ "for (boxed " <> ident <> " in "

194+ , prettyPrintCpp' obj

195+ , return $ emit ") "

196+ , prettyPrintCpp' sts

197+ ]

198+ match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence

199+ [ return $ emit "if ("

200+ , return $ emit $ unbox' "bool" cond

201+ , return $ emit ") "

202+ , prettyPrintCpp' thens

203+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses

204+ ]

205+ match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence

206+ [ return $ emit "if (!("

207+ , return $ emit $ unbox' "bool" cond

208+ , return $ emit ")) "

209+ , prettyPrintCpp' thens

210+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses

211+ ]

212+ match (IfElse _ (Binary _ EqualTo x y@(NumericLiteral _ n)) thens elses) = mconcat <$> sequence

213+ [ return $ emit "if ("

214+ , return $ emit $ unbox' t x

215+ , return $ emit $ " == "

216+ , prettyPrintCpp' y

217+ , return $ emit ") "

218+ , prettyPrintCpp' thens

219+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses

220+ ]

221+ where

222+ t | Left _ <- n = int

223+ | Right _ <- n = float

224+ match (IfElse _ (Binary _ EqualTo a b@StringLiteral{}) thens elses) = mconcat <$> sequence

225+ [ return $ emit "if ("

226+ , return $ emit $ unbox' string a

227+ , return $ emit $ " == "

228+ , prettyPrintCpp' b

229+ , return $ emit ") "

230+ , prettyPrintCpp' thens

231+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses

232+ ]

233+ match (IfElse _ cond thens elses) = mconcat <$> sequence

234+ [ return $ emit "if ("

235+ , prettyPrintCpp' cond

236+ , return $ emit ") "

237+ , prettyPrintCpp' thens

238+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintCpp') elses

239+ ]

240+ match (Return _ value) = mconcat <$> sequence

241+ [ return $ emit "return "

242+ , prettyPrintCpp' value

243+ ]

244+ match (ReturnNoResult _) = return $ emit "return undefined"

245+ -- match (Throw _ _) = return mempty

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

247+ [ return $ emit "throw "

248+ , return $ emit "std::runtime_error(\"PatternMatchFailure: \""

249+ , prettyPrintCpp' value

250+ , return $ emit ")"

251+ ]

252+ match (Comment _ com cpp) = mconcat <$> sequence

253+ [ return $ emit "\n"

254+ , mconcat <$> forM com comment

255+ , prettyPrintCpp' cpp

256+ ]

257+ match _ = mzero

258+

259+ comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen

260+ comment (LineComment com) = fmap mconcat $ sequence $

261+ [ currentIndent

262+ , return $ emit "//" <> emit com <> emit "\n"

263+ ]

264+ comment (BlockComment com) = fmap mconcat $ sequence $

265+ [ currentIndent

266+ , return $ emit "/**\n"

267+ ] ++

268+ map asLine (T.lines com) ++

269+ [ currentIndent

270+ , return $ emit " */\n"

271+ , currentIndent

272+ ]

273+ where

274+ asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen

275+ asLine s = do

276+ i <- currentIndent

277+ return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"

278+

279+ removeComments :: Text -> Text

280+ removeComments t =

281+ case T.stripPrefix "*/" t of

282+ Just rest -> removeComments rest

283+ Nothing -> case T.uncons t of

284+ Just (x, xs) -> x `T.cons` removeComments xs

285+ Nothing -> ""

286+

287+unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen

288+unary' op mkStr = Wrap match (const)

289+ where

290+ match :: (Emit gen) => Pattern PrinterState AST (gen, AST)

291+ match = mkPattern match'

292+ where

293+ match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)

294+ match' _ = Nothing

295+

296+unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen

297+unary op str = unary' op (\v -> str <> "(" <> prettyPrintCpp1 v <> ")")

298+

299+negateOperator :: (Emit gen) => Operator PrinterState AST gen

300+negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")

301+ where

302+ isNegate (Unary _ Negate _) = True

303+ isNegate _ = False

304+

305+binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen

306+binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)

307+ where

308+ match :: Pattern PrinterState AST (AST, AST)

309+ match = mkPattern match'

310+ where

311+ match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)

312+ match' _ = Nothing

313+

314+isLiteral :: AST -> Bool

315+isLiteral Function{} = True

316+isLiteral NumericLiteral{} = True

317+isLiteral StringLiteral{} = True

318+isLiteral BooleanLiteral{} = True

319+isLiteral ObjectLiteral{} = True

320+isLiteral ArrayLiteral{} = True

321+isLiteral _ = False

322+

323+prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen

324+prettyStatements sts = do

325+ cpps <- forM sts prettyPrintCpp'

326+ indentString <- currentIndent

327+ return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) cpps

328+

329+-- | Generate a pretty-printed string representing a collection of Objective-C expressions at the same indentation level

330+prettyPrintCppWithSourceMaps :: [AST] -> (Text, [SMap])

331+prettyPrintCppWithSourceMaps cpp =

332+ let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) cpp

333+ in (s, mp)

334+

335+prettyPrintCpp :: [AST] -> Text

336+prettyPrintCpp = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements

337+

338+-- | Generate an indented, pretty-printed string representing a Objective-C expression

339+prettyPrintCpp' :: (Emit gen) => AST -> StateT PrinterState Maybe gen

340+prettyPrintCpp' = A.runKleisli $ runPattern matchValue

341+ where

342+ matchValue :: (Emit gen) => Pattern PrinterState AST gen

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

344+ operators :: (Emit gen) => OperatorTable PrinterState AST gen

345+ operators =

346+ OperatorTable [ [ unary New "box" ]

347+ , [ unary Not "!"

348+ , unary BitwiseNot "~"

349+ , unary Positive "+"

350+ , negateOperator ]

351+ , [ binary Multiply "*"

352+ , binary Divide "/"

353+ , binary Modulus "%" ]

354+ , [ binary Add "+"

355+ , binary Subtract "-" ]

356+ , [ binary ShiftLeft "<<"

357+ , binary ShiftRight ">>"

358+ , binary ZeroFillShiftRight ">>>" ]

359+ , [ binary LessThan "<"

360+ , binary LessThanOrEqualTo "<="

361+ , binary GreaterThan ">"

362+ , binary GreaterThanOrEqualTo ">=" ]

363+ , [ binary EqualTo "=="

364+ , binary NotEqualTo "!=" ]

365+ , [ binary BitwiseAnd "&" ]

366+ , [ binary BitwiseXor "^" ]

367+ , [ binary BitwiseOr "|" ]

368+ , [ binary And "&&" ]

369+ , [ binary Or "||" ]

370+ ]

371+

372+prettyPrintCpp1 :: AST -> Text

373+prettyPrintCpp1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintCpp'

374+

375+stringLiteral :: PSString -> Text

376+stringLiteral pss | Just s <- decodeString pss =

377+ (if T.all isAscii s

378+ then ""

379+ else ("u8")) <> stringLiteral' s

380+ where

381+ stringLiteral' :: Text -> Text

382+ stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""

383+ encodeChar :: Char -> Text

384+ encodeChar '\0' = "\\0"

385+ encodeChar '\b' = "\\b"

386+ encodeChar '\t' = "\\t"

387+ encodeChar '\n' = "\\n"

388+ encodeChar '\v' = "\\v"

389+ encodeChar '\f' = "\\f"

390+ encodeChar '\r' = "\\r"

391+ encodeChar '"' = "\\\""

392+ encodeChar '\\' = "\\\\"

393+ encodeChar c = T.singleton $ c

394+stringLiteral _ = "\"\\uFFFD\""

395+

396+unbox' :: Text -> AST -> Text

397+unbox' _ v@(NumericLiteral{}) = prettyPrintCpp1 v

398+unbox' _ v@(BooleanLiteral{}) = prettyPrintCpp1 v

399+unbox' _ v@(StringLiteral{}) = prettyPrintCpp1 v

400+unbox' t v = unbox t <> "(" <> prettyPrintCpp1 v <> ")"

401+

402+unboxType :: Text -> Maybe Text

403+unboxType t

404+ | t == C.eqInt ||

405+ t == C.semiringInt ||

406+ t == C.ringInt

407+ = Just int

408+ | t == C.semiringNumber ||

409+ t == C.ringNumber ||

410+ t == C.euclideanRingNumber

411+ = Just float

412+ | otherwise = Nothing

413+

414+renderOp :: Text -> Maybe Text

415+renderOp op

416+ | op == C.eq = Just " == "

417+ | op == C.notEq = Just " != "

418+ | op == C.add = Just " + "

419+ | op == C.sub = Just " - "

420+ | op == C.mul = Just " * "

421+ | op == C.div = Just " / "

422+ | otherwise = Nothing

423+

424+interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text

425+interfaceSource mn values foreigns =

426+ let foreigns' = identToCpp <$> foreigns

427+ valueNames = fst <$> values

428+ values' = filter ((`notElem` foreigns') . fst) values ++

429+ zip (foreigns' \\ valueNames) (repeat True)

430+ in

431+ "// Generated by pscpp compiler\n\n" <>

432+ "#ifndef " <> mn <> "_H\n" <>

433+ "#define " <> mn <> "_H\n\n" <>

434+ "#include \"purescript.h\"\n\n" <>

435+ "namespace " <> mn <> " {\n\n" <>

436+ "using namespace purescript;\n\n" <>

437+ (T.concat $ (\(export, static) ->

438+ let rty = if static then "const boxed&" else "boxed" in

439+ "auto " <> export <> "() -> " <> rty <> ";\n") <$> values') <> "\n" <>

440+ "} // end namespace " <> mn <> "\n\n" <>

441+ "#endif // " <> mn <> "_H\n\n"

442+

443+implHeaderSource :: Text -> [Text] -> Text -> Text

444+implHeaderSource mn imports interfaceImport =

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

446+ interfaceImport <> "\n\n" <>

447+ "namespace " <> mn <> " {\n\n"

448+

449+implFooterSource :: Text -> [Ident] -> Text

450+implFooterSource mn foreigns =

451+ "\n\n\n" <>

452+ (if null foreigns

453+ then ""

454+ else ("// Foreign values\n\n" <>

455+ "DEFINE_FOREIGN_DICTIONARY_AND_ACCESSOR()\n\n" <>

456+ (T.concat $ (\foreign' -> "auto " <>

457+ identToCpp foreign' <>

458+ "() -> const boxed& { " <>

459+ staticValueBegin <>

460+ foreignDict <> "().at(" <>

461+ (stringLiteral . mkString $ runIdent foreign') <> "); " <>

462+ staticValueEnd <>

463+ " };\n") <$> foreigns) <>

464+ "\n")) <>

465+ "} // end namespace " <> mn <>

466+ "\n\n" <>

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

468+ where

469+ mainSource :: Text

470+ mainSource = "\

471+ \int main(int argc, const char * argv[]) {\n\

472+ \ Main::main()();\n\

473+ \ return 0;\n\

474+ \}\n\n\

475+ \"

476+

477+varDecl :: Text

478+varDecl = "const boxed"

479+

480+varRefDecl :: Text

481+varRefDecl = varDecl <> "&"

482+

483+renderArg' :: Text -> Text -> Text

484+renderArg' decl arg

485+ | arg == unusedName = decl

486+ | otherwise = decl <> " " <> arg

487+

488+renderArg :: Text -> Text

489+renderArg = renderArg' varRefDecl

490+

491+renderArgByVal :: Text -> Text

492+renderArgByVal = renderArg' varDecl

493+

494+foreignDict :: Text

495+foreignDict = "foreign"

496+

497+staticValueBegin :: Text

498+staticValueBegin = "static const boxed _ = "

499+

500+staticValueEnd :: Text

501+staticValueEnd = "return _;"

src/CodeGen/IL.hsdeleted−321

@@ -1,321 +0,0 @@

1−-- | This module generates code in the core imperative representation from

2−-- elaborated PureScript code.

3−module CodeGen.IL

4− ( module AST

5− , module Common

6− , moduleToIL

7− ) where

8−

9−import Prelude.Compat

10−import Protolude (ordNub)

11−

12−import Control.Arrow ((&&&))

13−import Control.Monad (forM, liftM, replicateM, void)

14−import Control.Monad.Supply.Class

15−

16−import Data.List ((\\), delete, intersect, nub)

17−import qualified Data.Foldable as F

18−import qualified Data.Map as M

19−import Data.Maybe (fromMaybe, isNothing, mapMaybe)

20−import Data.Monoid ((<>))

21−import Data.String (fromString)

22−import Data.Text (Text)

23−import qualified Data.Text as T

24−

25−import Language.PureScript.AST.SourcePos

26−import Language.PureScript.CoreImp.AST (AST)

27−import qualified Language.PureScript.CoreImp.AST as AST

28−import Language.PureScript.CoreFn

29−import Language.PureScript.Crash

30−import Language.PureScript.Names

31−import Language.PureScript.Options

32−import Language.PureScript.PSString (PSString, mkString)

33−import Language.PureScript.Traversals (sndM)

34−import qualified Language.PureScript.Constants as C

35−

36−import System.FilePath.Posix ((</>))

37−

38−import CodeGen.IL.Common as Common

39−import CodeGen.IL.Optimizer

40−import CodeGen.IL.Printer

41−

42−data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)

43−

44−-- | Generate code in the simplified intermediate representation for all declarations in a

45−-- module.

46−moduleToIL

47− :: forall m

48− -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)

49− . (Monad m, MonadSupply m)

50− => Module Ann

51− -> Text

52− -> m (Text, [Text], [AST], Text, Text)

53−moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =

54− do

55− ilDecls <- mapM (bindToIL ModuleDecl) decls

56− optimized <- traverse (traverse (optimize modName')) ilDecls

57− let optimized' = concat optimized

58− values = annotValue <$> optimized'

59− foreigns' = moduleIdentToIL <$> foreigns

60− interface = interfaceSource modName values foreigns

61− imports = nub . concat $ importToIL <$> optimized'

62− implHeader = implHeaderSource modName imports project

63− implFooter = implFooterSource (runModuleName mn) foreigns

64− return $ (interface, foreigns', optimized', implHeader, implFooter)

65− where

66− modName = moduleNameToIL mn

67− modName' = AST.Var Nothing modName

68−

69− annotValue :: AST -> (Text, Bool)

70− annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))

71− | isLiteral ret = (name, True)

72− annotValue (AST.Function _ (Just name) [] _) = (name, False)

73− annotValue _ = error "Unexpected top-level value form"

74−

75− -- | Extracts all declaration names from a binding group.

76− getNames :: Bind Ann -> [Ident]

77− getNames (NonRec _ ident _) = [ident]

78− getNames (Rec vals) = map (snd . fst) vals

79−

80− -- | Generates IL code for a module import

81− --

82− importToIL :: AST -> [Text]

83− importToIL = AST.everything (++) modRef

84− where

85− modRef (AST.Indexer _ (AST.Var _ _) (AST.Var _ mname))

86− | not $ T.null mname = [extract mname]

87− modRef _ = []

88− extract :: Text -> Text

89− extract = T.replace "_" "." . T.dropWhileEnd (=='_')

90−

91− -- |

92− -- Generate code in the simplified intermediate representation for a declaration

93− --

94− bindToIL :: DeclType -> Bind Ann -> m [AST]

95− bindToIL dt (NonRec ann ident val) = return <$> nonRecToIL dt ann ident val

96− bindToIL dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToIL dt')

97− where

98− dt' = if dt == LetDecl then RecLetDecl else dt

99−

100− -- | Generate code in the simplified intermediate representation for a single non-recursive

101− -- declaration.

102− --

103− -- The main purpose of this function is to handle code generation for comments.

104− nonRecToIL :: DeclType -> Ann -> Ident -> Expr Ann -> m AST

105− nonRecToIL dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

106− -- withoutComment <- asks optionsNoComments

107− let withoutComment = False

108− if withoutComment

109− then nonRecToIL dt a i (modifyAnn removeComments e)

110− else AST.Comment Nothing com <$> nonRecToIL dt a i (modifyAnn removeComments e)

111− nonRecToIL ModuleDecl (ss, _, _, _) ident val = do

112− il <- valueToIL val

113− pure $ AST.Function Nothing (Just $ moduleIdentToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])

114− nonRecToIL RecLetDecl (ss, _, _, _) ident val = do

115− ilExpr <- valueToIL val

116− pure $ AST.Assignment Nothing (AST.Var Nothing $ identToIL ident) ilExpr

117− nonRecToIL _ (ss, _, _, _) ident val = do

118− il <- valueToIL val

119− pure $ AST.VariableIntroduction Nothing (identToIL ident) (Just il)

120−

121− -- | Generate code in the simplified intermediate representation for a variable based on a

122− -- PureScript identifier.

123− var :: Ident -> AST

124− var = AST.Var Nothing . identToIL

125−

126− accessorString :: PSString -> AST -> AST

127− accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)

128−

129− -- | Generate code in the simplified intermediate representation for a value or expression.

130−

131− valueToIL :: Expr Ann -> m AST

132− valueToIL (Literal (pos, _, _, _) l) = literalToValueIL pos l

133− valueToIL (Accessor _ prop val) =

134− accessorString prop <$> valueToIL val

135− valueToIL (ObjectUpdate _ o ps) = do

136− obj <- valueToIL o

137− updates <- mapM (sndM valueToIL) ps

138− obj' <- freshName'

139− let objVar = AST.Var Nothing obj'

140− copy = AST.VariableIntroduction Nothing obj' (Just $ copyDict obj)

141− assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v

142− sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]

143− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []

144− valueToIL (Abs _ arg val) = do

145− ret <- valueToIL val

146− let ilArg = case arg of

147− UnusedIdent -> []

148− _ -> [identToIL arg]

149− return $ AST.Function Nothing Nothing ilArg (AST.Block Nothing [AST.Return Nothing ret])

150− valueToIL e@App{} = do

151− let (f, args) = unApp e []

152− args' <- mapM valueToIL args

153− fn <- valueToIL f

154− case f of

155− Var (_, _, _, Just IsNewtype) _ -> return (head args')

156− _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToIL f

157− where

158− unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

159− unApp (App _ val arg) args = unApp val (arg : args)

160− unApp other args = (other, args)

161− valueToIL (Var _ ident) = return $ varToIL ident

162− valueToIL (Case (ss, _, _, _) values binders) = do

163− vals <- mapM valueToIL values

164− bindersToIL ss binders vals

165− valueToIL (Let _ ds val) = do

166− let recurs = concatMap getNames $ filter isRec ds

167− recurDs = (\v -> AST.VariableIntroduction Nothing (identToIL v) Nothing) <$> recurs

168− ds' <- concat <$> mapM (bindToIL LetDecl) ds

169− ret <- valueToIL val

170− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (recurDs ++ ds' ++ [AST.Return Nothing ret]))) []

171− where

172− isRec :: Bind Ann -> Bool

173− isRec (Rec _) = True

174− isRec _ = False

175− valueToIL (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"

176− valueToIL (Constructor _ _ (ProperName ctor) fields) =

177− let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :

178− ((\field -> (mkString (identToIL field), var field)) `map` fields)

179− fn = foldr (\f inner -> AST.Function Nothing Nothing [identToIL f] (AST.Block Nothing [AST.Return Nothing inner])) body fields

180− in return fn

181−

182−

183− iife :: Text -> [AST] -> AST

184− iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []

185−

186− literalToValueIL :: SourceSpan -> Literal (Expr Ann) -> m AST

187− literalToValueIL ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)

188− literalToValueIL ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)

189− literalToValueIL ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s

190− literalToValueIL ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])

191− literalToValueIL ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b

192− literalToValueIL ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToIL xs

193− literalToValueIL ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToIL) ps

194−

195− -- | Generate code in the simplified intermediate representation for a reference to a

196− -- variable.

197− varToIL :: Qualified Ident -> AST

198− varToIL (Qualified Nothing ident) = var ident

199− varToIL qual = qualifiedToIL id qual

200−

201− -- | Generate code in the simplified intermediate representation for a reference to a

202− -- variable that may have a qualified name.

203− qualifiedToIL :: (a -> Ident) -> Qualified a -> AST

204− qualifiedToIL f (Qualified (Just (ModuleName mn')) a) | mn' == C.prim = AST.Var Nothing . moduleIdentToIL $ f a

205− qualifiedToIL f (Qualified (Just mn') a) | mn /= mn' = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))

206− qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing "")

207−

208− -- foreignIdent :: Ident -> AST

209− -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")

210−

211− -- | Generate code in the simplified intermediate representation for pattern match binders

212− -- and guards.

213− bindersToIL :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST

214− bindersToIL ss binders vals = do

215− valNames <- replicateM (length vals) freshName'

216− let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)

217− ils <- forM binders $ \(CaseAlternative bs result) -> do

218− ret <- guardsToIL result

219− go valNames ret bs

220− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat ils ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))

221− []

222− where

223− go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]

224− go _ done [] = return done

225− go (v:vs) done' (b:bs) = do

226− done'' <- go vs done' bs

227− binderToIL v done'' b

228− go _ _ _ = internalError "Invalid arguments to bindersToIL"

229−

230− failedPatternMessage :: Text

231− failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss

232−

233− guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]

234− guardsToIL (Left gs) = traverse genGuard gs where

235− genGuard (cond, val) = do

236− cond' <- valueToIL cond

237− val' <- valueToIL val

238− return

239− (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))

240− (AST.Block Nothing [AST.Return Nothing val']) Nothing)

241−

242− guardsToIL (Right v) = return . AST.Return Nothing <$> valueToIL v

243−

244− -- | Generate code in the simplified intermediate representation for a pattern match

245− -- binder.

246− binderToIL :: Text -> [AST] -> Binder Ann -> m [AST]

247− binderToIL _ done NullBinder{} = return done

248− binderToIL varName done (LiteralBinder _ l) =

249− literalToBinderIL varName done l

250− binderToIL varName done (VarBinder _ ident) =

251− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : done)

252− binderToIL varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =

253− binderToIL varName done b

254− binderToIL varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do

255− il <- go (zip fields bs) done

256− return $ case ctorType of

257− ProductType -> il

258− SumType ->

259− [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))

260− (AST.Block Nothing il)

261− Nothing]

262− where

263− go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]

264− go [] done' = return done'

265− go ((field, binder) : remain) done' = do

266− argVar <- freshName'

267− done'' <- go remain done'

268− il <- binderToIL argVar done'' binder

269− return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToIL field) $ AST.Var Nothing varName) : il)

270−

271− binderToIL _ _ ConstructorBinder{} =

272− internalError "binderToIL: Invalid ConstructorBinder in binderToIL"

273− binderToIL varName done (NamedBinder _ ident binder) = do

274− il <- binderToIL varName done binder

275− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : il)

276−

277− literalToBinderIL :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]

278− literalToBinderIL varName done (NumericLiteral num) =

279− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]

280− literalToBinderIL varName done (CharLiteral c) =

281− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]

282− literalToBinderIL varName done (StringLiteral str) =

283− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]

284− literalToBinderIL varName done (BooleanLiteral True) =

285− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]

286− literalToBinderIL varName done (BooleanLiteral False) =

287− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]

288− -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]

289− literalToBinderIL varName done (ObjectLiteral bs) = go done bs

290− where

291− go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]

292− go done' [] = return done'

293− go done' ((prop, binder):bs') = do

294− propVar <- freshName'

295− done'' <- go done' bs'

296− il <- binderToIL propVar done'' binder

297− return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : il)

298− literalToBinderIL varName done (ArrayLiteral bs) = do

299− il <- go done 0 bs

300− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo

301− (arrayLength $ AST.Var Nothing varName)

302− (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))

303− (AST.Block Nothing il) Nothing]

304− where

305− go :: [AST] -> Integer -> [Binder Ann] -> m [AST]

306− go done' _ [] = return done'

307− go done' index (binder:bs') = do

308− elVar <- freshName'

309− done'' <- go done' (index + 1) bs'

310− il <- binderToIL elVar done'' binder

311− return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : il)

312−

313−emptyAnn :: Ann

314−emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)

315−

316−arrayLength :: AST -> AST

317−arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]

318−-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")

319−

320−copyDict :: AST -> AST

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

src/CodeGen/IL/Common.hsdeleted−196

@@ -1,196 +0,0 @@

1−-- | Common code generation utility functions

2−module CodeGen.IL.Common where

3−

4−import Prelude.Compat

5−

6−import Control.Monad.Supply.Class (MonadSupply, freshName)

7−import Data.Char

8−import Data.Maybe (maybe)

9−import Data.Monoid ((<>))

10−import Data.Text (Text)

11−import qualified Data.Text as T

12−

13−import Language.PureScript.Crash

14−import Language.PureScript.Names

15−

16−import qualified Language.PureScript.Constants as C

17−

18−moduleNameToIL :: ModuleName -> Text

19−moduleNameToIL (ModuleName mn) =

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

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

22−

23−moduleNameToIL' :: ModuleName -> Text

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

25−

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

27−--

28−-- * Alphanumeric characters are kept unmodified.

29−--

30−-- * Reserved IL identifiers are wrapped with '_'.

31−--

32−identToIL :: Ident -> Text

33−identToIL UnusedIdent = unusedName

34−identToIL (Ident "$__unused") = unusedName

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

36−identToIL (Ident name) = properToIL name

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

38−

39−moduleIdentToIL :: Ident -> Text

40−moduleIdentToIL UnusedIdent = unusedName

41−moduleIdentToIL (Ident name) | name == C.undefined = undefinedName

42−moduleIdentToIL (Ident name) = moduleProperToIL name

43−moduleIdentToIL (GenIdent _ _) = internalError "GenIdent in identToIL"

44−

45−undefinedName :: Text

46−undefinedName = "Undefined"

47−

48−unusedName :: Text

49−unusedName = "_"

50−

51−properToIL :: Text -> Text

52−properToIL name

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

54− | otherwise = T.concatMap identCharToText name

55−

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

57−-- ordinal value.

58−identCharToText :: Char -> Text

59−identCharToText 'ṩ' = "_ṩ"

60−identCharToText c | isAlphaNum c = T.singleton c

61−identCharToText '_' = "_"

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

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

64−

65−moduleProperToIL :: Text -> Text

66−moduleProperToIL = T.concatMap identCharToText

67−

68−-- | Checks whether an identifier name is reserved in IL.

69−nameIsILReserved :: Text -> Bool

70−nameIsILReserved name =

71− name `elem` ilAnyReserved

72−

73−-- | Checks whether a name matches a built-in value in IL.

74−nameIsILBuiltIn :: Text -> Bool

75−nameIsILBuiltIn name =

76− name `elem`

77− [ "Any"

78− , "Apply"

79− , "Contains"

80− , "CopyDict"

81− , "Dict"

82− , "EffFn"

83− , "Fn"

84− , "Foreign"

85− , "Get"

86− , "Index"

87− , "Is"

88− , "Length"

89− , "Once"

90− , "Run"

91− , "Undefined"

92− ]

93−

94−ilAnyReserved :: [Text]

95−ilAnyReserved =

96− concat

97− [ ilKeywords

98− , ilLiterals

99− ]

100−

101−ilKeywords :: [Text]

102−ilKeywords =

103− [ "break"

104− , "case"

105− , "chan"

106− , "const"

107− , "continue"

108− , "default"

109− , "defer"

110− , "else"

111− , "fallthrough"

112− , "for"

113− , "func"

114− , "go"

115− , "goto"

116− , "if"

117− , "import"

118− , "interface"

119− , "map"

120− , "package"

121− , "range"

122− , "return"

123− , "select"

124− , "struct"

125− , "switch"

126− , "type"

127− , "var"

128− ]

129−

130−ilLiterals :: [Text]

131−ilLiterals =

132− [ "init"

133− , "nil"

134− , "int"

135− , "int8"

136− , "int16"

137− , "int32"

138− , "int64"

139− , "uint"

140− , "uint8"

141− , "uint16"

142− , "uint32"

143− , "uint64"

144− , "uintptr"

145− , "float32"

146− , "float64"

147− , "complex64"

148− , "complex128"

149− , "byte"

150− , "rune"

151− , "string"

152− ]

153−

154−withPrefix :: Text -> Text

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

156−

157−anyType :: Text

158−anyType = "Any"

159−

160−dictType :: Text

161−dictType = "Dict"

162−

163−arrayType :: Text

164−arrayType = "[]" <> anyType

165−

166−uncurriedFnType :: Int -> Text

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

168−

169−int :: Text

170−int = "int"

171−

172−float :: Text

173−float = "float64"

174−

175−bool :: Text

176−bool = "bool"

177−

178−string :: Text

179−string = "string"

180−

181−arrayLengthFn :: Text

182−arrayLengthFn = "Length"

183−

184−indexFn :: Text

185−indexFn = "Index"

186−

187−copyDictFn :: Text

188−copyDictFn = "CopyDict"

189−

190−freshName' :: MonadSupply m => m Text

191−freshName' = do

192− name <- freshName

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

194−

195−moduleRenamerMarker :: Text

196−moduleRenamerMarker = "__"

src/CodeGen/IL/Optimizer.hsdeleted−81

@@ -1,81 +0,0 @@

1−-- | This module optimizes code in the intermediate representation.

2−module CodeGen.IL.Optimizer (optimize) where

3−

4−import Prelude.Compat

5−

6−import Control.Monad.Supply.Class (MonadSupply)

7−import Data.Text (Text)

8−import Language.PureScript.CoreImp.AST

9−import Language.PureScript.CoreImp.Optimizer.Blocks

10−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)

11−import Language.PureScript.CoreImp.Optimizer.Inliner (etaConvert, evaluateIifes, inlineVariables, unThunk)

12−import Language.PureScript.CoreImp.Optimizer.Unused

13−

14−import CodeGen.IL.Common (unusedName)

15−import CodeGen.IL.Optimizer.Inliner

16−import CodeGen.IL.Optimizer.MagicDo

17−import CodeGen.IL.Optimizer.TCO

18−

19−import qualified Language.PureScript.Constants as C

20−

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

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

23−optimize mn il = do

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

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

26− =<< untilFixedPoint (return . magicDoST)

27− =<< untilFixedPoint (return . magicDoEff)

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

29− untilFixedPoint (return . collapseVarDeclarations) il''

30− where

31− tidyUp :: AST -> AST

32− tidyUp = applyAll

33− [ collapseNestedBlocks

34− , collapseNestedIfs

35− , collapseIfChecks

36− , removeCodeAfterReturnStatements

37− , unThunk

38− , etaConvert

39− , evaluateIifes

40− , inlineVariables

41− ]

42−

43−untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a

44−untilFixedPoint f = go

45− where

46− go a = do

47− a' <- f a

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

49−

50−collapseIfChecks :: AST -> AST

51−collapseIfChecks = everywhere collapse where

52− collapse :: AST -> AST

53− collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs

54− collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)

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

56− collapse exprs = exprs

57−

58−collapseVarDeclarations :: AST -> AST

59−collapseVarDeclarations = everywhere collapse where

60− collapse :: AST -> AST

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

62− collapse s = s

63−

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

65− go _ [] = []

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

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

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

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

70−

71−ignoreUnusedResults :: AST -> AST

72−ignoreUnusedResults = everywhere $ removeFromBlock go

73− where

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

75− go [] = []

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

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

78− where

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

80− | otherwise = go sts

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

src/CodeGen/IL/Optimizer/Common.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/Printer.hsdeleted−527

@@ -1,527 +0,0 @@

1−-- | Pretty printer for the AST

2−module CodeGen.IL.Printer

3− ( prettyPrintIL

4− , prettyPrintIL1

5− , prettyPrintILWithSourceMaps

6− , interfaceSource

7− , implHeaderSource

8− , implFooterSource

9− , isLiteral

10− , modLabel

11− , modPrefix

12− , ffiLoader

13− ) where

14−

15−import Prelude.Compat

16−

17−import Control.Arrow ((<+>))

18−import Control.Monad (forM, mzero)

19−import Control.Monad.State (StateT, evalStateT)

20−import Control.PatternArrows

21−import Data.List (filter, (\\))

22−import qualified Control.Arrow as A

23−

24−import Data.Maybe (fromMaybe)

25−import Data.Monoid ((<>))

26−import Data.Text (Text)

27−import qualified Data.Text as T

28−

29−import Language.PureScript.AST (SourceSpan(..))

30−import Language.PureScript.CoreImp.AST

31−import Language.PureScript.Comments

32−import Language.PureScript.Crash

33−import Language.PureScript.Names (Ident, runIdent)

34−import Language.PureScript.Pretty.Common

35−import Language.PureScript.PSString (PSString, decodeString, mkString)

36−

37−import CodeGen.IL.Common

38−import CodeGen.IL.Optimizer.TCO (tcoLoop)

39−

40−import qualified Language.PureScript.Constants as C

41−

42−-- TODO (Christoph): Get rid of T.unpack / pack

43−

44−literals :: (Emit gen) => Pattern PrinterState AST gen

45−literals = mkPattern' match'

46− where

47− match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen

48− match' il = (addMapping' (getSourceSpan il) <>) <$> match il

49−

50− match :: (Emit gen) => AST -> StateT PrinterState Maybe gen

51− match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n

52− match (StringLiteral _ s) = return $ emit $ stringLiteral s

53− match (BooleanLiteral _ True) = return $ emit "true"

54− match (BooleanLiteral _ False) = return $ emit "false"

55− match (ArrayLiteral _ xs) = mconcat <$> sequence

56− [ return . emit $ arrayType <> "{"

57− , intercalate (emit ", ") <$> forM xs prettyPrintIL'

58− , return $ emit "}"

59− ]

60− -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"

61− match (ObjectLiteral _ ps) = mconcat <$> sequence

62− [ return . emit $ dictType <> "{"

63− , withIndent $ do

64− ils <- forM ps $ \(key, value) -> do

65− value' <- prettyPrintIL' value

66− return $ objectPropertyToString key <> value'

67− return $ intercalate (emit " ") $ map (<> emit ",") ils

68− , return $ emit "}"

69− ]

70− where

71− objectPropertyToString :: (Emit gen) => PSString -> gen

72− objectPropertyToString s = emit $ stringLiteral s <> ": "

73− match (Block _ sts) = mconcat <$> sequence

74− [ return $ emit "{\n"

75− , withIndent $ prettyStatements sts

76− , return $ emit "\n"

77− , currentIndent

78− , return $ emit "}"

79− ]

80− match (Var _ ident) | ident == C.undefined = return $ emit undefinedName

81− match (Var _ ident) = return $ emit ident

82− match (VariableIntroduction _ ident value) = mconcat <$> sequence

83− [ return . emit $ varDecl <> " " <> ident <> " " <> anyType

84− , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintIL') value

85− ]

86− match (Assignment _ target value) = mconcat <$> sequence

87− [ prettyPrintIL' target

88− , return $ emit " = "

89− , prettyPrintIL' value

90− ]

91− match (App _ val []) = mconcat <$> sequence

92− [ return $ emit "Run("

93− , prettyPrintIL' val

94− , return $ emit ")"

95− ]

96− match (App _ (StringLiteral _ u) [arg])

97− | Just ty <- decodeString u = mconcat <$> sequence

98− [ prettyPrintIL' arg

99− , return $ emit ".("

100− , return $ emit ty

101− , return $ emit ")"

102− ]

103− match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence

104− [ return $ emit fn

105− , return $ emit "("

106− , prettyPrintIL' arg

107− , return $ emit ")"

108− ]

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

110− [ return $ emit fn

111− , return $ emit "("

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

113− , return $ emit ")"

114− ]

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

116− [ return $ emit fn

117− , return $ emit "("

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

119− , return $ emit ")"

120− ]

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

122− | Just ftype <- decodeString fnx

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

124− [ prettyPrintIL' fn

125− , return $ emit "("

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

127− , return $ emit ")"

128− ]

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

130− | Just ftype <- decodeString fnx

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

132− [ prettyPrintIL' fn

133− , return $ emit ".("

134− , return $ emit ftype

135− , return $ emit ")("

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

137− , return $ emit ")"

138− ]

139− match app@(App{})

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

141− , length args > 1

142− = mconcat <$> sequence

143− [ return $ emit "Apply("

144− , prettyPrintIL' val

145− , return $ emit ", "

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

147− , return $ emit ")"

148− ]

149− match (App _ val args) = mconcat <$> sequence

150− [ return $ emit "Apply("

151− , prettyPrintIL' val

152− , return $ emit ", "

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

154− , return $ emit ")"

155− ]

156− match (Function _ (Just name) [] (Block _ [Return _ ret]))

157− | isComplexLiteral ret = mconcat <$> sequence

158− [ return $ emit "\n"

159− , return . emit $ varDecl <> " " <> initName name <> " Once\n"

160− , prettyPrintIL' $ VariableIntroduction Nothing (valueName name) Nothing

161− , return $ emit "\n\n"

162− , return $ emit "func "

163− , return . emit $ withPrefix name

164− , return . emit $ "() " <> anyType <> " "

165− , return $ emit "{\n"

166− , withIndent $ do

167− indentString <- currentIndent

168− return $ indentString <> (emit $ initName name <> ".Do(func() {\n") <>

169− indentString <> indentString <> (emit $ valueName name <> " = ")

170− , withIndent $ do

171− case ret of

172− Function _ Nothing args body -> mconcat <$> sequence

173− [ return $ emit "func("

174− , return . emit $ intercalate ", " (renderArg anyType <$> args)

175− , return . emit $ ") " <> anyType <> " "

176− , prettyPrintIL' body

177− ]

178− _ -> do

179− prettyPrintIL' ret

180− , return $ emit "\n"

181− , withIndent $ do

182− indentString <- currentIndent

183− return $ indentString <> (emit $ "})\n" <> "return " <> valueName name <>"\n")

184− , return $ emit "}\n\n"

185− ]

186− match (Function _ (Just name) [] ret) = mconcat <$> sequence

187− [ return $ emit "func "

188− , return . emit $ withPrefix name

189− , return . emit $ "() " <> anyType <> " "

190− , prettyPrintIL' ret

191− ]

192− match (Function _ _ args ret) = mconcat <$> sequence

193− [ return $ emit "func("

194− , return . emit $ intercalate ", " (renderArg anyType <$> args)

195− , return . emit $ ") " <> anyType <> " "

196− , prettyPrintIL' ret

197− ]

198− match (Indexer _ (Var _ name) (Var _ "")) = mconcat <$> sequence

199− [ prettyPrintIL' (Var Nothing $ withPrefix name)

200− , return $ emit "()"

201− ]

202− match (Indexer _ (Var _ name) val) = mconcat <$> sequence

203− [ prettyPrintIL' val

204− , return $ emit "."

205− , prettyPrintIL' (Var Nothing $ withPrefix name)

206− , return $ emit "()"

207− ]

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

209− [ prettyPrintIL' val

210− , return $ emit "["

211− , prettyPrintIL' prop

212− , return $ emit "]"

213− ]

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

215− [ prettyPrintIL' val

216− , return $ emit ".("

217− , return $ emit dictType

218− , return $ emit ")["

219− , prettyPrintIL' prop

220− , return $ emit "]"

221− ]

222− match (Indexer _ index val@ArrayLiteral{}) = mconcat <$> sequence

223− [ prettyPrintIL' val

224− , return $ emit "["

225− , prettyPrintIL' index

226− , return $ emit "]"

227− ]

228− match (Indexer _ index val) = mconcat <$> sequence

229− [ prettyPrintIL' val

230− , return $ emit ".("

231− , return $ emit arrayType

232− , return $ emit ")["

233− , prettyPrintIL' index

234− , return $ emit "]"

235− ]

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

237− [ return $ emit "Is("

238− , prettyPrintIL' val

239− , return $ emit ", "

240− , prettyPrintIL' ty

241− , return $ emit ")"

242− ]

243− match (While _ cond sts) = mconcat <$> sequence

244− [ return $ emit "for "

245− , prettyPrintIL' cond

246− , return $ emit " "

247− , prettyPrintIL' sts

248− ]

249− match (For _ ident start end sts) = mconcat <$> sequence

250− [ return $ emit $ "for var " <> ident <> " = "

251− , prettyPrintIL' start

252− , return $ emit $ "; " <> ident <> " < "

253− , prettyPrintIL' end

254− , return $ emit $ "; " <> ident <> "++ "

255− , prettyPrintIL' sts

256− ]

257− match (ForIn _ ident obj sts) = mconcat <$> sequence

258− [ return $ emit $ "for var " <> ident <> " in "

259− , prettyPrintIL' obj

260− , return $ emit " "

261− , prettyPrintIL' sts

262− ]

263− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence

264− [ return $ emit "if "

265− , prettyPrintIL' cond

266− , return $ emit " "

267− , prettyPrintIL' thens

268− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

269− ]

270− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence

271− [ return $ emit "if !("

272− , prettyPrintIL' cond

273− , return $ emit ") "

274− , prettyPrintIL' thens

275− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

276− ]

277− match (IfElse _ cond thens elses) = mconcat <$> sequence

278− [ return $ emit "if "

279− , prettyPrintIL' cond

280− , return $ emit " "

281− , prettyPrintIL' thens

282− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

283− ]

284− match (Return _ value) = mconcat <$> sequence

285− [ return $ emit "return "

286− , prettyPrintIL' value

287− ]

288− match (ReturnNoResult _) = return . emit $ "return " <> undefinedName

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

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

291− [ return $ emit "panic("

292− , prettyPrintIL' value

293− , return $ emit ")"

294− ]

295− match (Comment _ com il) = mconcat <$> sequence

296− [ return $ emit "\n"

297− , mconcat <$> forM com comment

298− , prettyPrintIL' il

299− ]

300− match _ = mzero

301−

302− comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen

303− comment (LineComment com) = fmap mconcat $ sequence $

304− [ currentIndent

305− , return $ emit "//" <> emit com <> emit "\n"

306− ]

307− comment (BlockComment com) = fmap mconcat $ sequence $

308− [ currentIndent

309− , return $ emit "/**\n"

310− ] ++

311− map asLine (T.lines com) ++

312− [ currentIndent

313− , return $ emit " */\n"

314− , currentIndent

315− ]

316− where

317− asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen

318− asLine s = do

319− i <- currentIndent

320− return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"

321−

322− removeComments :: Text -> Text

323− removeComments t =

324− case T.stripPrefix "*/" t of

325− Just rest -> removeComments rest

326− Nothing -> case T.uncons t of

327− Just (x, xs) -> x `T.cons` removeComments xs

328− Nothing -> ""

329−

330−unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen

331−unary' op mkStr = Wrap match (<>)

332− where

333− match :: (Emit gen) => Pattern PrinterState AST (gen, AST)

334− match = mkPattern match'

335− where

336− match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)

337− match' _ = Nothing

338−

339−unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen

340−unary op str = unary' op (const str)

341−

342−negateOperator :: (Emit gen) => Operator PrinterState AST gen

343−negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")

344− where

345− isNegate (Unary _ Negate _) = True

346− isNegate _ = False

347−

348−binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen

349−binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)

350− where

351− match :: Pattern PrinterState AST (AST, AST)

352− match = mkPattern match'

353− where

354− match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)

355− match' _ = Nothing

356−

357−isLiteral :: AST -> Bool

358−isLiteral Function{} = True

359−isLiteral NumericLiteral{} = True

360−isLiteral StringLiteral{} = True

361−isLiteral BooleanLiteral{} = True

362−isLiteral ObjectLiteral{} = True

363−isLiteral ArrayLiteral{} = True

364−isLiteral _ = False

365−

366−isComplexLiteral :: AST -> Bool

367−-- isComplexLiteral Function{} = True

368−isComplexLiteral ObjectLiteral{} = True

369−isComplexLiteral ArrayLiteral{} = True

370−isComplexLiteral _ = False

371−

372−unApp :: AST -> [AST] -> (AST, [AST])

373−unApp (App _ val [arg]) args = unApp val (arg : args)

374−unApp other args = (other, args)

375−

376−prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen

377−prettyStatements sts = do

378− ils <- forM sts prettyPrintIL'

379− indentString <- currentIndent

380− return $ intercalate (emit "\n") $ map (indentString <>) ils

381−

382−-- | Generate a pretty-printed string representing a collection of C++ expressions at the same indentation level

383−prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])

384−prettyPrintILWithSourceMaps il =

385− let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) il

386− in (s, mp)

387−

388−prettyPrintIL :: [AST] -> Text

389−prettyPrintIL = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements

390−

391−-- | Generate an indented, pretty-printed string representing a C++ expression

392−prettyPrintIL' :: (Emit gen) => AST -> StateT PrinterState Maybe gen

393−prettyPrintIL' = A.runKleisli $ runPattern matchValue

394− where

395− matchValue :: (Emit gen) => Pattern PrinterState AST gen

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

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

398− operators =

399− OperatorTable [ [ unary New "?" ]

400− , [ unary Not "!"

401− , unary BitwiseNot "~"

402− , unary Positive "+"

403− , negateOperator ]

404− , [ binary Multiply "*"

405− , binary Divide "/"

406− , binary Modulus "%" ]

407− , [ binary Add "+"

408− , binary Subtract "-" ]

409− , [ binary ShiftLeft "<<"

410− , binary ShiftRight ">>" ]

411− , [ binary LessThan "<"

412− , binary LessThanOrEqualTo "<="

413− , binary GreaterThan ">"

414− , binary GreaterThanOrEqualTo ">=" ]

415− , [ binary EqualTo "=="

416− , binary NotEqualTo "!=" ]

417− , [ binary BitwiseAnd "&" ]

418− , [ binary BitwiseXor "^" ]

419− , [ binary BitwiseOr "|" ]

420− , [ binary And "&&" ]

421− , [ binary Or "||" ]

422− ]

423−

424−prettyPrintIL1 :: AST -> Text

425−prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'

426−

427−stringLiteral :: PSString -> Text

428−stringLiteral pss | Just s <- decodeString pss = stringLiteral' s

429− where

430− stringLiteral' :: Text -> Text

431− stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""

432− encodeChar :: Char -> Text

433− encodeChar '\0' = "\\x00"

434− encodeChar '\b' = "\\b"

435− encodeChar '\t' = "\\t"

436− encodeChar '\n' = "\\n"

437− encodeChar '\v' = "\\v"

438− encodeChar '\f' = "\\f"

439− encodeChar '\r' = "\\r"

440− encodeChar '"' = "\\\""

441− encodeChar '\\' = "\\\\"

442− encodeChar c = T.singleton $ c

443−stringLiteral _ = "\"\\uFFFD\""

444−

445−interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text

446−interfaceSource _ _ _ = ""

447−

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

449−implHeaderSource mn imports otherPrefix =

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

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

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

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

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

455− else "\n") <>

456− "import (\n" <>

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

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

459− where

460− formatImport :: Text -> Text

461− formatImport s =

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

463− moduleRenamer :: Text -> Text

464− moduleRenamer s

465− | (s', sfx) <- T.breakOn moduleRenamerMarker s,

466− not $ T.null sfx = s'

467− moduleRenamer s = s

468−

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

470−implFooterSource mn foreigns =

471− "\n\n\n" <>

472− (if null foreigns

473− then ""

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

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

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

477− let name = moduleIdentToIL foreign' in

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

479− varDecl <> " " <> valueName name <> " " <> anyType <> "\n\n" <>

480− "func " <>

481− withPrefix name <>

482− "() Any { \n" <>

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

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

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

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

487− " })\n" <>

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

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

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

491− where

492− mainSource :: Text

493− mainSource = "\

494− \func main() {\n\

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

496− \}\n\n\

497− \"

498−

499−varDecl :: Text

500−varDecl = "var"

501−

502−renderArg :: Text -> Text -> Text

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

504−

505−foreignMod :: Text

506−foreignMod = "Foreign"

507−

508−foreignDict :: Text

509−foreignDict = "foreign"

510−

511−modLabel :: Text

512−modLabel = "purescript-native"

513−

514−modPrefix :: Text

515−modPrefix = modLabel <> "/output"

516−

517−runtime :: Text

518−runtime = "github.com/" <> modLabel <> "/go-runtime"

519−

520−ffiLoader :: Text

521−ffiLoader = modLabel <> "/ffi-loader"

522−

523−initName :: Text -> Text

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

525−

526−valueName :: Text -> Text

527−valueName s = "ᛧ" <> s

src/Tests.hs+12−11

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

31 let srcDir = outputDir </> "src"

32 createDirectory srcDir

34− callProcess "git" ["clone", "--branch", "v0.13.8", "--depth", "1", "https://github.com/purescript/purescript.git"]

34+ callProcess "git" ["clone", "--branch", "v0.12.1", "--depth", "1", "https://github.com/purescript/purescript.git"]

35 let passingDir = baseDir </> "purescript" </> "tests" </> "purs" </> "passing"

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

38 setCurrentDirectory outputDir

39+ callProcess "pscpp" ["--makefile"]

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.12.1/prelude/v4.1.0"]

45+ callProcess "git" ["clone", "--depth", "1", "https://github.com/andyarvanitis/purescript-prelude.git", ".psc-package/psc-0.12.1/prelude/v4.1.0"]

42 let tests = filter (`notElem` skipped) passingTestCases

47 let tests = filter (`notElem` skipped) passingTestCases

@@ -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]

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

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.nixdeleted−23

@@ -1,23 +0,0 @@

1−#

2−# You may need to manually run `unset STACK_IN_NIX_SHELL`

3−# (doesn't work from a `shellHook`; see: https://github.com/commercialhaskell/stack/issues/5000

4−#

5−#

6−# You may need to set LC_ALL when building, e.g.

7−# LC_ALL=en_US.iso88591 stack --nix build; see e.g. https://github.com/koalaman/shellcheck/issues/324

8−#

9−#

10−{ pkgs ?

11− import (builtins.fetchTarball {

12− name = "nixos-release-19.03";

13− url = https://github.com/nixos/nixpkgs/archive/34c7eb7545d155cc5b6f499b23a7cb1c96ab4d59.tar.gz;

14− sha256 = "11z6ajj108fy2q5g8y4higlcaqncrbjm3dnv17pvif6avagw4mcb";

15− }) {}

16−}:

17−

18−pkgs.haskell.lib.buildStackProject {

19− name = "default-stack-shell";

20− ghc = pkgs.haskell.compiler.ghc865;

21− buildInputs = with pkgs; [git git-lfs gmp ncurses zlib];

22− LANG = "en_US.UTF-8";

23−}

stack.yaml+63−18

@@ -1,24 +1,69 @@

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/

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

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: v0.12.0

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

15−nix:

50+# Extra package databases containing global packages

16− enable: false

51+# extra-package-dbs: []

17− shell-file: stack.nix

19−flags:

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

20− aeson-pretty:

54+# system-ghc: true

21− lib-only: true

55+#

22− these:

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

23− assoc: false

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

24− quickcheck: false

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

support/Makefilenew file+118

@@ -0,0 +1,118 @@

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+debug: codegen

47+ @$(MAKE) $(BIN) CFLAGS+=$(DEBUG) CXXFLAGS+=$(DEBUG)

48+

49+release: codegen

50+ @$(MAKE) $(BIN) CFLAGS+=$(RELEASE) CXXFLAGS+=$(RELEASE)

51+

52+.PHONY: corefn

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

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

55+corefn: $(PURESCRIPT_PKGS)

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

57+

58+.PHONY: codegen

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

60+codegen: corefn

61+ @$(PSCPP) $(PSCPPFLAGS) $(COREFN_SRCS)

62+

63+$(PURESCRIPT_PKGS):

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

65+ @$(PSC_PACKAGE) update

66+

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

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

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

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

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

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

73+

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

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

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

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

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

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

80+

81+$(BIN): $(OBJS)

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

83+ @mkdir -p $(BIN_DIR)

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

85+

86+-include $(DEPS)

87+

88+%.o: %.cpp

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

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

91+

92+%.o: %.cc

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

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

95+

96+%.o: %.mm

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

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

99+

100+%.o: %.c

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

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

103+

104+%.o: %.m

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

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

107+

108+.PHONY: all

109+all: release

110+

111+.PHONY: clean

112+clean:

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

114+ @-rm -rf $(OUTPUT)

115+

116+.PHONY: run

117+run:

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