ddf7e59 · rowtype-yoga/purescript-native

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

on golang help sign in

C++: fix some issues with TCO and recursive refs

ddf7e59Andy Arvanitis10 years ago

purescript.cabal+1

compare with golang

unifiedsplit

@@ -205,6 +205,7 @@ library

205 Language.PureScript.CodeGen.Cpp.Optimizer.TCO

206 Language.PureScript.CodeGen.Cpp.Optimizer.Uncurry

207 Language.PureScript.CodeGen.Cpp.Optimizer.Unused

208+ Language.PureScript.CodeGen.Cpp.Recursion

208 Language.PureScript.CodeGen.Cpp.Types

209 Language.PureScript.CodeGen.Cpp.Types

209 Language.PureScript.CodeGen.Cpp.Unicode

210 Language.PureScript.CodeGen.Cpp.Unicode

210 Language.PureScript.Pretty.Cpp

211 Language.PureScript.Pretty.Cpp

src/Language/PureScript/CodeGen/Cpp.hs+10−108

@@ -32,23 +32,22 @@ import Data.Char (isLetter)

32import Data.Function (on)

33import Data.List

34import qualified Data.Map as M

35−import Data.Maybe (catMaybes, fromJust)

35+import Data.Maybe (catMaybes)

36import Data.Monoid ((<>))

37import Data.Text (Text, unpack)

38import qualified Data.Text as Text

40import Control.Monad (forM, replicateM)

41−import Control.Monad.Reader (MonadReader, ask)

41+import Control.Monad.Reader (MonadReader)

42import Control.Monad.Supply.Class

43import Language.PureScript.AST.SourcePos

44import Language.PureScript.CodeGen.Cpp.AST as AST

45import Language.PureScript.CodeGen.Cpp.Common as Common

46import Language.PureScript.CodeGen.Cpp.File

47import Language.PureScript.CodeGen.Cpp.Optimizer

48−import Language.PureScript.CodeGen.Cpp.Optimizer.TCO

48+import Language.PureScript.CodeGen.Cpp.Recursion

49import Language.PureScript.CodeGen.Cpp.Types

50import Language.PureScript.CodeGen.Cpp.Unicode

51−import Language.PureScript.Comments

52import Language.PureScript.CoreFn

51import Language.PureScript.CoreFn

53import Language.PureScript.Names

52import Language.PureScript.Names

54import Language.PureScript.Options

53import Language.PureScript.Options

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

93 E.dataConstructors env

92 E.dataConstructors env

94 cpps' <- traverse (optimize $ namesmap ++ datamap) cpps

93 cpps' <- traverse (optimize $ namesmap ++ datamap) cpps

95 foreignWrappers <- curriedForeigns

94 foreignWrappers <- curriedForeigns

96− let optimized = (otherTransforms otherOpts <$> cpps') ++ foreignWrappers

95+ let optimized = (otherTransforms otherOpts . convertRecursiveRefs <$> cpps') ++ foreignWrappers

97 let moduleHeader =

96 let moduleHeader =

98 fileBegin mn "HH" ++

97 fileBegin mn "HH" ++

99 P.linebreak ++

98 P.linebreak ++

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

333 fnToLambda (CppFunction name args _ qs body) =

332 fnToLambda (CppFunction name args _ qs body) =

334 CppVariableIntroduction

333 CppVariableIntroduction

335 (name, Just $ Any [Const])

334 (name, Just $ Any [Const])

336− (filter (== Static) qs)

335+ qs -- (filter (== Static) qs)

337 (Just $ CppLambda cs args (Just $ Any []) body)

336 (Just $ CppLambda cs args (Just $ Any []) body)

338 where

337 where

339 cs

338 cs

@@ -350,82 +349,6 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do

350 go f@(CppFunction {}) = maybeRemCaps $ fnToLambda f

349 go f@(CppFunction {}) = maybeRemCaps $ fnToLambda f

351 go (CppLambda _ args rtyp body) = maybeRemCaps $ CppLambda [CaptureAll] args rtyp body

350 go (CppLambda _ args rtyp body) = maybeRemCaps $ CppLambda [CaptureAll] args rtyp body

352 go cpp = cpp

351 go cpp = cpp

353− -------------------------------------------------------------------------------------------------

354− convertRecursiveFns :: [Cpp] -> Cpp -> [Cpp]

355− -------------------------------------------------------------------------------------------------

356− convertRecursiveFns cpps otherCpp

357− | not $ null fns = dict : (accessor topdict <$> filteredFns allCpps) ++ cpps'

358− where

359− cpps' = everywhereOnCpp removeRec <$> cpps

360− allCpps = CppBlock $ otherCpp : cpps'

361− fns :: [(Text, Cpp)]

362− fns = toelem <$> concatMap (everythingOnCpp (++) recursive) cpps

363− filteredFns :: Cpp -> [(Text, Cpp)]

364− filteredFns cpp = filter (\(f, _) -> everythingOnCpp (||) (== CppVar f) cpp) fns

365− recursive :: Cpp -> [Cpp]

366− recursive cpp'@(CppFunction _ _ _ qs _)

367− | Recursive `elem` qs = [cpp']

368− recursive cpp'@(CppVariableIntroduction _ qs _)

369− | Recursive `elem` qs = [cpp']

370− recursive _ = []

371− removeRec :: Cpp -> Cpp

372− removeRec (CppFunction _ _ _ qs _)

373− | Recursive `elem` qs = CppNoOp

374− removeRec (CppVariableIntroduction _ qs _)

375− | Recursive `elem` qs = CppNoOp

376− removeRec cpp' = cpp'

377− replaceVar :: [(Text, Cpp)] -> Cpp -> Cpp

378− replaceVar rs = go

379− where

380− go (CppVar var)

381− | Just var' <- lookup var rs = var'

382− go cpp' = cpp'

383− dict :: Cpp

384− dict =

385− CppVariableIntroduction

386− (topdict, Just $ Any [Const])

387− []

388− (Just $ CppDataLiteral ((\(f, cpp) -> CppComment [LineComment f] cpp) <$> fns))

389− accessed :: Text -> Text -> (Text, Cpp)

390− accessed dictname name =

391− ( name

392− , CppApp

393− (CppDataGet

394− (CppNumericLiteral . Left . fromIntegral . fromJust $ findIndex ((== name) . fst) fns)

395− dict')

396− [dict'])

397− where

398− dict' = CppVar dictname

399− accessor :: Text -> (Text, Cpp) -> Cpp

400− accessor dictname (name, _) =

401− CppVariableIntroduction (name, Just $ Any [Const]) [] (Just . snd $ accessed dictname name)

402− toelem :: Cpp -> (Text, Cpp)

403− toelem (CppFunction name args rtyp _ body'@(CppBlock body)) =

404− ( name

405− , withdict . maybeRemCaps $

406− CppLambda

407− [CaptureAll]

408− args

409− rtyp

410− (CppBlock $ (accessor localdict <$> filteredFns body') ++ body))

411− toelem (CppVariableIntroduction (name, _) _ (Just body')) =

412− let replacements = accessed localdict . fst <$> filteredFns body'

413− replaced = everywhereOnCpp (replaceVar replacements) body'

414− in (name, withdict . maybeRemCaps $ CppBlock [CppReturn replaced])

415− toelem _ = error "not a function"

416− withdict :: Cpp -> Cpp

417− withdict cpp' =

418− maybeRemCaps $

419− CppLambda

420− [CaptureAll]

421− [(localdict, Just $ Any [Const, Ref])]

422− (Just $ Any [])

423− (returnBlock cpp')

424− topdict :: Text

425− topdict = "_$dict$_"

426− localdict :: Text

427− localdict = "$dict$"

428− convertRecursiveFns cpps _ = cpps

429

352

430 -- |

353 -- |

431 -- Generate code in the simplified C++1x intermediate representation for a value or expression.

354 -- Generate code in the simplified C++1x intermediate representation for a value or expression.

@@ -437,6 +360,9 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do

437 valueToCpp (Var (_, _, _, Just (IsConstructor _ [])) ident) = return $ CppApp (varToCpp ident) []

360 valueToCpp (Var (_, _, _, Just (IsConstructor _ [])) ident) = return $ CppApp (varToCpp ident) []

438 valueToCpp (Var (_, _, Just ty, _) ident@(Qualified (Just _) _))

361 valueToCpp (Var (_, _, Just ty, _) ident@(Qualified (Just _) _))

439 | arity ty > 0 = return . curriedName' $ varToCpp ident

362 | arity ty > 0 = return . curriedName' $ varToCpp ident

363+ valueToCpp (Var (_, _, Nothing, _) ident@(Qualified (Just _) _))

364+ | Just (ty, _, _) <- M.lookup ident (E.names env)

365+ , arity ty > 0 = return . curriedName' $ varToCpp ident

440 valueToCpp (Var _ ident) = return $ varToCpp ident

366 valueToCpp (Var _ ident) = return $ varToCpp ident

441 valueToCpp (Literal _ (NumericLiteral n)) = return (CppNumericLiteral n)

367 valueToCpp (Literal _ (NumericLiteral n)) = return (CppNumericLiteral n)

442 valueToCpp (Literal _ (StringLiteral s)) = return (CppStringLiteral s)

368 valueToCpp (Literal _ (StringLiteral s)) = return (CppStringLiteral s)

@@ -500,32 +426,8 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do

500 valueToCpp (Let _ ds val) = do

426 valueToCpp (Let _ ds val) = do

501 ds' <- concat <$> mapM (bindToCpp []) ds

427 ds' <- concat <$> mapM (bindToCpp []) ds

502 ret <- valueToCpp val

428 ret <- valueToCpp val

503− opts <- ask

504− let ds'' = tco opts <$> ds'

505− let rs =

506− if hasRecursion ds''

507− then convertRecursiveFns ds'' ret

508− else ds''

509− let cpps = innerLambdas <$> rs

429+ let cpps = (innerLambdas <$> ds') ++ [CppReturn ret]

510− return $ CppApp (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret]))) []

430+ return $ CppApp (CppLambda [] [] Nothing (CppBlock cpps)) []

511− where

512− hasRecursion :: [Cpp] -> Bool

513− hasRecursion cpps' = any (everythingOnCpp (||) hasRecursiveRef) cpps'

514− where

515− valnames :: [Text]

516− valnames = concatMap (everythingOnCpp (++) valname) cpps'

517− valname :: Cpp -> [Text]

518− valname (CppFunction name _ _ _ _) = [name]

519− valname (CppVariableIntroduction (name, _) _ _) = [name]

520− valname _ = []

521− hasRecursiveRef :: Cpp -> Bool

522− hasRecursiveRef (CppFunction _ _ _ _ body) = everythingOnCpp (||) ref body

523− hasRecursiveRef (CppVariableIntroduction _ _ (Just value)) = everythingOnCpp (||) ref value

524− hasRecursiveRef _ = False

525− ref :: Cpp -> Bool

526− ref (CppVar name)

527− | name `elem` valnames = True

528− ref _ = False

529 valueToCpp Constructor {} = return CppNoOp

431 valueToCpp Constructor {} = return CppNoOp

530

432

531 -- |

433 -- |

src/Language/PureScript/CodeGen/Cpp/Optimizer/TCO.hs+35−31

@@ -48,10 +48,9 @@ tco' = everywhereOnCpp convert

48 copyVar' (arg, t) = (copyVar arg, t)

50 convert :: Cpp -> Cpp

51−

52− convert cpp@(CppVariableIntroduction (name, ty) qs (Just fn@CppLambda {})) =

51+ convert cpp@(CppVariableIntroduction (name, ty) qs (Just lambda@CppLambda {})) =

53 let

52 let

54− (argss, body', replace) = collectAllFunctionArgs [] id fn

53+ (argss, body', replace) = collectAllLambdaArgs [] id lambda

55 in case () of

54 in case () of

56 _ | isTailCall name body' ->

55 _ | isTailCall name body' ->

57 let

56 let

@@ -59,29 +58,34 @@ tco' = everywhereOnCpp convert

59 in

58 in

60 CppVariableIntroduction (name, ty) qs (Just (replace (toLoop name allArgs body')))

59 CppVariableIntroduction (name, ty) qs (Just (replace (toLoop name allArgs body')))

61 | otherwise -> cpp

60 | otherwise -> cpp

62−

63− convert fn@(CppFunction name (_:_) _ _ _) =

61+ convert cpp@(CppFunction name _ _ _ _) =

64 let

62 let

65− (argss, body', replace) = collectAllFunctionArgs [] id fn

63+ (argss, body', replace) = collectAllFunctionArgs [] id cpp

66 in case () of

64 in case () of

67 _ | isTailCall name body' ->

65 _ | isTailCall name body' ->

68 let

66 let

69 allArgs = fst <$> (concat $ reverse argss)

67 allArgs = fst <$> (concat $ reverse argss)

70 in

68 in

71 replace (toLoop name allArgs body')

69 replace (toLoop name allArgs body')

72− | otherwise -> fn

70+ | otherwise -> cpp

73−

74 convert cpp = cpp

71 convert cpp = cpp

76− collectAllFunctionArgs :: [[(Text, Maybe CppType)]] -> (Cpp -> Cpp) -> Cpp -> ([[(Text, Maybe CppType)]], Cpp, Cpp -> Cpp)

73+ collectAllLambdaArgs :: [[(Text, Maybe CppType)]] -> (Cpp -> Cpp) -> Cpp -> ([[(Text, Maybe CppType)]], Cpp, Cpp -> Cpp)

77− collectAllFunctionArgs allArgs f (CppFunction ident args rty qs (CppBlock (body@(CppReturn _):_))) =

74+ collectAllLambdaArgs allArgs f (CppLambda cs args rty (CppBlock (body@(CppReturn _):_))) =

78− collectAllFunctionArgs (args : allArgs) (\b -> f (CppFunction ident (map copyVar' args) rty qs (CppBlock [b]))) body

75+ collectAllLambdaArgs (args : allArgs) (\b -> f (CppLambda cs (map copyVar' args) rty (CppBlock [b]))) body

79− collectAllFunctionArgs allArgs f (CppFunction ident args rty qs body@(CppBlock _)) =

76+ collectAllLambdaArgs allArgs f (CppLambda cs args rty body@(CppBlock _)) =

80− (args : allArgs, body, f . CppFunction ident (map copyVar' args) rty qs)

77+ (args : allArgs, body, f . CppLambda cs (map copyVar' args) rty)

81− collectAllFunctionArgs allArgs f (CppReturn (CppLambda cs args rty (CppBlock [body]))) =

78+ collectAllLambdaArgs allArgs f (CppReturn (CppLambda cs args rty (CppBlock [body]))) =

82− collectAllFunctionArgs (args : allArgs) (\b -> f (CppReturn (CppLambda cs (map copyVar' args) rty (CppBlock [b])))) body

79+ collectAllLambdaArgs (args : allArgs) (\b -> f (CppReturn (CppLambda cs (map copyVar' args) rty (CppBlock [b])))) body

83− collectAllFunctionArgs allArgs f (CppReturn (CppLambda cs args rty body@(CppBlock _))) =

80+ collectAllLambdaArgs allArgs f (CppReturn (CppLambda cs args rty body@(CppBlock _))) =

84 (args : allArgs, body, f . CppReturn . CppLambda cs (map copyVar' args) rty)

81 (args : allArgs, body, f . CppReturn . CppLambda cs (map copyVar' args) rty)

82+ collectAllLambdaArgs allArgs f body = (allArgs, body, f)

83+

84+ collectAllFunctionArgs :: [[(Text, Maybe CppType)]] -> (Cpp -> Cpp) -> Cpp -> ([[(Text, Maybe CppType)]], Cpp, Cpp -> Cpp)

85+ collectAllFunctionArgs allArgs f (CppFunction name args rty qs (CppBlock (body@(CppReturn _):_))) =

86+ collectAllFunctionArgs (args : allArgs) (\b -> f (CppFunction name (map copyVar' args) rty qs (CppBlock [b]))) body

87+ collectAllFunctionArgs allArgs f (CppFunction name args rty qs body@(CppBlock _)) =

88+ (args : allArgs, body, f . CppFunction name (map copyVar' args) rty qs)

85 collectAllFunctionArgs allArgs f body = (allArgs, body, f)

89 collectAllFunctionArgs allArgs f body = (allArgs, body, f)

87 isTailCall :: Text -> Cpp -> Bool

91 isTailCall :: Text -> Cpp -> Bool

@@ -107,15 +111,26 @@ tco' = everywhereOnCpp convert

107

111

108 countSelfCallsUnderFunctions :: Cpp -> Int

112 countSelfCallsUnderFunctions :: Cpp -> Int

109 countSelfCallsUnderFunctions (CppFunction _ _ _ _ cpp') = everythingOnCpp (+) countSelfCalls cpp'

113 countSelfCallsUnderFunctions (CppFunction _ _ _ _ cpp') = everythingOnCpp (+) countSelfCalls cpp'

110− countSelfCallsUnderFunctions (CppLambda _ (_:_) _ cpp') = everythingOnCpp (+) countSelfCalls cpp'

114+ countSelfCallsUnderFunctions (CppLambda _ _ _ cpp') = everythingOnCpp (+) countSelfCalls cpp'

111 countSelfCallsUnderFunctions _ = 0

115 countSelfCallsUnderFunctions _ = 0

112

116

113 countSelfCallsWithFnArgs :: Cpp -> Int

117 countSelfCallsWithFnArgs :: Cpp -> Int

114− countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0

118+ countSelfCallsWithFnArgs = go [] where

119+ go acc (CppVar ident')

120+ | ident == ident' && any hasFunction acc = 1

121+ go acc (CppApp fn args) = go (args ++ acc) fn

122+ go _ _ = 0

123+

124+ hasFunction :: Cpp -> Bool

125+ hasFunction = Monoid.getAny . everythingOnCpp mappend (Monoid.Any . isFunction)

126+ where

127+ isFunction (CppFunction {}) = True

128+ isFunction (CppLambda {}) = True

129+ isFunction _ = False

115

130

116 toLoop :: Text -> [Text] -> Cpp -> Cpp

131 toLoop :: Text -> [Text] -> Cpp -> Cpp

117 toLoop ident allArgs cpp = CppBlock $

132 toLoop ident allArgs cpp = CppBlock $

118− map (\arg -> CppVariableIntroduction (arg, Just $ Any []) [] (Just (CppVar (copyVar arg)))) allArgs ++

133+ map (\arg -> CppVariableIntroduction (arg, alwaysType (Auto [])) [] (Just (CppVar (copyVar arg)))) allArgs ++

119 [ CppWhile (CppBooleanLiteral True) (CppBlock loop) ]

134 [ CppWhile (CppBooleanLiteral True) (CppBlock loop) ]

120 where

135 where

121 loop :: [Cpp]

136 loop :: [Cpp]

@@ -129,7 +144,7 @@ tco' = everywhereOnCpp convert

129 allArgumentValues = concat $ collectSelfCallArgs [] ret

144 allArgumentValues = concat $ collectSelfCallArgs [] ret

130 in

145 in

131 CppBlock $ zipWith (\val arg ->

146 CppBlock $ zipWith (\val arg ->

132− CppVariableIntroduction (tcoVar arg, Just $ Any [Const]) [] (Just val)) allArgumentValues allArgs

147+ CppVariableIntroduction (tcoVar arg, alwaysType (Auto [Const])) [] (Just val)) allArgumentValues allArgs

133 ++ map (\arg ->

148 ++ map (\arg ->

134 CppAssignment (CppVar arg) (CppVar (tcoVar arg))) allArgs

149 CppAssignment (CppVar arg) (CppVar (tcoVar arg))) allArgs

135 ++ [ CppContinue ]

150 ++ [ CppContinue ]

@@ -142,14 +157,3 @@ tco' = everywhereOnCpp convert

142 isSelfCall ident (CppApp (CppVar ident') _) = ident == ident'

157 isSelfCall ident (CppApp (CppVar ident') _) = ident == ident'

143 isSelfCall ident (CppApp fn _) = isSelfCall ident fn

158 isSelfCall ident (CppApp fn _) = isSelfCall ident fn

144 isSelfCall _ _ = False

159 isSelfCall _ _ = False

145−

146− isSelfCallWithFnArgs :: Text -> Cpp -> [Cpp] -> Bool

147− isSelfCallWithFnArgs ident (CppVar ident') args | ident == ident' && any hasFunction args = True

148− isSelfCallWithFnArgs ident (CppApp fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)

149− isSelfCallWithFnArgs _ _ _ = False

150−

151− hasFunction :: Cpp -> Bool

152− hasFunction = Monoid.getAny . everythingOnCpp mappend (Monoid.Any . isFunction)

153− where

154− isFunction (CppFunction {}) = True

155− isFunction _ = False

src/Language/PureScript/CodeGen/Cpp/Recursion.hsnew file+139

@@ -0,0 +1,139 @@

1+---------------------------------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CodeGen.Cpp.Recursion

5+-- License : MIT

6+--

7+-- Maintainer : Andy Arvanitis <andy.arvanitis@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+--

12+---------------------------------------------------------------------------------------------------

13+{-# LANGUAGE PatternGuards #-}

14+

15+module Language.PureScript.CodeGen.Cpp.Recursion

16+ ( convertRecursiveRefs

17+ ) where

18+

19+import Prelude.Compat

20+import Data.List

21+import Data.Maybe (fromJust)

22+import Data.Text (Text)

23+

24+import Language.PureScript.CodeGen.Cpp.AST as AST

25+import Language.PureScript.CodeGen.Cpp.File

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

27+import Language.PureScript.Comments (Comment(..))

28+

29+-------------------------------------------------------------------------------------------------

30+convertRecursiveRefs :: Cpp -> Cpp

31+-------------------------------------------------------------------------------------------------

32+convertRecursiveRefs = everywhereOnCpp go

33+ where

34+ go :: Cpp -> Cpp

35+ go (CppFunction name args rty qs (CppBlock cpps)) =

36+ CppFunction name args rty qs (CppBlock (convertRecursive cpps))

37+ go (CppLambda cs args rty (CppBlock cpps)) =

38+ CppLambda cs args rty (CppBlock (convertRecursive cpps))

39+ go cpp = cpp

40+ convertRecursive :: [Cpp] -> [Cpp]

41+ convertRecursive cpps

42+ | hasRecursion cpps

43+ = convertRecursiveRefs' cpps

44+ where

45+ hasRecursion :: [Cpp] -> Bool

46+ hasRecursion cpps' = any (everythingOnCpp (||) hasRecursiveRef) cpps'

47+ where

48+ valnames :: [Text]

49+ valnames = concatMap (everythingOnCpp (++) valname) cpps'

50+ valname :: Cpp -> [Text]

51+ valname (CppFunction name' _ _ _ _) = [name']

52+ valname (CppVariableIntroduction (name', _) _ _) = [name']

53+ valname _ = []

54+ hasRecursiveRef :: Cpp -> Bool

55+ hasRecursiveRef (CppFunction _ _ _ _ body) = everythingOnCpp (||) ref body

56+ hasRecursiveRef (CppVariableIntroduction _ _ (Just value)) = everythingOnCpp (||) ref value

57+ hasRecursiveRef _ = False

58+ ref :: Cpp -> Bool

59+ ref (CppVar name')

60+ | name' `elem` valnames = True

61+ ref _ = False

62+ convertRecursive cpp = cpp

63+

64+-------------------------------------------------------------------------------------------------

65+convertRecursiveRefs' :: [Cpp] -> [Cpp]

66+-------------------------------------------------------------------------------------------------

67+convertRecursiveRefs' cpps

68+ | not $ null fns = dict : (accessor topdict <$> filteredFns allCpps) ++ cpps'

69+ where

70+ cpps' = everywhereOnCpp removeRec <$> cpps

71+ allCpps = CppBlock cpps'

72+ fns :: [(Text, Cpp)]

73+ fns = toelem <$> concatMap (everythingOnCpp (++) recursive) cpps

74+ filteredFns :: Cpp -> [(Text, Cpp)]

75+ filteredFns cpp = filter (\(f, _) -> everythingOnCpp (||) (== CppVar f) cpp) fns

76+ recursive :: Cpp -> [Cpp]

77+ recursive cpp'@(CppFunction _ _ _ qs _)

78+ | Recursive `elem` qs = [cpp']

79+ recursive cpp'@(CppVariableIntroduction _ qs _)

80+ | Recursive `elem` qs = [cpp']

81+ recursive _ = []

82+ removeRec :: Cpp -> Cpp

83+ removeRec (CppFunction _ _ _ qs _)

84+ | Recursive `elem` qs = CppNoOp

85+ removeRec (CppVariableIntroduction _ qs _)

86+ | Recursive `elem` qs = CppNoOp

87+ removeRec cpp' = cpp'

88+ replaceVar :: [(Text, Cpp)] -> Cpp -> Cpp

89+ replaceVar rs = go

90+ where

91+ go (CppVar var)

92+ | Just var' <- lookup var rs = var'

93+ go cpp' = cpp'

94+ dict :: Cpp

95+ dict =

96+ CppVariableIntroduction

97+ (topdict, Just $ Any [Const])

98+ []

99+ (Just $ CppDataLiteral ((\(f, cpp) -> CppComment [LineComment f] cpp) <$> fns))

100+ accessed :: Text -> Text -> (Text, Cpp)

101+ accessed dictname name =

102+ ( name

103+ , CppApp

104+ (CppDataGet

105+ (CppNumericLiteral . Left . fromIntegral . fromJust $ findIndex ((== name) . fst) fns)

106+ dict')

107+ [dict'])

108+ where

109+ dict' = CppVar dictname

110+ accessor :: Text -> (Text, Cpp) -> Cpp

111+ accessor dictname (name, _) =

112+ CppVariableIntroduction (name, Just $ Any [Const]) [] (Just . snd $ accessed dictname name)

113+ toelem :: Cpp -> (Text, Cpp)

114+ toelem (CppFunction name args rtyp _ body'@(CppBlock body)) =

115+ ( name

116+ , withdict . maybeRemCaps $

117+ CppLambda

118+ [CaptureAll]

119+ args

120+ rtyp

121+ (CppBlock $ (accessor localdict <$> filteredFns body') ++ body))

122+ toelem (CppVariableIntroduction (name, _) _ (Just body')) =

123+ let replacements = accessed localdict . fst <$> filteredFns body'

124+ replaced = everywhereOnCpp (replaceVar replacements) body'

125+ in (name, withdict . maybeRemCaps $ CppBlock [CppReturn replaced])

126+ toelem _ = error "not a function"

127+ withdict :: Cpp -> Cpp

128+ withdict cpp' =

129+ maybeRemCaps $

130+ CppLambda

131+ [CaptureAll]

132+ [(localdict, Just $ Any [Const, Ref])]

133+ (Just $ Any [])

134+ (CppBlock [CppReturn cpp'])

135+ topdict :: Text

136+ topdict = "_$dict$_"

137+ localdict :: Text

138+ localdict = "$dict$"

139+convertRecursiveRefs' cpps = cpps

src/Language/PureScript/CodeGen/Cpp/Types.hs+5

@@ -146,3 +146,8 @@ getCtor = dataNS <> "::ctor"

146

147constAnyRef :: Maybe CppType

148constAnyRef = Just $ Any [Const, Ref]

149+

150+-- Prevents any optimization changes to type

151+--

152+alwaysType :: CppType -> Maybe CppType

153+alwaysType t = Just . Primitive $ runType t