9cdc997 · rowtype-yoga/purescript-native

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

on golang help sign in

C++: move uncurried calls to optimizer

9cdc997Andy Arvanitis10 years ago

purescript.cabal+1

compare with golang

unifiedsplit

@@ -182,6 +182,7 @@ library

182 Language.PureScript.CodeGen.Cpp.Optimizer.Inliner

183 Language.PureScript.CodeGen.Cpp.Optimizer.MagicDo

184 Language.PureScript.CodeGen.Cpp.Optimizer.TCO

185+ Language.PureScript.CodeGen.Cpp.Optimizer.Uncurry

185 Language.PureScript.CodeGen.Cpp.Optimizer.Unused

186 Language.PureScript.CodeGen.Cpp.Optimizer.Unused

186 Language.PureScript.CodeGen.Cpp.Types

187 Language.PureScript.CodeGen.Cpp.Types

187 Language.PureScript.Pretty.Cpp

188 Language.PureScript.Pretty.Cpp

src/Language/PureScript/CodeGen/Cpp.hs+22−43

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

71 (snd <$> imps)

72 let cppImports' = "PureScript" : cppImports

73 cppDecls <- concat <$> mapM (bindToCpp [CppTopLevel]) decls

74+ let namesmap = M.toList .

75+ M.mapKeysMonotonic (qualifiedToCpp id) . M.map (\(t, _, _) -> arity t) $

76+ E.names env

77+ datamap = M.toList .

78+ M.mapKeysMonotonic (qualifiedToCpp (Ident . runProperName)) .

79+ M.map (\(_, _, _, fields) -> length fields) $

80+ E.dataConstructors env

74− cppDecls' <- traverse optimize cppDecls

81+ cppDecls' <- traverse (optimize $ namesmap ++ datamap) cppDecls

75 foreignWrappers <- curriedForeigns

82 foreignWrappers <- curriedForeigns

76 let optimized = cppDecls' ++ foreignWrappers

83 let optimized = cppDecls' ++ foreignWrappers

77 let moduleHeader =

84 let moduleHeader =

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

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

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

128

135

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

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

130− fn <- if arity' > 1 && CppTopLevel `elem` vqs

137+ fn <- if CppTopLevel `elem` vqs

131 then do

138 then do

132 argNames <- replicateM (arity' - length args' - 1) freshName

139 argNames <- replicateM (arity' - length args' - 1) freshName

133 let args'' = zip argNames (repeat aty)

140 let args'' = zip argNames (repeat aty)

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

151 (curriedName name)

158 (curriedName name)

152 [arg']

159 [arg']

153 rty

160 rty

154− []

161+ (if arity' == 1 then [CppInline] else [])

155 (asReturnBlock $

162 (asReturnBlock $

156 curriedLambda

163 curriedLambda

157 (fst <$> args' ++ args'')

164 (fst <$> args' ++ args'')

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

210 CppDataLiteral $

217 CppDataLiteral $

211 CppAccessor (CppVar name) (CppVar "data") : (CppVar <$> fields'))

218 CppAccessor (CppVar name) (CppVar "data") : (CppVar <$> fields'))

212 ] ++

219 ] ++

213− if length fields > 1

220+ if length fields > 0

214 then

221 then

215 [ CppFunction

222 [ CppFunction

216 (curriedName name)

223 (curriedName name)

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

263 rty

270 rty

264 []

271 []

265 (asReturnBlock block)

272 (asReturnBlock block)

266− ] ++ if arity' > 1

273+ ] ++ if arity' > 0

267 then [fn']

274 then [fn']

268 else []

275 else []

269 where

276 where

@@ -387,17 +394,14 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

387 -------------------------------------------------------------------------------------------------

394 -------------------------------------------------------------------------------------------------

388 valueToCpp :: Expr Ann -> m Cpp

395 valueToCpp :: Expr Ann -> m Cpp

389 -------------------------------------------------------------------------------------------------

396 -------------------------------------------------------------------------------------------------

390− valueToCpp (Var (_, _, _, Just (IsConstructor _ [])) ident) =

397+ valueToCpp (Var (_, _, _, Just IsNewtype) ident) =

391− return $ CppApp (varToCpp ident) []

392−

393− valueToCpp (Var (_, _, _, Just (IsConstructor _ [_])) ident) =

394 return $ varToCpp ident

398 return $ varToCpp ident

395

399

396− valueToCpp (Var (_, _, _, Just (IsConstructor _ _)) ident) =

400+ valueToCpp (Var (_, _, _, Just (IsConstructor _ [])) ident) =

397− return . curriedName' $ varToCpp ident

401+ return $ CppApp (varToCpp ident) []

398

402

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

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

400− | arity ty > 1 =

404+ | arity ty > 0 =

401 return . curriedName' $ varToCpp ident

405 return . curriedName' $ varToCpp ident

402

406

403 valueToCpp (Var _ ident) =

407 valueToCpp (Var _ ident) =

@@ -460,34 +464,16 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

460 args' <- mapM valueToCpp args

464 args' <- mapM valueToCpp args

461 case f of

465 case f of

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

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

463− Var (_, _, _, Just (IsConstructor _ fields)) ident

464− | length args == length fields ->

465− return $ CppApp (uncurried' $ qualifiedToCpp id ident) args'

466 Var (_, _, _, Just IsTypeClassConstructor) (Qualified mn' (Ident classname)) ->

467 Var (_, _, _, Just IsTypeClassConstructor) (Qualified mn' (Ident classname)) ->

467 let Just (_, constraints, fns) = findClass (Qualified mn' (ProperName classname)) in

468 let Just (_, constraints, fns) = findClass (Qualified mn' (ProperName classname)) in

468 return . CppObjectLiteral CppInstance $

469 return . CppObjectLiteral CppInstance $

469 zip

470 zip

470 ((sort $ superClassDictionaryNames constraints) ++ (fst <$> fns))

471 ((sort $ superClassDictionaryNames constraints) ++ (fst <$> fns))

471 args'

472 args'

472− Var ann (Qualified (Just mn') ident)

473+ Var _ (Qualified (Just _) _) -> applied f args' curriedName'

473− | arity' <- maybe 0 arity ty,

474+ _ -> applied f args' id

474− arity' > 1 -> do

475− f' <- valueToCpp f

476− let (uncurriedArgs, curriedArgs) =

477− if length args' >= arity'

478− then splitAt arity' args'

479− else ([], args')

480− fn' =

481− if null uncurriedArgs

482− then curriedName' f'

483− else CppApp (uncurried' f') uncurriedArgs

484− return $ foldl (\fn a -> CppApp fn [a]) fn' curriedArgs

485− where

475+ where

486− ty | (_, _, Just t, _) <- ann = Just t

487− | Just (t, _, _) <- M.lookup (Qualified (Just mn') ident) (E.names env) = Just t

488− | otherwise = Nothing

489− _ ->

490− flip (foldl (\fn a -> CppApp fn [a])) args' <$> valueToCpp f

476+ applied f args g = flip (foldl (\fn a -> CppApp (g fn) [a])) args <$> valueToCpp f

491

477

492 valueToCpp (Case (maybeSpan, _, ty, _) values binders) = do

478 valueToCpp (Case (maybeSpan, _, ty, _) values binders) = do

493 vals <- mapM valueToCpp values

479 vals <- mapM valueToCpp values

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

792 where

778 where

793 go (ident, ty)

779 go (ident, ty)

794 | arity' <- arity ty,

780 | arity' <- arity ty,

795− arity' > 1 = do

781+ arity' > 0 = do

796 let name = identToCpp ident

782 let name = identToCpp ident

797 argNames <- replicateM arity' freshName

783 argNames <- replicateM arity' freshName

798 return $

784 return $

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

800 (curriedName name)

786 (curriedName name)

801 [(head argNames, Just $ CppAny [CppConst, CppRef])]

787 [(head argNames, Just $ CppAny [CppConst, CppRef])]

802 (Just $ CppAny [])

788 (Just $ CppAny [])

803− []

789+ (if arity' == 1 then [CppInline] else [])

804 (asReturnBlock $

790 (asReturnBlock $

805 curriedLambda

791 curriedLambda

806 (tail argNames)

792 (tail argNames)

@@ -876,13 +862,6 @@ curriedName :: String -> String

876curriedName name@('$' : _) = name

862curriedName name@('$' : _) = name

877curriedName name = '$' : name

863curriedName name = '$' : name

878

864

879−---------------------------------------------------------------------------------------------------

880−uncurried' :: Cpp -> Cpp

881−---------------------------------------------------------------------------------------------------

882−uncurried' (CppVar ('$':name)) = CppVar name

883−uncurried' (CppAccessor a b) = CppAccessor (uncurried' a) b

884−uncurried' cpp = cpp

885−

886---------------------------------------------------------------------------------------------------

865---------------------------------------------------------------------------------------------------

887curriedName' :: Cpp -> Cpp

866curriedName' :: Cpp -> Cpp

888---------------------------------------------------------------------------------------------------

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

src/Language/PureScript/CodeGen/Cpp/Optimizer.hs+7−5

@@ -55,23 +55,25 @@ import Language.PureScript.CodeGen.Cpp.Optimizer.Common

55import Language.PureScript.CodeGen.Cpp.Optimizer.Inliner

56import Language.PureScript.CodeGen.Cpp.Optimizer.MagicDo

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

58+import Language.PureScript.CodeGen.Cpp.Optimizer.Uncurry

58import Language.PureScript.CodeGen.Cpp.Optimizer.Unused

59import Language.PureScript.CodeGen.Cpp.Optimizer.Unused

60-- |

61-- |

61-- Apply a series of optimizer passes to simplified C++11 code

62-- Apply a series of optimizer passes to simplified C++11 code

62--

63--

63−optimize :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => Cpp -> m Cpp

64+optimize :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => NamesMap -> Cpp -> m Cpp

64−optimize cpp = do

65+optimize nm cpp = do

65 noOpt <- asks optionsNoOptimizations

66 noOpt <- asks optionsNoOptimizations

66− if noOpt then return cpp else optimize' cpp

67+ if noOpt then return cpp else optimize' nm cpp

68−optimize' :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => Cpp -> m Cpp

69+optimize' :: (Monad m, MonadReader Options m, Applicative m, MonadSupply m) => NamesMap -> Cpp -> m Cpp

69−optimize' cpp = do

70+optimize' nm cpp = do

70 opts <- ask

71 opts <- ask

71 untilFixedPoint (inlineFnComposition . applyAll

72 untilFixedPoint (inlineFnComposition . applyAll

72 [ collapseNestedBlocks

73 [ collapseNestedBlocks

73 , collapseNestedIfs

74 , collapseNestedIfs

74 , collapseIfElses

75 , collapseIfElses

76+ , removeCurrying nm

75 , toAutoVars

77 , toAutoVars

76 , tco opts

78 , tco opts

77 , magicDo opts

79 , magicDo opts

src/Language/PureScript/CodeGen/Cpp/Optimizer/Inliner.hs+7

@@ -281,6 +281,13 @@ inlineFnComposition = everywhereOnCppTopDownM convert

281 | isFnComposeFlipped dict' fn = do

282 arg <- freshName

283 return $ CppLambda [CppCaptureAll] [(arg, constAnyRef)] Nothing (CppBlock [CppReturn $ CppApp y [CppApp x [CppVar arg]]])

284+ convert (CppApp (CppApp (CppApp fn [dict']) [x]) [y])

285+ | isFnCompose dict' fn = do

286+ arg <- freshName

287+ return $ CppLambda [CppCaptureAll] [(arg, constAnyRef)] Nothing (CppBlock [CppReturn $ CppApp x [CppApp y [CppVar arg]]])

288+ | isFnComposeFlipped dict' fn = do

289+ arg <- freshName

290+ return $ CppLambda [CppCaptureAll] [(arg, constAnyRef)] Nothing (CppBlock [CppReturn $ CppApp y [CppApp x [CppVar arg]]])

284 convert other = return other

291 convert other = return other

285 isFnCompose :: Cpp -> Cpp -> Bool

292 isFnCompose :: Cpp -> Cpp -> Bool

286 isFnCompose dict' fn = isDict semigroupoidFn dict' && isFn fnCompose fn

293 isFnCompose dict' fn = isDict semigroupoidFn dict' && isFn fnCompose fn

src/Language/PureScript/CodeGen/Cpp/Optimizer/Uncurry.hsnew file+49

@@ -0,0 +1,49 @@

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

2+--

3+-- Module : Language.PureScript.CodeGen.Cpp.Optimizer.Uncurry

4+-- Copyright : (c) Andy Arvanitis 2016

5+-- License : MIT

6+--

7+-- Maintainer : Andy Arvanitis

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Removes unused variables

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.CodeGen.Cpp.Optimizer.Uncurry where

17+

18+import Prelude.Compat

19+

20+import Language.PureScript.CodeGen.Cpp.AST

21+import qualified Language.PureScript.Types as T

22+

23+type NamesMap = [(Cpp, Int)]

24+

25+removeCurrying :: NamesMap -> Cpp -> Cpp

26+removeCurrying nm = everywhereOnCpp convert

27+ where

28+ convert cpp@(CppApp {})

29+ | (f, args@(_:_)) <- unApp cpp [],

30+ Just f' <- unCurried f,

31+ Just arity' <- lookup f' nm,

32+ arity' > 0 && length args >= arity' =

33+ foldl

34+ (\fn a -> CppApp fn [a])

35+ (CppApp f' (take arity' args))

36+ (drop arity' args)

37+ where

38+ unCurried :: Cpp -> Maybe Cpp

39+ unCurried (CppAccessor var mn)

40+ | Just var' <- unCurried var = Just $ CppAccessor var' mn

41+ unCurried (CppVar ('$':name)) = Just $ CppVar name

42+ unCurried _ = Nothing

43+ convert cpp = cpp

44+

45+-------------------------------------------------------------------------------------------------

46+unApp :: Cpp -> [Cpp] -> (Cpp, [Cpp])

47+-------------------------------------------------------------------------------------------------

48+unApp (CppApp val args) args' = unApp val (args ++ args')

49+unApp other args' = (other, args')