47af0dc · rowtype-yoga/purescript-native

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

Merge remote-tracking branch 'pure11/pure11' into native

commit47af0dcdc9e7d167a3659ddcd64138f2b34aa23d authorAndy Arvanitis <andyarvanitis@gmail.com> dateWed 21 Dec 2016, 15:30 (10 years ago) parentaf3b441 3942bea

8 files changed+88−34

compare with golang

unifiedsplit

pcc/runtime/purescript.hh+1−1 src/Language/PureScript/CodeGen/Cpp.hs+3−2 src/Language/PureScript/CodeGen/Cpp/AST.hs+5−4 src/Language/PureScript/CodeGen/Cpp/Common.hs+16−4 src/Language/PureScript/CodeGen/Cpp/File.hs+2−3 src/Language/PureScript/CodeGen/Cpp/Optimizer.hs+1 src/Language/PureScript/CodeGen/Cpp/Optimizer/Blocks.hs+25−1 src/Language/PureScript/Pretty/Cpp.hs+35−19

pcc/runtime/purescript.hh+1−1

@@ -517,7 +517,7 @@ namespace data {

517517 }

518518

519519 template <typename T>

520− inline auto ctor(const T& a) -> const any& {

520+ inline auto ctor(const T& a) -> int {

521521 return get<0>(a);

522522 }

523523}

src/Language/PureScript/CodeGen/Cpp.hs+3−2

@@ -28,7 +28,6 @@ module Language.PureScript.CodeGen.Cpp

2828 ) where

2929

3030import Prelude.Compat

31−

3231import Data.Char (isLetter)

3332import Data.Function (on)

3433import Data.List

@@ -110,6 +109,7 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do

110109 symbols = allSymbols bodyCpps

111110 moduleBody =

112111 CppInclude (runModuleName mn) (runModuleName mn) :

112+ P.linebreak ++

113113 (CppDefineSymbol <$> symbols) ++

114114 (if null bodyCpps

115115 then []

@@ -138,7 +138,8 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do

138138 -------------------------------------------------------------------------------------------------

139139 declToCpp _ (_, ident) e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =

140140 let className = identToCpp ident

141− (supers, members) = span (C.__superclass_ `Text.isPrefixOf`) (identToCpp <$> (fst $ unAbs e []))

141+ (supers, members) =

142+ span (safeName C.__superclass_ `Text.isPrefixOf`) (identToCpp <$> (fst $ unAbs e []))

142143 in return $ CppStruct className [CppEnum Nothing Nothing (sort supers <> members)]

143144 declToCpp vqs (_, ident) (Abs (_, com, ty, _) arg body) = do

144145 fn <-

src/Language/PureScript/CodeGen/Cpp/AST.hs+5−4

@@ -270,7 +270,7 @@ data Cpp

270270 -- |

271271 -- Switch statement

272272 --

273− | CppSwitch Cpp [(Cpp, Cpp)]

273+ | CppSwitch Cpp [(Cpp, Cpp)] (Maybe Cpp)

274274 -- |

275275 -- Return statement

276276 --

@@ -329,7 +329,7 @@ everywhereOnCpp f = go

329329 go (CppAssignment j1 j2) = f (CppAssignment (go j1) (go j2))

330330 go (CppWhile j1 j2) = f (CppWhile (go j1) (go j2))

331331 go (CppIfElse j1 j2 j3) = f (CppIfElse (go j1) (go j2) (fmap go j3))

332− go (CppSwitch cpp cpps) = f (CppSwitch (go cpp) (map (fmap go) cpps))

332+ go (CppSwitch cpp cpps d) = f (CppSwitch (go cpp) (map (fmap go) cpps) (fmap go d))

333333 go (CppReturn cpp) = f (CppReturn (go cpp))

334334 go (CppThrow cpp) = f (CppThrow (go cpp))

335335 go (CppComment com j) = f (CppComment com (go j))

@@ -362,7 +362,7 @@ everywhereOnCppTopDownM f = f >=> go

362362 go (CppAssignment j1 j2) = CppAssignment <$> f' j1 <*> f' j2

363363 go (CppWhile j1 j2) = CppWhile <$> f' j1 <*> f' j2

364364 go (CppIfElse j1 j2 j3) = CppIfElse <$> f' j1 <*> f' j2 <*> traverse f' j3

365− go (CppSwitch cpp cpps) = CppSwitch <$> f' cpp <*> traverse (pairM f' f') cpps

365+ go (CppSwitch cpp cpps d) = CppSwitch <$> f' cpp <*> traverse (pairM f' f') cpps <*> traverse f' d

366366 go (CppReturn j) = CppReturn <$> f' j

367367 go (CppThrow j) = CppThrow <$> f' j

368368 go (CppComment com j) = CppComment com <$> f' j

@@ -392,7 +392,8 @@ everythingOnCpp (<>) f = go

392392 go j@(CppWhile j1 j2) = f j <> go j1 <> go j2

393393 go j@(CppIfElse j1 j2 Nothing) = f j <> go j1 <> go j2

394394 go j@(CppIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3

395− go j@(CppSwitch cpp cpps) = foldl (<>) (f j <> go cpp) ((map (go . fst) cpps) ++ (map (go . snd) cpps))

395+ go j@(CppSwitch cpp cpps Nothing) = foldl (<>) (f j <> go cpp) ((map (go . fst) cpps) ++ (map (go . snd) cpps))

396+ go j@(CppSwitch cpp cpps (Just d)) = foldl (<>) (f j <> go cpp) ((map (go . fst) cpps) ++ (map (go . snd) cpps)) <> go d

396397 go j@(CppReturn j1) = f j <> go j1

397398 go j@(CppThrow j1) = f j <> go j1

398399 go j@(CppComment _ j1) = f j <> go j1

src/Language/PureScript/CodeGen/Cpp/Common.hs+16−4

@@ -18,11 +18,12 @@

1818

1919module Language.PureScript.CodeGen.Cpp.Common where

2020

21−import Prelude.Compat hiding (all, concatMap, last, init, null)

21+import Prelude.Compat hiding (all, any, concatMap, last, init, map, null)

2222

2323import Data.Char

24−import Data.Text hiding (map)

24+import Data.Text hiding (foldl1)

2525import Data.Monoid ((<>))

26+import qualified Language.PureScript.Constants as C

2627import Language.PureScript.Crash

2728import Language.PureScript.Names

2829

@@ -45,6 +46,10 @@ safeName name

4546safeName name

4647 | Just ('$', s) <- uncons name

4748 , all isDigit s = name

49+safeName name

50+ | C.__superclass_ `isPrefixOf` name

51+ , any (=='.') name

52+ = "$" <> (escaped $ dotsTo '_' name)

4853safeName name

4954 | "_" `isPrefixOf` name = "$" <> escaped name

5055safeName name = escaped name

@@ -52,6 +57,9 @@ safeName name = escaped name

5257escaped :: Text -> Text

5358escaped = escapeDoubleUnderscores . concatMap identCharToText

5459

60+dotsTo :: Char -> Text -> Text

61+dotsTo chr' = map (\c -> if c == '.' then chr' else c)

62+

5563-- |

5664-- C++ actually reserves all identifiers containing double

5765-- underscores.

@@ -235,8 +243,12 @@ normalizedName = unescapeDoubleUnderscores . normalizedName'

235243

236244moduleNameToCpp :: ModuleName -> Text

237245moduleNameToCpp (ModuleName pns) =

238− let name = intercalate "_" (runProperName `map` pns)

239− in if properNameIsCppReserved name then name <> "$" else name

246+ if properNameIsCppReserved name then name <> "$" else name

247+ where

248+ pnames = runProperName <$> pns

249+ name

250+ | foldl1 (||) (any (=='_') <$> pnames) = error "Module names can now contain underscores"

251+ | otherwise = intercalate "_" pnames

240252

241253-- |

242254-- Checks whether a proper name is reserved in C++11.

src/Language/PureScript/CodeGen/Cpp/File.hs+2−3

@@ -24,11 +24,10 @@ import Data.Monoid ((<>))

2424import Data.Text (Text)

2525

2626import Language.PureScript.CodeGen.Cpp.AST

27+import Language.PureScript.CodeGen.Cpp.Common

2728import Language.PureScript.CodeGen.Cpp.Types

2829import Language.PureScript.Names

2930

30−import qualified Language.PureScript.Pretty.Cpp as P

31−

3231---------------------------------------------------------------------------------------------------

3332toHeader :: [Cpp] -> [Cpp]

3433---------------------------------------------------------------------------------------------------

@@ -171,7 +170,7 @@ fileEnd :: ModuleName -> Text -> [Cpp]

171170fileEnd mn suffix = [CppRaw ("#endif // " <> fileModName mn suffix)]

172171

173172fileModName :: ModuleName -> Text -> Text

174−fileModName mn suffix = P.dotsTo '_' (runModuleName mn <> "_" <> suffix)

173+fileModName mn suffix = dotsTo '_' (runModuleName mn <> "_" <> suffix)

175174

176175isMain :: ModuleName -> Bool

177176isMain (ModuleName [ProperName "Main"]) = True

src/Language/PureScript/CodeGen/Cpp/Optimizer.hs+1

@@ -69,6 +69,7 @@ optimize' nm cpp = do

6969 opts <- ask

7070 untilFixedPoint (liftM toAutoVars . inlineFnComposition . applyAll

7171 [ collapseNestedBlocks

72+ , collapseCtorChecksToSwitch

7273 , collapseNestedIfs

7374 , collapseIfElses

7475 , removeCurrying nm

src/Language/PureScript/CodeGen/Cpp/Optimizer/Blocks.hs+25−1

@@ -17,11 +17,14 @@ module Language.PureScript.CodeGen.Cpp.Optimizer.Blocks

1717 ( collapseNestedBlocks

1818 , collapseNestedIfs

1919 , collapseIfElses

20+ , collapseCtorChecksToSwitch

2021 ) where

2122

2223import Prelude.Compat

24+import Data.Either

2325

2426import Language.PureScript.CodeGen.Cpp.AST

27+import Language.PureScript.CodeGen.Cpp.Types

2528import qualified Language.PureScript.Constants as C

2629

2730-- |

@@ -53,7 +56,7 @@ collapseIfElses = everywhereOnCpp collapse

5356 where

5457 go (st'@(CppIfElse (CppBinary EqualTo lhs _) _ Nothing) : sts') =

5558 if length (fst cpps') > 1

56− then CppSwitch lhs (mkCases <$> fst cpps') : snd cpps'

59+ then CppSwitch lhs (mkCases <$> fst cpps') Nothing : snd cpps'

5760 else st' : sts'

5861 where

5962 cpps' = span (isIntEq lhs) (st' : sts')

@@ -83,3 +86,24 @@ collapseIfElses = everywhereOnCpp collapse

8386 go cpp' = cpp'

8487 collapse (CppIfElse (CppAccessor (CppVar "otherwise") (CppVar mn')) body _) | mn' == C.prelude = body

8588 collapse cpp = cpp

89+

90+collapseCtorChecksToSwitch :: Cpp -> Cpp

91+collapseCtorChecksToSwitch = everywhereOnCpp collapse

92+ where

93+ collapse :: Cpp -> Cpp

94+ collapse (CppBlock cpps@(_:_:_)) = CppBlock (go cpps)

95+ where

96+ go cpps'@(cpp:_)

97+ | Right (lhs, _, _) <- fromif Nothing cpp

98+ , (otherCpps, ifs@(_:_:_)) <- partitionEithers $ fromif (Just lhs) <$> cpps'

99+ = CppSwitch lhs ((\(_,b,c) -> (b,c)) <$> ifs) Nothing : otherCpps

100+ go (cpp':cpps') = cpp' : go cpps'

101+ go cpp' = cpp'

102+ fromif :: Maybe Cpp -> Cpp -> Either Cpp (Cpp, Cpp, Cpp)

103+ fromif cond (CppIfElse (CppBinary EqualTo lhs rhs) stmt Nothing)

104+ | CppApp (CppVar f) _ <- lhs

105+ , f == getCtor

106+ , maybe True (lhs==) cond

107+ = Right (lhs, rhs, stmt)

108+ fromif _ cpp = Left cpp

109+ collapse cpp = cpp

src/Language/PureScript/Pretty/Cpp.hs+35−19

@@ -85,24 +85,18 @@ literals = mkPattern' match

8585 match (CppCharLiteral c) = return $ "'" <> T.singleton c <> "'"

8686 match (CppBooleanLiteral True) = return "true"

8787 match (CppBooleanLiteral False) = return "false"

88− match (CppArrayLiteral [x@CppArrayLiteral {}]) = -- Works around what appears to be a recent clang bug

89− mconcat <$> sequence

90− [ return $ runType arrayType

91− , return "{ { "

92− , prettyPrintCpp' x

93− , return " } }"

94− ]

88+ match (CppArrayLiteral []) = return $ runType arrayType <> "{}"

9589 match (CppArrayLiteral xs) = mconcat <$> sequence

9690 [ return $ runType arrayType

97− , return "{ "

91+ , return "{{ "

9892 , fmap (T.intercalate ", ") $ forM xs prettyPrintCpp'

99− , return " }"

93+ , return " }}"

10094 ]

10195 match (CppDataLiteral xs) = mconcat <$> sequence

10296 [ return $ runType (dataType $ length xs)

103− , return "{ "

97+ , return "{{ "

10498 , fmap (T.intercalate ", ") $ forM xs prettyPrintCpp'

105− , return " }"

99+ , return " }}"

106100 ]

107101 match (CppEnum name ty es) = mconcat <$> sequence

108102 [ return "enum"

@@ -276,15 +270,17 @@ literals = mkPattern' match

276270 , prettyPrintCpp' thens

277271 , maybe (return "") (fmap (" else " <>) . prettyPrintCpp') elses

278272 ]

279− match (CppSwitch cond cases@((case1,_):_:_)) = mconcat <$> sequence

273+ match (CppSwitch cond cases@((case1,_):_:_) default') = mconcat <$> sequence

280274 [ return "switch "

281275 , return . parensT $ prettyPrintCpp1 (cast case1 cond)

282276 , return " {\n"

283277 , withIndent $ do

284− cpps <- forM cases $ \(c, s) -> do

285− c' <- prettyPrintCpp' c

286− s' <- prettyPrintCpp' s

287− return $ "case " <> c' <> ": " <> s' <> ";"

278+ cpps <- forM (normalizeBlocks $

279+ cases ++ maybe [] (\c -> [(CppNoOp,c)]) default')

280+ $ \(c, s) -> do

281+ c' <- prettyPrintCpp' c

282+ s' <- prettyPrintCpp' s

283+ return $ label c <> c' <> ": " <> s' <> caseEnd s

288284 indentString <- currentIndent

289285 return $ T.intercalate "\n" $ map (indentString <>) cpps

290286 , return "\n"

@@ -297,6 +293,25 @@ literals = mkPattern' match

297293 cast CppBooleanLiteral {} cpp' = CppCast boolType cpp'

298294 cast CppCharLiteral {} cpp' = CppCast charType cpp'

299295 cast _ cpp' = cpp'

296+ normalizeBlocks :: [(Cpp,Cpp)] -> [(Cpp,Cpp)]

297+ normalizeBlocks cpps

298+ | any (isBlock . snd) cpps = addBlock <$> cpps

299+ | otherwise = cpps

300+ where

301+ addBlock (cpp1, cpp2@(CppBlock _)) = (cpp1, cpp2)

302+ addBlock (cpp1, cpp2) = (cpp1, CppBlock [cpp2])

303+ label :: Cpp -> Text

304+ label CppNoOp = "default"

305+ label _ = "case "

306+ caseEnd :: Cpp -> Text

307+ caseEnd (CppReturn {}) = ";"

308+ caseEnd (CppThrow {}) = ";"

309+ caseEnd (CppContinue) = ";"

310+ caseEnd (CppBlock stmts@(_:_))

311+ | (CppReturn {}) <- last stmts = ""

312+ | (CppThrow {}) <- last stmts = ""

313+ | CppContinue <- last stmts = ""

314+ caseEnd _ = " break;"

300315 match (CppReturn (CppBlock (cpp:cpps))) = mconcat <$> sequence

301316 [ do s <- prettyPrintCpp' cpp

302317 return $ T.dropWhile isSpace s

@@ -500,9 +515,6 @@ prettyPrintCpp' = A.runKleisli $ runPattern matchValue

500515 , [ binary Or " || " ]

501516 ]

502517

503−dotsTo :: Char -> Text -> Text

504−dotsTo chr' = T.map (\c -> if c == '.' then chr' else c)

505−

506518argstr :: (Text, Maybe CppType) -> Text

507519argstr (name, Nothing) = argStr name (Auto [])

508520argstr (name, Just typ)

@@ -538,6 +550,10 @@ isNoOp CppNoOp = True

538550isNoOp (CppComment [] CppNoOp) = True

539551isNoOp _ = False

540552

553+isBlock :: Cpp -> Bool

554+isBlock (CppBlock {}) = True

555+isBlock _ = False

556+

541557renderName :: Text -> Text

542558renderName name

543559 | Just ('*', name') <- T.uncons name = '$' `T.cons` name'