3451fc8 · rowtype-yoga/purescript-native

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

C++: optimize accessors for typeclass dicts

commit3451fc844c52bce8f0ecbe98c9131f1fbb4eb51b authorAndy Arvanitis <andyarvanitis@gmail.com> dateSat 9 Apr 2016, 20:07 (11 years ago) parent33205fe

4 files changed+55−12

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/Cpp.hs+37−11 src/Language/PureScript/CodeGen/Cpp/AST.hs+7 src/Language/PureScript/CodeGen/Cpp/File.hs+2−1 src/Language/PureScript/Pretty/Cpp.hs+9

src/Language/PureScript/CodeGen/Cpp.hs+37−11

@@ -42,6 +42,7 @@ import Language.PureScript.CodeGen.Cpp.File

4242import Language.PureScript.CodeGen.Cpp.Optimizer

4343import Language.PureScript.CodeGen.Cpp.Optimizer.TCO

4444import Language.PureScript.CodeGen.Cpp.Types

45+import Language.PureScript.Comments

4546import Language.PureScript.CoreFn

4647import Language.PureScript.Names

4748import Language.PureScript.Options

@@ -118,8 +119,10 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

118119 -------------------------------------------------------------------------------------------------

119120 declToCpp :: [CppValueQual] -> (Ann, Ident) -> Expr Ann -> m Cpp

120121 -------------------------------------------------------------------------------------------------

121− declToCpp _ _ (Abs (_, _, _, Just IsTypeClassConstructor) _ _) =

122− return CppNoOp

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

123+ let className = identToCpp ident

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

125+ in return $ CppStruct className [CppEnum Nothing Nothing (sort supers ++ members)]

123126

124127 declToCpp _ (_, Op _) (Var (_, _, Nothing, _) _) =

125128 return CppNoOp -- skip operator aliases

@@ -144,7 +147,7 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

144147 (arg' : args' ++ args'')

145148 rty

146149 (vqs ++ if isAccessor (snd abs') then [CppInline] else [])

147− (convertNestedLambdas block)

150+ (convertNestedLambdas $ convertDictIndexers block)

148151 , CppFunction

149152 (curriedName name)

150153 [arg']

@@ -163,12 +166,13 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

163166 [arg']

164167 rty

165168 (vqs ++ if isIndexer block then [CppInline] else [])

166− (convertNestedLambdas $ asReturnBlock block)

169+ (convertNestedLambdas . asReturnBlock $ convertDictIndexers block)

167170 return (CppComment com fn)

168171 where

169− argcnt | Just t <- ty = countArgs t

170− | Just (t, _, _) <- M.lookup (mn, ident) (E.names env) = countArgs t

171− | otherwise = 0

172+ ty' | Just t <- ty = Just t

173+ | Just (t, _, _) <- M.lookup (mn, ident) (E.names env) = Just t

174+ | otherwise = Nothing

175+ argcnt = maybe 0 countArgs ty'

172176 name = identToCpp ident

173177 aty = Just $ CppAny [CppConst, CppRef]

174178 rty = Just $ CppAny []

@@ -181,6 +185,10 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

181185 isIndexer :: Cpp -> Bool

182186 isIndexer (CppIndexer (CppStringLiteral _) (CppVar _)) = True

183187 isIndexer _ = False

188+ classes = qualifiedToCpp (Ident . runProperName) . fst <$>

189+ maybe [] extractConstraints ty'

190+ dictClasses = zip (CppVar . fst <$> arg' : args') classes

191+ convertDictIndexers = everywhereOnCpp (dictIndexerToEnum dictClasses)

184192

185193 declToCpp _ (_, ident) (Constructor _ _ (ProperName _) []) =

186194 return $

@@ -427,10 +435,6 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

427435 [(identToCpp arg, Just $ CppAny [CppConst, CppRef])]

428436 (Just $ CppAny [])

429437 (asReturnBlock cpp')

430−

431− -- valueToCpp (App _ e (Var _ (Qualified (Just (ModuleName [ProperName "Prim"])) (Ident "undefined")))) =

432− -- valueToCpp e

433−

434438 valueToCpp e@App{} = do

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

436440 args' <- mapM valueToCpp args

@@ -838,6 +842,28 @@ countArgs = go 0

838842 go argcnt (T.ConstrainedType ts t) = go (argcnt + length ts) t

839843 go argcnt _ = argcnt

840844

845+---------------------------------------------------------------------------------------------------

846+extractConstraints :: T.Type -> [T.Constraint]

847+---------------------------------------------------------------------------------------------------

848+extractConstraints = go []

849+ where

850+ go cs (T.ForAll _ t _) = go cs t

851+ go cs (T.TypeApp (T.TypeApp fn _) t) | fn == E.tyFunction = go cs t

852+ go cs (T.ConstrainedType ts t) = go (cs ++ ts) t

853+ go cs _ = cs

854+

855+---------------------------------------------------------------------------------------------------

856+dictIndexerToEnum :: [(Cpp,Cpp)] -> Cpp -> Cpp

857+---------------------------------------------------------------------------------------------------

858+dictIndexerToEnum repls (CppIndexer (CppStringLiteral prop) dict)

859+ | Just cls <- lookup dict repls =

860+ CppBinary Dot

861+ (CppIndexer

862+ (CppAccessor (CppVar . identToCpp $ Ident prop) cls)

863+ (CppCast mapType dict))

864+ (CppVar "second")

865+dictIndexerToEnum _ cpp = cpp

866+

841867---------------------------------------------------------------------------------------------------

842868curriedName :: String -> String

843869---------------------------------------------------------------------------------------------------

src/Language/PureScript/CodeGen/Cpp/AST.hs+7

@@ -218,6 +218,10 @@ data Cpp

218218 --

219219 | CppNamespace String [Cpp]

220220 -- |

221+ -- An C++ struct declaration (name, members)

222+ --

223+ | CppStruct String [Cpp]

224+ -- |

221225 -- A C++ #include

222226 --

223227 | CppInclude String String

@@ -300,6 +304,7 @@ everywhereOnCpp f = go

300304 go (CppApp j cpp) = f (CppApp (go j) (map go cpp))

301305 go (CppBlock cpp) = f (CppBlock (map go cpp))

302306 go (CppNamespace name cpp) = f (CppNamespace name (map go cpp))

307+ go (CppStruct name cpp) = f (CppStruct name (map go cpp))

303308 go (CppVariableIntroduction name qs j) = f (CppVariableIntroduction name qs (fmap go j))

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

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

@@ -330,6 +335,7 @@ everywhereOnCppTopDownM f = f >=> go

330335 go (CppApp j cpp) = CppApp <$> f' j <*> traverse f' cpp

331336 go (CppBlock cpp) = CppBlock <$> traverse f' cpp

332337 go (CppNamespace name cpp) = CppNamespace name <$> traverse f' cpp

338+ go (CppStruct name cpp) = CppStruct name <$> traverse f' cpp

333339 go (CppVariableIntroduction name qs j) = CppVariableIntroduction name qs <$> traverse f' j

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

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

@@ -356,6 +362,7 @@ everythingOnCpp (<>) f = go

356362 go j@(CppApp j1 cpp) = foldl (<>) (f j <> go j1) (map go cpp)

357363 go j@(CppBlock cpp) = foldl (<>) (f j) (map go cpp)

358364 go j@(CppNamespace _ cpp) = foldl (<>) (f j) (map go cpp)

365+ go j@(CppStruct _ cpp) = foldl (<>) (f j) (map go cpp)

359366 go j@(CppVariableIntroduction _ _ (Just j1)) = f j <> go j1

360367 go j@(CppAssignment j1 j2) = f j <> go j1 <> go j2

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

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

@@ -51,6 +51,8 @@ toHeader = catMaybes . map go

5151 -- Generate thunks for top-level values

5252 go (CppVariableIntroduction (name, _) _ (Just _)) =

5353 Just $ CppVariableIntroduction (name, Just $ CppAny [CppConst]) [CppExtern] Nothing

54+ go cpp@(CppStruct {}) =

55+ Just cpp

5456 go (CppComment comms cpp')

5557 | Just cpp <- go cpp' = Just $ case cpp of CppFunction {} -> cpp

5658 _ -> CppComment comms cpp

@@ -76,7 +78,6 @@ toHeaderFns = catMaybes . map go

7678 Just cpp

7779 go cpp@(CppVariableIntroduction _ _ (Just CppBooleanLiteral {})) =

7880 Just cpp

79−

8081 go (CppComment comms cpp') | Just cpp <- go cpp' = Just (CppComment comms cpp)

8182 go _ = Nothing

8283

src/Language/PureScript/Pretty/Cpp.hs+9

@@ -193,6 +193,15 @@ literals = mkPattern' match

193193 isUseNamespace :: Cpp -> Bool

194194 isUseNamespace (CppUseNamespace{}) = True

195195 isUseNamespace _ = False

196+ match (CppStruct (name) mems) = fmap concat $ sequence $

197+ [ return "\n"

198+ , currentIndent

199+ , return $ "struct " ++ name ++ " {\n"

200+ , withIndent $ prettyStatements mems

201+ , return "\n"

202+ , currentIndent

203+ , return "}"

204+ ]

196205 match (CppInclude path name) =

197206 let fullpath

198207 | null path = last . words . dotsTo ' ' $ name