3451fc8 · rowtype-yoga/purescript-native

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

on golang help sign in

C++: optimize accessors for typeclass dicts

3451fc8Andy Arvanitis11 years ago

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

compare with golang

unifiedsplit

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

42import Language.PureScript.CodeGen.Cpp.Optimizer

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

44import Language.PureScript.CodeGen.Cpp.Types

45+import Language.PureScript.Comments

45import Language.PureScript.CoreFn

46import Language.PureScript.CoreFn

46import Language.PureScript.Names

47import Language.PureScript.Names

47import Language.PureScript.Options

48import Language.PureScript.Options

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

118 -------------------------------------------------------------------------------------------------

119 -------------------------------------------------------------------------------------------------

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

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

120 -------------------------------------------------------------------------------------------------

121 -------------------------------------------------------------------------------------------------

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

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

122− return CppNoOp

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

123

126

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

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

125 return CppNoOp -- skip operator aliases

128 return CppNoOp -- skip operator aliases

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

144 (arg' : args' ++ args'')

147 (arg' : args' ++ args'')

145 rty

148 rty

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

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

147− (convertNestedLambdas block)

150+ (convertNestedLambdas $ convertDictIndexers block)

148 , CppFunction

151 , CppFunction

149 (curriedName name)

152 (curriedName name)

150 [arg']

153 [arg']

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

163 [arg']

166 [arg']

164 rty

167 rty

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

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

166− (convertNestedLambdas $ asReturnBlock block)

169+ (convertNestedLambdas . asReturnBlock $ convertDictIndexers block)

167 return (CppComment com fn)

170 return (CppComment com fn)

168 where

171 where

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

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

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

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

171− | otherwise = 0

174+ | otherwise = Nothing

175+ argcnt = maybe 0 countArgs ty'

172 name = identToCpp ident

176 name = identToCpp ident

173 aty = Just $ CppAny [CppConst, CppRef]

177 aty = Just $ CppAny [CppConst, CppRef]

174 rty = Just $ CppAny []

178 rty = Just $ CppAny []

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

181 isIndexer :: Cpp -> Bool

185 isIndexer :: Cpp -> Bool

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

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

183 isIndexer _ = False

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

184

192

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

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

186 return $

194 return $

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

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

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

428 (Just $ CppAny [])

436 (Just $ CppAny [])

429 (asReturnBlock cpp')

437 (asReturnBlock cpp')

430−

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

432− -- valueToCpp e

433−

434 valueToCpp e@App{} = do

438 valueToCpp e@App{} = do

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

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

436 args' <- mapM valueToCpp args

440 args' <- mapM valueToCpp args

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

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

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

839 go argcnt _ = argcnt

843 go argcnt _ = argcnt

840

844

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+

841---------------------------------------------------------------------------------------------------

867---------------------------------------------------------------------------------------------------

842curriedName :: String -> String

868curriedName :: String -> String

843---------------------------------------------------------------------------------------------------

869---------------------------------------------------------------------------------------------------

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

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

218 --

219 | CppNamespace String [Cpp]

220 -- |

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

222+ --

223+ | CppStruct String [Cpp]

224+ -- |

221 -- A C++ #include

225 -- A C++ #include

222 --

226 --

223 | CppInclude String String

227 | CppInclude String String

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

368 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

51 -- Generate thunks for top-level values

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

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

54+ go cpp@(CppStruct {}) =

55+ Just cpp

54 go (CppComment comms cpp')

56 go (CppComment comms cpp')

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

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

56 _ -> CppComment comms cpp

58 _ -> CppComment comms cpp

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

76 Just cpp

78 Just cpp

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

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

78 Just cpp

80 Just cpp

79−

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

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

81 go _ = Nothing

82 go _ = Nothing

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

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

193 isUseNamespace :: Cpp -> Bool

194 isUseNamespace (CppUseNamespace{}) = True

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

196 match (CppInclude path name) =

205 match (CppInclude path name) =

197 let fullpath

206 let fullpath

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

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