f93d365 · rowtype-yoga/purescript-native

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

C++: more agressive use of uncurried funcs (incl dicts)

commitf93d3652d39c30ac6c6df3440b3055b18f7b31a0 authorAndy Arvanitis <andyarvanitis@gmail.com> dateTue 23 Feb 2016, 22:05 (11 years ago) parent6d56ee3

4 files changed+52−37

compare with golang

unifiedsplit

src/Language/PureScript/CodeGen/Cpp.hs+28−36 src/Language/PureScript/CodeGen/Cpp/Common.hs+2−1 src/Language/PureScript/CodeGen/Cpp/Optimizer/Inliner.hs+14 src/Language/PureScript/CodeGen/Cpp/Optimizer/MagicDo.hs+8

src/Language/PureScript/CodeGen/Cpp.hs+28−36

@@ -52,8 +52,6 @@ import qualified Language.PureScript.Environment as E

5252import qualified Language.PureScript.Pretty.Cpp as P

5353import qualified Language.PureScript.Types as T

5454

55−-- import Debug.Trace

56−

5755-- |

5856-- Generate code in the simplified C++1x intermediate representation for all declarations in a

5957-- module.

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

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

121119 return CppNoOp -- skip operator aliases

122120

123− declToCpp _ ident (Abs _ arg@(Ident "dict")

124− body@(Accessor _ _ (Var _ (Qualified Nothing arg'))))

125− | arg' == arg = do

126− block <- asReturnBlock <$> valueToCpp body

127− let fn' = CppFunction

128− (identToCpp ident)

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

130− (Just $ CppAny [])

131− []

132− block

133− return fn'

134−

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

136− fn <- if argcnt > 0 && CppTopLevel `elem` vqs

122+ fn <- if argcnt > 1 && CppTopLevel `elem` vqs

137123 then do

138124 argNames <- replicateM (argcnt - length args' - 1) freshName

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

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

231217 block <- valueToCpp $

232218 curriedApp

233219 (tail argNames)

234− (App

235− (Nothing, [], Just ty, Nothing)

236− e

237− (Var nullAnn . Qualified Nothing . Ident $ head argNames))

220+ (App nullAnn e (Var nullAnn . Qualified Nothing . Ident $ head argNames))

238221 let fn' = CppFunction

239222 (curriedName name)

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

@@ -245,15 +228,16 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

245228 (tail argNames)

246229 (CppApp (CppVar name)

247230 (CppVar <$> argNames)))

248− return $ CppNamespace ""

231+ return $ CppNamespace "" $

249232 [ CppFunction

250233 name

251234 (zip argNames $ repeat aty)

252235 rty

253236 []

254237 (asReturnBlock block)

255− , fn'

256− ]

238+ ] ++ if argcnt > 1

239+ then [fn']

240+ else []

257241 where

258242 name = identToCpp ident

259243 aty = Just $ CppAny [CppConst, CppRef]

@@ -362,10 +346,10 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

362346 valueToCpp :: Expr Ann -> m Cpp

363347 -------------------------------------------------------------------------------------------------

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

365− return $ CppApp (CppVar $ qualifiedToStr' id ident) []

349+ return $ CppApp (varToCpp ident) []

366350

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

368− return . CppVar $ qualifiedToStr' id ident

352+ return $ varToCpp ident

369353

370354 valueToCpp (Var (_, _, _, Just (IsConstructor _ _)) ident) =

371355 return . curriedName' $ varToCpp ident

@@ -437,14 +421,23 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

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

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

439423 return . CppObjectLiteral $ zip ((sort $ superClassDictionaryNames constraints) ++ (fst <$> fns)) args'

440− Var (_, _, Just ty, _) (Qualified (Just _) _)

441− | argcnt <- countArgs ty,

442− argcnt > 1,

443− length args >= argcnt -> do

424+ Var ann (Qualified (Just mn') ident)

425+ | argcnt <- maybe 0 countArgs ty,

426+ argcnt > 1 -> do

444427 f' <- valueToCpp f

445− let (uncurArgs, curArgs) = splitAt argcnt args'

446− uncurApp = CppApp (uncurried' f') uncurArgs

447− return $ foldl (\fn a -> CppApp fn [a]) uncurApp curArgs

428+ let (uncurriedArgs, curriedArgs) =

429+ if length args' >= argcnt

430+ then splitAt argcnt args'

431+ else ([], args')

432+ fn' =

433+ if null uncurriedArgs

434+ then curriedName' f'

435+ else CppApp (uncurried' f') uncurriedArgs

436+ return $ foldl (\fn a -> CppApp fn [a]) fn' curriedArgs

437+ where

438+ ty | (_, _, Just t, _) <- ann = Just t

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

440+ | otherwise = Nothing

448441 _ ->

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

450443

@@ -788,18 +781,17 @@ curriedApp args vals = foldl (\val arg -> App

788781---------------------------------------------------------------------------------------------------

789782countArgs :: T.Type -> Int

790783---------------------------------------------------------------------------------------------------

791−countArgs = go 0 . T.everywhereOnTypes rmForAll

784+countArgs = go 0

792785 where

793− go argcnt (T.TypeApp (T.TypeApp fn _) (T.ConstrainedType _ _)) | fn == E.tyFunction = argcnt

786+ go argcnt (T.ForAll _ t _) = go argcnt t

794787 go argcnt (T.TypeApp (T.TypeApp fn _) t) | fn == E.tyFunction = go (argcnt + 1) t

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

795789 go argcnt _ = argcnt

796− rmForAll :: T.Type -> T.Type

797− rmForAll (T.ForAll _ t _) = t

798− rmForAll t = t

799790

800791---------------------------------------------------------------------------------------------------

801792curriedName :: String -> String

802793---------------------------------------------------------------------------------------------------

794+curriedName name@('$' : _) = name

803795curriedName name = '$' : name

804796

805797---------------------------------------------------------------------------------------------------

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

@@ -33,6 +33,7 @@ import Language.PureScript.Names

3333--

3434identToCpp :: Ident -> String

3535identToCpp (Ident name) | nameIsCppReserved name = '_' : name ++ "_"

36+identToCpp (Ident name@('$' : s)) | all isDigit s = name

3637identToCpp (Ident name) = concatMap identCharToString name

3738identToCpp (Op op) = concatMap identCharToString op

3839

@@ -50,7 +51,7 @@ identCharToString :: Char -> String

5051identCharToString c | isAlphaNum c = [c]

5152identCharToString '_' = "_"

5253identCharToString '.' = "_dot_"

53−identCharToString '$' = "$"

54+identCharToString '$' = "_dollar_"

5455identCharToString '~' = "_tilde_"

5556identCharToString '=' = "_eq_"

5657identCharToString '<' = "_less_"

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

@@ -109,11 +109,17 @@ inlineValues = everywhereOnCpp convert

109109 | isDict semiringInt dict && isFn fnOne fn = CppNumericLiteral (Left 1)

110110 | isDict boundedBoolean dict && isFn fnBottom fn = CppBooleanLiteral False

111111 | isDict boundedBoolean dict && isFn fnTop fn = CppBooleanLiteral True

112+ convert (CppApp fn [dict, x, y])

113+ | isDict semiringInt dict && isFn fnAdd fn = CppBinary Add x y

114+ | isDict semiringInt dict && isFn fnMultiply fn = CppBinary Multiply x y

115+ | isDict moduloSemiringInt dict && isFn fnDivide fn = CppBinary Divide x y

116+ | isDict ringInt dict && isFn fnSubtract fn = CppBinary Subtract x y

112117 convert (CppApp (CppApp (CppApp fn [dict]) [x]) [y])

113118 | isDict semiringInt dict && isFn fnAdd fn = CppBinary Add x y

114119 | isDict semiringInt dict && isFn fnMultiply fn = CppBinary Multiply x y

115120 | isDict moduloSemiringInt dict && isFn fnDivide fn = CppBinary Divide x y

116121 | isDict ringInt dict && isFn fnSubtract fn = CppBinary Subtract x y

122+

117123 convert other = other

118124 fnZero = (C.prelude, C.zero)

119125 fnOne = (C.prelude, C.one)

@@ -128,6 +134,7 @@ inlineOperator :: (String, String) -> (Cpp -> Cpp -> Cpp) -> Cpp -> Cpp

128134inlineOperator (m, op) f = everywhereOnCpp convert

129135 where

130136 convert :: Cpp -> Cpp

137+ convert (CppApp op' [x, y]) | isOp op' = f x y

131138 convert (CppApp (CppApp op' [x]) [y]) | isOp op' = f x y

132139 convert other = other

133140 isOp (CppAccessor (CppVar longForm) (CppVar m')) = m == m' && longForm == identToCpp (Op op)

@@ -188,6 +195,7 @@ inlineCommonOperators = applyAll $

188195 binary dict opString op = everywhereOnCpp convert

189196 where

190197 convert :: Cpp -> Cpp

198+ convert (CppApp fn [dict', x, y]) | isDict dict dict' && isPreludeFn opString fn = CppBinary op x y

191199 convert (CppApp (CppApp (CppApp fn [dict']) [CppStringLiteral x]) [CppStringLiteral y])

192200 | isDict dict dict' && isPreludeFn opString fn = CppStringLiteral (x ++ y)

193201 convert (CppApp (CppApp (CppApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = CppBinary op x y

@@ -196,18 +204,21 @@ inlineCommonOperators = applyAll $

196204 binary' moduleName opString op = everywhereOnCpp convert

197205 where

198206 convert :: Cpp -> Cpp

207+ convert (CppApp fn [x, y]) | isFn (moduleName, opString) fn = CppBinary op x y

199208 convert (CppApp (CppApp fn [x]) [y]) | isFn (moduleName, opString) fn = CppBinary op x y

200209 convert other = other

201210 binaryFunction :: (String, String) -> String -> BinaryOp -> Cpp -> Cpp

202211 binaryFunction dict fnName op = everywhereOnCpp convert

203212 where

204213 convert :: Cpp -> Cpp

214+ convert (CppApp fn [dict', x, y]) | isPreludeFn fnName fn && isDict dict dict' = CppBinary op x y

205215 convert (CppApp (CppApp (CppApp fn [dict']) [x]) [y]) | isPreludeFn fnName fn && isDict dict dict' = CppBinary op x y

206216 convert other = other

207217 unary :: (String, String) -> String -> CppUnaryOp -> Cpp -> Cpp

208218 unary dict fnName op = everywhereOnCpp convert

209219 where

210220 convert :: Cpp -> Cpp

221+ convert (CppApp fn [dict', x]) | isPreludeFn fnName fn && isDict dict dict' = CppUnary op x

211222 convert (CppApp (CppApp fn [dict']) [x]) | isPreludeFn fnName fn && isDict dict dict' = CppUnary op x

212223 convert other = other

213224 unary' :: String -> String -> CppUnaryOp -> Cpp -> Cpp

@@ -258,6 +269,9 @@ inlineFnComposition :: (Applicative m, MonadSupply m) => Cpp -> m Cpp

258269inlineFnComposition = everywhereOnCppTopDownM convert

259270 where

260271 convert :: (MonadSupply m) => Cpp -> m Cpp

272+ convert (CppApp fn [dict', x, y]) | isFnCompose dict' fn = do

273+ arg <- freshName

274+ return $ CppLambda [CppCaptureAll] [(arg, Just (CppAny [CppConst, CppRef]))] (Just $ CppAny []) (CppBlock [CppReturn $ CppApp x [CppApp y [CppVar arg]]])

261275 convert (CppApp (CppApp (CppApp (CppApp fn [dict']) [x]) [y]) [z]) | isFnCompose dict' fn =

262276 return $ CppApp x [CppApp y [z]]

263277 convert (CppApp (CppApp (CppApp fn [dict']) [x]) [y]) | isFnCompose dict' fn = do

src/Language/PureScript/CodeGen/Cpp/Optimizer/MagicDo.hs+8

@@ -53,19 +53,27 @@ magicDo' = everywhereOnCpp undo . everywhereOnCppTopDown convert

5353 -- Desugar monomorphic calls to >>= and return for the Eff monad

5454 convert :: Cpp -> Cpp

5555 -- Desugar return

56+ convert (CppApp (CppApp ret [effDict, val]) []) | isRetPoly ret && isEffDict C.monadEffDictionary effDict = val

5657 convert (CppApp (CppApp ret [val]) []) | isReturn ret = val

5758 -- Desugar pure

59+ convert (CppApp (CppApp pure' [effDict, val]) []) | isPurePoly pure' && isEffDict C.applicativeEffDictionary effDict = val

5860 convert (CppApp (CppApp pure' [val]) []) | isPure pure' = val

5961 -- Desugar >>

62+ convert (CppApp bind [effDict, m, CppLambda _ [] rty (CppBlock cpp)]) | isBindPoly bind && isEffDict C.bindEffDictionary effDict =

63+ CppFunction fnName [] rty [] $ CppBlock (CppApp m [] : map applyReturns cpp )

6064 convert (CppApp (CppApp bind [m]) [CppLambda _ [] rty (CppBlock cpp)]) | isBind bind =

6165 CppFunction fnName [] rty [] $ CppBlock (CppApp m [] : map applyReturns cpp )

6266 -- Desugar >>=

67+ convert (CppApp bind [effDict, m, CppLambda _ [arg] rty (CppBlock cpp)]) | isBindPoly bind && isEffDict C.bindEffDictionary effDict =

68+ CppFunction fnName [] rty [] $ CppBlock (CppVariableIntroduction arg [] (Just (CppApp m [])) : map applyReturns cpp)

6369 convert (CppApp (CppApp bind [m]) [CppLambda _ [arg] rty (CppBlock cpp)]) | isBind bind =

6470 CppFunction fnName [] rty [] $ CppBlock (CppVariableIntroduction arg [] (Just (CppApp m [])) : map applyReturns cpp)

6571 -- Desugar untilE

6672 convert (CppApp (CppApp f [arg]) []) | isEffFunc C.untilE f =

6773 CppApp (CppLambda [CppCaptureAll] [] (Just $ CppAny []) (CppBlock [ CppWhile (CppUnary CppNot (CppApp arg [])) (CppBlock []), CppReturn $ CppObjectLiteral []])) []

6874 -- Desugar whileE

75+ convert (CppApp (CppApp f [arg1, arg2]) []) | isEffFunc C.whileE f =

76+ CppApp (CppLambda [CppCaptureAll] [] (Just $ CppAny []) (CppBlock [ CppWhile (CppApp arg1 []) (CppBlock [ CppApp arg2 [] ]), CppReturn $ CppObjectLiteral []])) []

6977 convert (CppApp (CppApp (CppApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =

7078 CppApp (CppLambda [CppCaptureAll] [] (Just $ CppAny []) (CppBlock [ CppWhile (CppApp arg1 []) (CppBlock [ CppApp arg2 [] ]), CppReturn $ CppObjectLiteral []])) []

7179 convert other = other