9d25c0e · rowtype-yoga/purescript-native

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

on golang help sign in

Initial impl; only very basic testing done

9d25c0eAndy Arvanitis7 years ago

app/Main.hs+2−2

compare with golang

unifiedsplit

@@ -107,8 +107,8 @@ transpile opts baseOutpath jsonFile = do

107

108writeRuntimeFiles :: FilePath -> IO ()

109writeRuntimeFiles baseOutpath = do

110− createDirectoryIfMissing True baseOutpath

110+ createDirectoryIfMissing True $ baseOutpath </> "purescript"

111− let runtimeSource = baseOutpath </> "purescript.go"

111+ let runtimeSource = baseOutpath </> "purescript" </> "purescript.go"

112 runtimeExists <- doesFileExist runtimeSource

113 when (not runtimeExists) $ do

114 B.writeFile runtimeSource $(embedFile "runtime/purescript.go")

runtime/purescript.go+35−3

@@ -2,11 +2,19 @@ package purescript

3//go:generate purs --version

5+import "sync"

5−type Any = interface{}

7+type Any interface{}

7type Fn = func(Any) Any

9type Fn = func(Any) Any

8type EffFn = func() Any

10type EffFn = func() Any

12+type Once = sync.Once

13+

14+type IGNORE_UNUSED_RUNTIME = bool

15+

16+const Undefined = false

17+

10func Apply(f Any, args ...Any) Any {

18func Apply(f Any, args ...Any) Any {

11 result := f

19 result := f

12 for _, arg := range args {

20 for _, arg := range args {

@@ -16,7 +24,31 @@ func Apply(f Any, args ...Any) Any {

16 return result

24 return result

17}

25}

27+func EffApply(f Any, args ...Any) Any {

28+ fn, _ := f.(EffFn)

29+ return fn()

30+}

31+

19func Get(dict Any, key string) Any {

32func Get(dict Any, key string) Any {

33+ d, _ := dict.(map[string]Any)

34+ return d[key]

35+}

36+

20− d, _ := dict.(func(string) Any)

37+func SafeGet(dict map[string]Any, key string) Any {

38+ value, ok := dict[key]

39+ if !ok {

40+ panic("Foreign value '" + key + "' not defined")

41+ }

21− return d(key)

42+ return value

43+}

44+

45+func Contains(dict Any, key string) bool {

46+ d, _ := dict.(map[string]Any)

47+ _, found := d[key]

48+ return found

49+}

50+

51+func Length(arr Any) Any {

52+ a, _ := arr.([]Any)

53+ return len(a)

22}

54}

src/CodeGen/IL.hs+28−68

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

40import CodeGen.IL.Printer

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

43+data ImportType = Imported | Ignored

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

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

45-- module.

46-- module.

@@ -54,8 +55,9 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =

54 do

55 do

55 let usedNames = concatMap getNames decls

56 let usedNames = concatMap getNames decls

56 let mnLookup = renameImports usedNames imps

57 let mnLookup = renameImports usedNames imps

57− ilImports <- traverse (importToIL mnLookup) . (\\ (mn : C.primModules)) . (\\ [mn]) $ ordNub $ map snd imps

58+ imports <- traverse (importToIL Imported mnLookup) . (\\ (mn : C.primModules)) . (\\ [mn]) $ ordNub $ map snd imps

59+ ignoredImports <- traverse (importToIL Ignored mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ (mn : C.primModules)) $ ordNub $ map snd imps

58− interfaceImport <- importToIL (renameImports [] [(emptyAnn, mn)]) mn

60+ interfaceImport <- importToIL Imported (renameImports [] [(emptyAnn, mn)]) mn

59 let decls' = renameModules mnLookup decls

61 let decls' = renameModules mnLookup decls

60 ilDecls <- mapM (bindToIL ModuleDecl) decls'

62 ilDecls <- mapM (bindToIL ModuleDecl) decls'

61 optimized <- traverse (traverse (optimize modName')) ilDecls

63 optimized <- traverse (traverse (optimize modName')) ilDecls

@@ -63,7 +65,7 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =

63 values = annotValue <$> optimized'

65 values = annotValue <$> optimized'

64 foreigns' = identToIL <$> foreigns

66 foreigns' = identToIL <$> foreigns

65 interface = interfaceSource modName values foreigns

67 interface = interfaceSource modName values foreigns

66− implHeader = implHeaderSource modName ilImports interfaceImport

68+ implHeader = implHeaderSource modName (imports ++ ignoredImports) interfaceImport

67 implFooter = implFooterSource modName foreigns

69 implFooter = implFooterSource modName foreigns

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

70 return $ (interface, foreigns', optimized', implHeader, implFooter)

69 where

71 where

@@ -102,24 +104,26 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =

102 then freshModuleName (i + 1) mn' used

104 then freshModuleName (i + 1) mn' used

103 else newName

105 else newName

104

106

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

107+ -- | Generates IL code for a module import, binding the required module

106 -- to the alternative

108 -- to the alternative

107− importToIL :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m Text

109+ importToIL :: ImportType -> M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m Text

108− importToIL mnLookup mn' = do

110+ importToIL t mnLookup mn' = do

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

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

110 mname = moduleNameToIL mnSafe

112 mname = moduleNameToIL mnSafe

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

113+ pure $ case t of

114+ Imported -> "import \"" <> mname <> "\"\n"

115+ Ignored -> "type _ = " <> mname <> ".IGNORE_UNUSED_IMPORTS\n"

112

116

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

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

114 -- the collision-avoiding renamed module imports.

118 -- the collision-avoiding renamed module imports.

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

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

116 renameModules mnLookup binds =

120 renameModules mnLookup binds =

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

121+ let (f, _, _) = everywhereOnValues id ilExpr goBinder

118 in map f binds

122 in map f binds

119 where

123 where

120− goExpr :: Expr a -> Expr a

124+ ilExpr :: Expr a -> Expr a

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

125+ ilExpr (Var ann q) = Var ann (renameQual q)

122− goExpr e = e

126+ ilExpr e = e

123 goBinder :: Binder a -> Binder a

127 goBinder :: Binder a -> Binder a

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

128 goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs

125 goBinder b = b

129 goBinder b = b

@@ -153,39 +157,8 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =

153 il <- valueToIL val

157 il <- valueToIL val

154 pure $ AST.Function Nothing (Just $ identToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])

158 pure $ AST.Function Nothing (Just $ identToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])

155 nonRecToIL RecLetDecl (ss, _, _, _) ident val = do

159 nonRecToIL RecLetDecl (ss, _, _, _) ident val = do

156− il <- valueToIL val

160+ ilExpr <- valueToIL val

157− pure $

161+ pure $ AST.Assignment Nothing (AST.Var Nothing $ identToIL ident) ilExpr

158− let retainedName = identToIL 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− prettyPrintIL1 $

164− AST.VariableIntroduction

165− Nothing

166− retainedName

167− (Just unretained)

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

169− in

170− case il of

171− AST.Function _ name args (AST.Block Nothing ils) ->

172− AST.Assignment Nothing

173− retained

174− (AST.Function Nothing

175− name

176− args

177− (AST.Block Nothing (boxed : ils)))

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 il

187− ])))

188− [])

189 nonRecToIL _ (ss, _, _, _) ident val = do

162 nonRecToIL _ (ss, _, _, _) ident val = do

190 il <- valueToIL val

163 il <- valueToIL val

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

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

@@ -222,9 +195,11 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =

222 valueToIL e@App{} = do

195 valueToIL e@App{} = do

223 let (f, args) = unApp e []

196 let (f, args) = unApp e []

224 args' <- mapM valueToIL args

197 args' <- mapM valueToIL args

198+ fn <- valueToIL f

225 case f of

199 case f of

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

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

201+ _ -> return $ AST.App Nothing fn args'

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

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

228 where

203 where

229 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

204 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

230 unApp (App _ val arg) args = unApp val (arg : args)

205 unApp (App _ val arg) args = unApp val (arg : args)

@@ -247,30 +222,14 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =

247 bindersToIL ss binders vals

222 bindersToIL ss binders vals

248 valueToIL (Let _ ds val) = do

223 valueToIL (Let _ ds val) = do

249 let recurs = concatMap getNames $ filter isRec ds

224 let recurs = concatMap getNames $ filter isRec ds

250− recurDs = (\v -> AST.Var Nothing $ "boxed::recur " <> identToIL v) <$> recurs

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

251− recurDsWeak = (\v -> AST.Var

252− Nothing

253− ("boxed::recur::weak " <> identToIL v <> unretainedSuffix <> "(" <> identToIL v <> ")")

254− ) <$> recurs

255− mutualRecurWarning = if any isMutRec $ filter isRec ds

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

257− else []

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

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

259 ret <- valueToIL val

227 ret <- valueToIL val

260− return $

261− AST.App Nothing

262− (AST.Function Nothing

263− Nothing

264− []

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

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

266− []

267 where

229 where

268 isRec :: Bind Ann -> Bool

230 isRec :: Bind Ann -> Bool

269 isRec (Rec _) = True

231 isRec (Rec _) = True

270− isRec _ = False

232+ isRec _ = False

271− isMutRec :: Bind Ann -> Bool

272− isMutRec b | (length . nub $ getNames b) > 1 = True

273− | otherwise = False

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

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

275 valueToIL (Constructor _ _ (ProperName ctor) fields) =

234 valueToIL (Constructor _ _ (ProperName ctor) fields) =

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

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

@@ -300,9 +259,9 @@ moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =

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

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

301 -- variable that may have a qualified name.

260 -- variable that may have a qualified name.

302 qualifiedToIL :: (a -> Ident) -> Qualified a -> AST

261 qualifiedToIL :: (a -> Ident) -> Qualified a -> AST

303− qualifiedToIL f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = AST.Var Nothing . runIdent $ f a

262+ qualifiedToIL f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = AST.Var Nothing . identToIL $ f a

304− qualifiedToIL f (Qualified (Just mn') a) = AST.Indexer Nothing (AST.Var Nothing . identToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))

263+ qualifiedToIL f (Qualified (Just mn') a) | mn /= mn' = AST.Indexer Nothing (AST.Var Nothing . identToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))

305− qualifiedToIL f (Qualified _ a) = AST.Var Nothing $ identToIL (f a)

264+ qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . identToIL $ f a) (AST.Var Nothing "")

306

265

307 -- foreignIdent :: Ident -> AST

266 -- foreignIdent :: Ident -> AST

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

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

@@ -414,8 +373,9 @@ emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)

414

373

415arrayLength :: AST -> AST

374arrayLength :: AST -> AST

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

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

376+-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")

417

377

418freshName' :: MonadSupply m => m Text

378freshName' :: MonadSupply m => m Text

419freshName' = do

379freshName' = do

420 name <- freshName

380 name <- freshName

421− return $ T.replace "$" "_Local_" name

381+ return $ T.replace "$" "𝕡" name

src/CodeGen/IL/Common.hs+58−117

@@ -11,57 +11,56 @@ import qualified Data.Text as T

11import Language.PureScript.Crash

12import Language.PureScript.Names

14+import qualified Language.PureScript.Constants as C

15+

14moduleNameToIL :: ModuleName -> Text

16moduleNameToIL :: ModuleName -> Text

15moduleNameToIL (ModuleName pns) =

17moduleNameToIL (ModuleName pns) =

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

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

17 in if nameIsILBuiltIn name then ("_" <> name <> "_") else name

19 in if nameIsILBuiltIn name then ("_" <> name <> "_") else name

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

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

20--

22--

21-- * Alphanumeric characters are kept unmodified.

23-- * Alphanumeric characters are kept unmodified.

22--

24--

23−-- * Reserved C++ identifiers are wrapped with '_'.

25+-- * Reserved IL identifiers are wrapped with '_'.

24--

26--

25identToIL :: Ident -> Text

27identToIL :: Ident -> Text

26identToIL UnusedIdent = unusedName

28identToIL UnusedIdent = unusedName

27identToIL (Ident "$__unused") = unusedName

29identToIL (Ident "$__unused") = unusedName

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

28identToIL (Ident name) = properToIL name

31identToIL (Ident name) = properToIL name

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

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

34+undefinedName :: Text

35+undefinedName = "Undefined"

36+

31unusedName :: Text

37unusedName :: Text

32−unusedName = "_Unused_"

38+unusedName = "_"

34properToIL :: Text -> Text

40properToIL :: Text -> Text

35properToIL name

41properToIL name

36 | nameIsILReserved name || nameIsILBuiltIn name || prefixIsReserved name = "_" <> name <> "_"

42 | nameIsILReserved name || nameIsILBuiltIn name || prefixIsReserved name = "_" <> name <> "_"

37 | otherwise = T.concatMap identCharToText name

43 | otherwise = T.concatMap identCharToText name

39−-- | Test if a string is a valid AST identifier without escaping.

40−identNeedsEscaping :: Text -> Bool

41−identNeedsEscaping s = s /= properToIL s || T.null s

42−

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

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

44-- ordinal value.

46-- ordinal value.

45identCharToText :: Char -> Text

47identCharToText :: Char -> Text

46identCharToText c | isAlphaNum c = T.singleton c

48identCharToText c | isAlphaNum c = T.singleton c

47identCharToText '_' = "_"

49identCharToText '_' = "_"

48identCharToText '\'' = "_Prime_"

50identCharToText '\'' = "_Prime_"

49−identCharToText '$' = "$"

51+-- identCharToText '$' = "𝕤"

50−identCharToText c = "_Code_Point_" <> T.pack (show (ord c))

52+identCharToText c = "𝕦" <> T.pack (show (ord c))

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

54+-- | Checks whether an identifier name is reserved in IL.

53nameIsILReserved :: Text -> Bool

55nameIsILReserved :: Text -> Bool

54nameIsILReserved name =

56nameIsILReserved name =

55 name `elem` ilAnyReserved

57 name `elem` ilAnyReserved

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

59+-- | Checks whether a name matches a built-in value in IL.

58nameIsILBuiltIn :: Text -> Bool

60nameIsILBuiltIn :: Text -> Bool

59nameIsILBuiltIn name =

61nameIsILBuiltIn name =

60 name `elem`

62 name `elem`

61− [ "final"

63+ [

62− , "override"

63− , "posix"

64− , "std"

65 ]

64 ]

67ilAnyReserved :: [Text]

66ilAnyReserved :: [Text]

@@ -73,135 +72,80 @@ ilAnyReserved =

74ilKeywords :: [Text]

73ilKeywords :: [Text]

75ilKeywords =

74ilKeywords =

76− [ "alignas"

77− , "alignof"

78− , "and"

79− , "and_eq"

80− , "asm"

81− , "assert"

82− , "atomic_cancel"

83− , "atomic_commit"

84− , "atomic_noexcept"

85− , "auto"

86− , "bitand"

87− , "bitor"

88− , "bool"

89− , "break"

75+ [ "break"

90 , "case"

76 , "case"

91− , "catch"

77+ , "chan"

92− , "char"

93− , "char16_t"

94− , "char32_t"

95− , "class"

96− , "compl"

97− , "concept"

98 , "const"

78 , "const"

99− , "constexpr"

100− , "const_cast"

101 , "continue"

79 , "continue"

102− , "concept"

103− , "decltype"

104 , "default"

80 , "default"

105− , "delete"

81+ , "defer"

106− , "do"

107− , "double"

108− , "dynamic_cast"

109 , "else"

82 , "else"

110− , "enum"

83+ , "fallthrough"

111− , "explicit"

112− , "export"

113− , "extern"

114− , "false"

115− , "float"

116 , "for"

84 , "for"

117− , "friend"

85+ , "func"

86+ , "go"

118 , "goto"

87 , "goto"

119 , "if"

88 , "if"

120 , "import"

89 , "import"

121− , "inline"

90+ , "interface"

122− , "int"

91+ , "map"

123− , "long"

92+ , "package"

124− , "module"

93+ , "range"

125− , "mutable"

126− , "namespace"

127− , "new"

128− , "noexcept"

129− , "not"

130− , "not_eq"

131− , "nullptr"

132− , "nullptr_t"

133− , "operator"

134− , "or"

135− , "or_eq"

136− , "private"

137− , "protected"

138− , "public"

139− , "register"

140− , "reinterpret_cast"

141− , "requires"

142 , "return"

94 , "return"

143− , "short"

95+ , "select"

144− , "signed"

145− , "sizeof"

146− , "static"

147− , "static_assert"

148− , "static_cast"

149 , "struct"

96 , "struct"

150 , "switch"

97 , "switch"

151− , "synchronized"

98+ , "type"

152− , "template"

99+ , "var"

153− , "this"

154− , "thread_local"

155− , "throw"

156− , "true"

157− , "try"

158− , "typedef"

159− , "typeid"

160− , "typename"

161− , "typeof"

162− , "union"

163− , "unsigned"

164− , "using"

165− , "virtual"

166− , "void"

167− , "volatile"

168− , "wchar_t"

169− , "while"

170− , "xor"

171− , "xor_eq"

172 ]

100 ]

173

101

174prefixIsReserved :: Text -> Bool

102prefixIsReserved :: Text -> Bool

175prefixIsReserved name =

103prefixIsReserved name =

176 any (`T.isPrefixOf` name)

104 any (`T.isPrefixOf` name)

177− [ "__"

105+ [

178 ]

106 ]

179

107

180ilLiterals :: [Text]

108ilLiterals :: [Text]

181ilLiterals =

109ilLiterals =

182− [ "box"

110+ [ "init"

183− , "boxed"

111+ , "nil"

184− , "copy"

112+ , "int"

185− , "errno"

113+ , "int8"

186− , "peek"

114+ , "int16"

187− , "purescript"

115+ , "int32"

188− , "runtime_error"

116+ , "int64"

189− , "setjmp"

117+ , "uint"

118+ , "uint8"

119+ , "uint16"

120+ , "uint32"

121+ , "uint64"

122+ , "uintptr"

123+ , "float32"

124+ , "float64"

125+ , "complex64"

126+ , "complex128"

127+ , "byte"

128+ , "rune"

190 , "string"

129 , "string"

191− , "unbox"

192 ]

130 ]

193

131

132+withPrefix :: Text -> Text

133+withPrefix s = "PS__" <> s

134+

135+anyType :: Text

136+anyType = "Any"

137+

194dictType :: Text

138dictType :: Text

195−dictType = "dict_t"

139+dictType = "map[string]Any"

196

140

197arrayType :: Text

141arrayType :: Text

198−arrayType = "array_t"

142+arrayType = "[]Any"

199

143

200int :: Text

144int :: Text

201int = "int"

145int = "int"

202

146

203float :: Text

147float :: Text

204−float = "double"

148+float = "float64"

205

149

206bool :: Text

150bool :: Text

207bool = "bool"

151bool = "bool"

@@ -210,13 +154,10 @@ string :: Text

210string = "string"

154string = "string"

211

155

212unbox :: Text -> Text

156unbox :: Text -> Text

213−unbox t = "unbox<" <> t <> ">"

157+unbox t = ".(" <> t <> ")"

214

158

215arrayLengthFn :: Text

159arrayLengthFn :: Text

216−arrayLengthFn = "array_length"

160+arrayLengthFn = "Length"

217−

218−unretainedSuffix :: Text

219−unretainedSuffix = "_Weak_"

220

161

221tcoLoop :: Text

162tcoLoop :: Text

222tcoLoop = "_TCO_Loop_"

163tcoLoop = "_TCO_Loop_"

src/CodeGen/IL/Optimizer.hs+2−2

@@ -12,7 +12,7 @@ import Language.PureScript.CoreImp.Optimizer.Inliner hiding (inlineUnsafeCoerce,

12import Language.PureScript.CoreImp.Optimizer.Unused

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

15−import CodeGen.IL.Common (unusedName)

15+import CodeGen.IL.Common (undefinedName, unusedName)

16import CodeGen.IL.Optimizer.TCO

18import qualified Language.PureScript.Constants as C

@@ -56,7 +56,7 @@ inlineUnsafePartial = everywhereTopDown convert where

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 ]

59+ = App ss comp [ Var ss undefinedName ]

60 convert other = other

62inlineUnsafeCoerce :: AST -> AST

src/CodeGen/IL/Optimizer/TCO.hs+2−2

@@ -93,11 +93,11 @@ tco mn = everywhere convert where

93 concatMap (\arg -> [ VariableIntroduction rootSS (tcoVar arg) Nothing

94 , Assignment rootSS (Var rootSS (tcoVar arg)) (Var rootSS (copyVar arg)) ]) (outerArgs ++ innerArgs) ++

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

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

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

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

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

99 , VariableIntroduction rootSS tcoResult Nothing

100− , Assignment rootSS (Var rootSS ("const auto " <> tcoLoop)) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))

100+ , Assignment rootSS (Var rootSS ("var " <> tcoLoop)) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))

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

102 , While rootSS (Unary Nothing Not (Var rootSS tcoDone))

103 (Block rootSS

src/CodeGen/IL/Printer.hs+161−135

@@ -15,7 +15,6 @@ import Control.Arrow ((<+>))

15import Control.Monad (forM, mzero)

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

17import Control.PatternArrows

18−import Data.Char (isAscii)

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

18import Data.List (filter, (\\))

20import qualified Control.Arrow as A

19import qualified Control.Arrow as A

@@ -49,26 +48,23 @@ literals = mkPattern' match'

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

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

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

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

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

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

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

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

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

52 , intercalate (emit ", ") <$> forM xs prettyPrintIL'

54− , return $ emit " }"

53+ , return $ emit "}"

55 ]

54 ]

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

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

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

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

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

57+ [ return . emit $ dictType <> "{"

59 , withIndent $ do

58 , withIndent $ do

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

59 ils <- forM ps $ \(key, value) -> do

61 value' <- prettyPrintIL' value

60 value' <- prettyPrintIL' value

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

61+ return $ objectPropertyToString key <> value'

63− indentString <- currentIndent

64− return $ intercalate (emit ",\n") $ map (indentString <>) ils

62+ return $ intercalate (emit " ") $ map (<> emit ",") ils

65− , return $ emit "\n"

66− , currentIndent

67 , return $ emit "}"

63 , return $ emit "}"

68 ]

64 ]

69 where

65 where

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

66 objectPropertyToString :: (Emit gen) => PSString -> gen

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

67+ objectPropertyToString s = emit $ stringLiteral s <> ": "

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

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

73 [ return $ emit "{\n"

69 [ return $ emit "{\n"

74 , withIndent $ prettyStatements sts

70 , withIndent $ prettyStatements sts

@@ -78,7 +74,7 @@ literals = mkPattern' match'

78 ]

74 ]

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

75 match (Var _ ident) = return $ emit ident

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

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

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

77+ [ return . emit $ varDecl <> " " <> ident <> " " <> anyType

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

78 , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintIL') value

83 ]

79 ]

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

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

@@ -87,13 +83,20 @@ literals = mkPattern' match'

87 , prettyPrintIL' value

83 , prettyPrintIL' value

88 ]

84 ]

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

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

86+ [ return $ emit "EffApply("

90− [ prettyPrintIL' val

87+ , prettyPrintIL' val

91− , return $ emit "()"

88+ , return $ emit ")"

89+ ]

90+ match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence

91+ [ return $ emit arrayLengthFn

92+ , return $ emit "("

93+ , prettyPrintIL' arg

94+ , return $ emit ")"

92 ]

95 ]

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

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

94 | fnMod == dictMod

97 | fnMod == dictMod

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

98 , dictMod == C.dataEq || dictMod == C.dataSemiring || dictMod == C.dataRing ||

96− dictMod == C.dataEuclideanRing || dictMod == C.dataHeytingAlgebra

99+ dictMod == C.dataEuclideanRing || dictMod == C.dataHeytingAlgebra || dictMod == C.dataOrd

97 , Just op <- renderOp fn

100 , Just op <- renderOp fn

98 , Just t <- unboxType dict

101 , Just t <- unboxType dict

99 = mconcat <$> sequence

102 = mconcat <$> sequence

@@ -101,130 +104,151 @@ literals = mkPattern' match'

101 , return $ emit op

104 , return $ emit op

102 , return $ emit $ unbox' t y

105 , return $ emit $ unbox' t y

103 ]

106 ]

104− match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])

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

105 | fnMod == dictMod

108 | fnMod == dictMod

106 , dictMod == C.dataRing

109 , dictMod == C.dataRing

107 , fn == C.negate

110 , fn == C.negate

108 , Just t <- unboxType dict

111 , Just t <- unboxType dict

109 = mconcat <$> sequence

112 = mconcat <$> sequence

110− [ return $ emit "-"

113+ [ return $ emit "-("

111 , return $ emit $ unbox' t n

114 , return $ emit $ unbox' t n

115+ , return $ emit ")"

112 ]

116 ]

113− match (App _ (App _ (Indexer _ (Var _ fn) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod)]) [n])

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

114 | fnMod == dictMod

118 | fnMod == dictMod

115 , dictMod == C.dataHeytingAlgebra

119 , dictMod == C.dataHeytingAlgebra

116 , fn == properToIL C.not

120 , fn == properToIL C.not

117 , Just t <- unboxType dict

121 , Just t <- unboxType dict

118 = mconcat <$> sequence

122 = mconcat <$> sequence

119− [ return $ emit "!"

123+ [ return $ emit "!("

120 , return $ emit $ unbox' t n

124 , return $ emit $ unbox' t n

125+ , return $ emit ")"

121 ]

126 ]

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

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

128+ [ return $ emit "Apply("

123− [ prettyPrintIL' val

129+ , prettyPrintIL' val

124− , return $ emit "("

130+ , return $ emit ", "

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

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

126 , return $ emit ")"

132 , return $ emit ")"

127 ]

133 ]

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

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

129− | isLiteral ret = mconcat <$> sequence

135+ | isComplexLiteral ret = mconcat <$> sequence

130− [ return $ emit "auto "

136+ [ return $ emit "\n"

137+ , return . emit $ varDecl <> " " <> initName name <> " Once\n"

138+ , prettyPrintIL' $ VariableIntroduction Nothing (valueName name) Nothing

139+ , return $ emit "\n\n"

131− , return $ emit name

140+ , return $ emit "func "

141+ , return . emit $ withPrefix name

132− , return $ emit "() -> const boxed& "

142+ , return . emit $ "() " <> anyType <> " "

133 , return $ emit "{\n"

143 , return $ emit "{\n"

134 , withIndent $ do

144 , withIndent $ do

135− indentString <- currentIndent

145+ indentString <- currentIndent

136− return $ indentString <> emit staticValueBegin

146+ return $ indentString <> (emit $ initName name <> ".Do(func() {\n") <>

147+ indentString <> indentString <> (emit $ valueName name <> " = ")

137 , withIndent $ do

148 , withIndent $ do

138 case ret of

149 case ret of

139 Function _ Nothing args body -> mconcat <$> sequence

150 Function _ Nothing args body -> mconcat <$> sequence

140− [ return $ emit "[]("

151+ [ return $ emit "func("

141− , return $ emit $ intercalate ", " (renderArg <$> args)

152+ , return . emit $ intercalate ", " (renderArg anyType <$> args)

142− , return $ emit ") -> boxed "

153+ , return . emit $ ") " <> anyType <> " "

143 , prettyPrintIL' body

154 , prettyPrintIL' body

144 ]

155 ]

145 _ -> do

156 _ -> do

146 prettyPrintIL' ret

157 prettyPrintIL' ret

147− , return $ emit ";\n"

158+ , return $ emit "\n"

148 , withIndent $ do

159 , withIndent $ do

149− indentString <- currentIndent

160+ indentString <- currentIndent

150− return $ indentString <> emit staticValueEnd

161+ return $ indentString <> (emit $ "})\n" <> "return " <> valueName name <>"\n")

151− , return $ emit "\n}"

162+ , return $ emit "}\n\n"

152 ]

163 ]

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

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

154− [ return $ emit "auto "

165+ [ return $ emit "func "

155− , return $ emit name

166+ , return . emit $ withPrefix name

156− , return $ emit "() -> boxed "

167+ , return . emit $ "() " <> anyType <> " "

157 , prettyPrintIL' ret

168 , prettyPrintIL' ret

158 ]

169 ]

159− match (Function _ name args ret) = mconcat <$> sequence

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

160− [ return $ emit captures

171+ [ return $ emit "func("

161− , return $ emit "("

162− , return $ emit $ intercalate ", " (render <$> args)

172+ , return . emit $ intercalate ", " (renderArg anyType <$> args)

163− , return $ emit ") -> boxed "

173+ , return . emit $ ") " <> anyType <> " "

164 , prettyPrintIL' ret

174 , prettyPrintIL' ret

165 ]

175 ]

166− where

176+ match (Indexer _ (Var _ name) (Var _ "")) = mconcat <$> sequence

167− (captures, render)

177+ [ prettyPrintIL' (Var Nothing $ withPrefix name)

168− | name == Just tcoLoop = ("[&]", renderArgByVal)

178+ , return $ emit "()"

169− | otherwise = ("[=]", renderArg)

179+ ]

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

180+ match (Indexer _ (Var _ name) val) = mconcat <$> sequence

171 [ prettyPrintIL' val

181 [ prettyPrintIL' val

172− , return $ emit "::"

182+ , return $ emit "."

173− , prettyPrintIL' prop

183+ , prettyPrintIL' (Var Nothing $ withPrefix name)

174 , return $ emit "()"

184 , return $ emit "()"

175 ]

185 ]

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

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

187+ [ return $ emit "Get("

177− [ prettyPrintIL' val

188+ , prettyPrintIL' val

178− , return $ emit "["

189+ , return $ emit ", "

179 , prettyPrintIL' prop

190 , prettyPrintIL' prop

180− , return $ emit "]"

191+ , return $ emit ")"

181 ]

192 ]

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

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

183− [ return . emit $ unbox' dictType val

194+ [ return $ emit "Contains("

195+ , prettyPrintIL' val

184− , return $ emit ".contains("

196+ , return $ emit ", "

185 , prettyPrintIL' ty

197 , prettyPrintIL' ty

186 , return $ emit ")"

198 , return $ emit ")"

187 ]

199 ]

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

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

189− [ return $ emit "while ("

201+ [ return $ emit "for "

190 , prettyPrintIL' cond

202 , prettyPrintIL' cond

191− , return $ emit ") "

203+ , return $ emit " "

192 , prettyPrintIL' sts

204 , prettyPrintIL' sts

193 ]

205 ]

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

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

195− [ return $ emit $ "for (boxed " <> ident <> " = "

207+ [ return $ emit $ "for var " <> ident <> " = "

196 , prettyPrintIL' start

208 , prettyPrintIL' start

197 , return $ emit $ "; " <> ident <> " < "

209 , return $ emit $ "; " <> ident <> " < "

198 , prettyPrintIL' end

210 , prettyPrintIL' end

199− , return $ emit $ "; " <> ident <> "++) "

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

200 , prettyPrintIL' sts

212 , prettyPrintIL' sts

201 ]

213 ]

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

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

203− [ return $ emit $ "for (boxed " <> ident <> " in "

215+ [ return $ emit $ "for var " <> ident <> " in "

204 , prettyPrintIL' obj

216 , prettyPrintIL' obj

205− , return $ emit ") "

217+ , return $ emit " "

206 , prettyPrintIL' sts

218 , prettyPrintIL' sts

207 ]

219 ]

220+ match (IfElse _ (Binary _ EqualTo cond (BooleanLiteral Nothing True)) thens elses)

221+ | (App ss (Indexer _ (Var _ _) (Var _ fnMod)) [Indexer _ (Var _ dict) (Var _ dictMod), x, y]) <- cond

222+ , fnMod == dictMod

223+ , dictMod == C.dataEq || dictMod == C.dataOrd

224+ , Just _ <- unboxTypeInt dict

225+ = mconcat <$> sequence

226+ [ return $ emit "if "

227+ , prettyPrintIL' cond

228+ , return $ emit " "

229+ , prettyPrintIL' thens

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

231+ ]

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

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

209− [ return $ emit "if ("

233+ [ return $ emit "if "

210 , return $ emit $ unbox' "bool" cond

234 , return $ emit $ unbox' "bool" cond

211− , return $ emit ") "

235+ , return $ emit " "

212 , prettyPrintIL' thens

236 , prettyPrintIL' thens

213 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

237 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

214 ]

238 ]

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

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

216− [ return $ emit "if (!("

240+ [ return $ emit "if !("

217 , return $ emit $ unbox' "bool" cond

241 , return $ emit $ unbox' "bool" cond

218− , return $ emit ")) "

242+ , return $ emit ") "

219 , prettyPrintIL' thens

243 , prettyPrintIL' thens

220 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

244 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

221 ]

245 ]

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

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

223− [ return $ emit "if ("

247+ [ return $ emit "if "

224 , return $ emit $ unbox' t x

248 , return $ emit $ unbox' t x

225 , return $ emit $ " == "

249 , return $ emit $ " == "

226 , prettyPrintIL' y

250 , prettyPrintIL' y

227− , return $ emit ") "

251+ , return $ emit " "

228 , prettyPrintIL' thens

252 , prettyPrintIL' thens

229 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

253 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

230 ]

254 ]

@@ -232,18 +256,18 @@ literals = mkPattern' match'

232 t | Left _ <- n = int

256 t | Left _ <- n = int

233 | Right _ <- n = float

257 | Right _ <- n = float

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

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

235− [ return $ emit "if ("

259+ [ return $ emit "if "

236 , return $ emit $ unbox' string a

260 , return $ emit $ unbox' string a

237 , return $ emit $ " == "

261 , return $ emit $ " == "

238 , prettyPrintIL' b

262 , prettyPrintIL' b

239− , return $ emit ") "

263+ , return $ emit " "

240 , prettyPrintIL' thens

264 , prettyPrintIL' thens

241 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

265 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

242 ]

266 ]

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

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

244− [ return $ emit "if ("

268+ [ return $ emit "if "

245 , prettyPrintIL' cond

269 , prettyPrintIL' cond

246− , return $ emit ") "

270+ , return $ emit " "

247 , prettyPrintIL' thens

271 , prettyPrintIL' thens

248 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

272 , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

249 ]

273 ]

@@ -251,11 +275,12 @@ literals = mkPattern' match'

251 [ return $ emit "return "

275 [ return $ emit "return "

252 , prettyPrintIL' value

276 , prettyPrintIL' value

253 ]

277 ]

254− match (ReturnNoResult _) = return $ emit "return undefined"

278+ match (ReturnNoResult _) = return . emit $ "return " <> undefinedName

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

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

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

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

257− [ return $ emit "THROW_("

281+ [ return $ emit "panic("

258 , return $ emit "\"PatternMatchFailure: \""

282 , return $ emit "\"PatternMatchFailure: \""

283+ , return $ emit " + "

259 , prettyPrintIL' value

284 , prettyPrintIL' value

260 , return $ emit ")"

285 , return $ emit ")"

261 ]

286 ]

@@ -330,11 +355,17 @@ isLiteral ObjectLiteral{} = True

330isLiteral ArrayLiteral{} = True

355isLiteral ArrayLiteral{} = True

331isLiteral _ = False

356isLiteral _ = False

332

357

358+isComplexLiteral :: AST -> Bool

359+-- isComplexLiteral Function{} = True

360+isComplexLiteral ObjectLiteral{} = True

361+isComplexLiteral ArrayLiteral{} = True

362+isComplexLiteral _ = False

363+

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

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

334prettyStatements sts = do

365prettyStatements sts = do

335 ils <- forM sts prettyPrintIL'

366 ils <- forM sts prettyPrintIL'

336 indentString <- currentIndent

367 indentString <- currentIndent

337− return $ intercalate (emit "\n") $ map ((<> emit ";") . (indentString <>)) ils

368+ return $ intercalate (emit "\n") $ map (indentString <>) ils

338

369

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

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

340prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])

371prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])

@@ -383,15 +414,12 @@ prettyPrintIL1 :: AST -> Text

383prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'

414prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'

384

415

385stringLiteral :: PSString -> Text

416stringLiteral :: PSString -> Text

386−stringLiteral pss | Just s <- decodeString pss =

417+stringLiteral pss | Just s <- decodeString pss = stringLiteral' s

387− (if T.all isAscii s

388− then ""

389− else ("u8")) <> stringLiteral' s

390 where

418 where

391 stringLiteral' :: Text -> Text

419 stringLiteral' :: Text -> Text

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

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

393 encodeChar :: Char -> Text

421 encodeChar :: Char -> Text

394− encodeChar '\0' = "\\0"

422+ encodeChar '\0' = "\\x00"

395 encodeChar '\b' = "\\b"

423 encodeChar '\b' = "\\b"

396 encodeChar '\t' = "\\t"

424 encodeChar '\t' = "\\t"

397 encodeChar '\n' = "\\n"

425 encodeChar '\n' = "\\n"

@@ -407,13 +435,14 @@ unbox' :: Text -> AST -> Text

407unbox' _ v@(NumericLiteral{}) = prettyPrintIL1 v

435unbox' _ v@(NumericLiteral{}) = prettyPrintIL1 v

408unbox' _ v@(BooleanLiteral{}) = prettyPrintIL1 v

436unbox' _ v@(BooleanLiteral{}) = prettyPrintIL1 v

409unbox' _ v@(StringLiteral{}) = prettyPrintIL1 v

437unbox' _ v@(StringLiteral{}) = prettyPrintIL1 v

410−unbox' t v = unbox t <> "(" <> prettyPrintIL1 v <> ")"

438+unbox' t v = "(" <> prettyPrintIL1 v <> ")" <> unbox t -- unbox t <> "(" <> prettyPrintIL1 v <> ")"

411

439

412unboxType :: Text -> Maybe Text

440unboxType :: Text -> Maybe Text

413unboxType t

441unboxType t

414 | t == C.eqInt ||

442 | t == C.eqInt ||

415 t == C.semiringInt ||

443 t == C.semiringInt ||

416− t == C.ringInt

444+ t == C.ringInt ||

445+ t == C.ordInt

417 = Just int

446 = Just int

418 | t == C.semiringNumber ||

447 | t == C.semiringNumber ||

419 t == C.ringNumber ||

448 t == C.ringNumber ||

@@ -423,10 +452,23 @@ unboxType t

423 = Just bool

452 = Just bool

424 | otherwise = Nothing

453 | otherwise = Nothing

425

454

455+unboxTypeInt :: Text -> Maybe Text

456+unboxTypeInt t

457+ | t == C.eqInt ||

458+ t == C.semiringInt ||

459+ t == C.ringInt ||

460+ t == C.ordInt

461+ = Just int

462+ | otherwise = Nothing

463+

426renderOp :: Text -> Maybe Text

464renderOp :: Text -> Maybe Text

427renderOp op

465renderOp op

428 | op == C.eq = Just " == "

466 | op == C.eq = Just " == "

429 | op == C.notEq = Just " != "

467 | op == C.notEq = Just " != "

468+ | op == C.lessThan = Just " < "

469+ | op == C.lessThanOrEq = Just " <= "

470+ | op == C.greaterThan = Just " > "

471+ | op == C.greaterThanOrEq = Just " >= "

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

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

431 | op == C.sub = Just " - "

473 | op == C.sub = Just " - "

432 | op == C.mul = Just " * "

474 | op == C.mul = Just " * "

@@ -436,29 +478,22 @@ renderOp op

436 | otherwise = Nothing

478 | otherwise = Nothing

437

479

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

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

439−interfaceSource mn values foreigns =

481+interfaceSource _ _ _ = ""

440− let foreigns' = identToIL <$> foreigns

441− valueNames = fst <$> values

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

443− zip (foreigns' \\ valueNames) (repeat True)

444− in

445− "// Generated by psil compiler\n\n" <>

446− "#ifndef " <> mn <> "_H\n" <>

447− "#define " <> mn <> "_H\n\n" <>

448− "#include \"purescript.h\"\n\n" <>

449− "namespace " <> mn <> " {\n\n" <>

450− "using namespace purescript;\n\n" <>

451− (T.concat $ (\(export, static) ->

452− let rty = if static then "const boxed&" else "boxed" in

453− "auto " <> export <> "() -> " <> rty <> ";\n") <$> values') <> "\n" <>

454− "} // end namespace " <> mn <> "\n\n" <>

455− "#endif // " <> mn <> "_H\n\n"

456

482

457implHeaderSource :: Text -> [Text] -> Text -> Text

483implHeaderSource :: Text -> [Text] -> Text -> Text

458−implHeaderSource mn imports interfaceImport =

484+implHeaderSource mn imports _ =

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

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

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

488+ (if mn == "Main"

489+ then "import \"purescript_ffi\"\n"

490+ else "") <>

459− T.concat imports <> "\n"<>

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

460− interfaceImport <> "\n\n" <>

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

461− "namespace " <> mn <> " {\n\n"

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

494+ (if mn == "Main"

495+ then "\nconst _ = purescript_ffi.Loader\n\n"

496+ else "\n")

462

497

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

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

464implFooterSource mn foreigns =

499implFooterSource mn foreigns =

@@ -466,50 +501,41 @@ implFooterSource mn foreigns =

466 (if null foreigns

501 (if null foreigns

467 then ""

502 then ""

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

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

469− "DEFINE_FOREIGN_DICTIONARY_AND_ACCESSOR()\n\n" <>

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

470− (T.concat $ (\foreign' -> "auto " <>

505+ (T.concat $ (\foreign' ->

471− identToIL foreign' <>

506+ let name = identToIL foreign' in

472− "() -> const boxed& { " <>

507+ varDecl <> " " <> initName name <> " Once\n" <>

473− staticValueBegin <>

508+ varDecl <> " " <> valueName name <> " " <> anyType <> "\n\n" <>

474− foreignDict <> "().at(" <>

509+ "func " <>

510+ withPrefix name <>

511+ "() Any { \n" <>

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

513+ " " <> valueName name <> " = " <>

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

475− (stringLiteral . mkString $ runIdent foreign') <> "); " <>

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

476− staticValueEnd <>

516+ " })\n" <>

517+ " return " <> valueName name <> "\n" <>

477− " };\n") <$> foreigns) <>

518+ "}\n\n") <$> foreigns))) <>

478− "\n")) <>

479− "} // end namespace " <> mn <>

480− "\n\n" <>

481 if mn == "Main" then mainSource else "\n"

519 if mn == "Main" then mainSource else "\n"

482 where

520 where

483 mainSource :: Text

521 mainSource :: Text

484 mainSource = "\

522 mainSource = "\

485− \int main(int argc, const char * argv[]) {\n\

523+ \func main() {\n\

486− \ Main::main()();\n\

524+ \ EffApply(PS__main())\n\

487− \ return 0;\n\

488 \}\n\n\

525 \}\n\n\

489 \"

526 \"

490

527

491varDecl :: Text

528varDecl :: Text

492−varDecl = "const boxed"

529+varDecl = "var"

493−

494−varRefDecl :: Text

495−varRefDecl = varDecl <> "&"

496−

497−renderArg' :: Text -> Text -> Text

498−renderArg' decl arg

499− | arg == unusedName = decl

500− | otherwise = decl <> " " <> arg

501−

502−renderArg :: Text -> Text

503−renderArg = renderArg' varRefDecl

504

530

505−renderArgByVal :: Text -> Text

531+renderArg :: Text -> Text -> Text

506−renderArgByVal = renderArg' varDecl

532+renderArg decl arg = arg <> " " <> decl

507

533

508foreignDict :: Text

534foreignDict :: Text

509−foreignDict = "foreign"

535+foreignDict = "Foreign"

510

536

511−staticValueBegin :: Text

537+initName :: Text -> Text

512−staticValueBegin = "static const boxed _ = "

538+initName s = "_" <> s <> "_init_"

513

539

514−staticValueEnd :: Text

540+valueName :: Text -> Text

515−staticValueEnd = "return _;"

541+valueName s = "_" <> s <> "_value_"