f93d365 · rowtype-yoga/purescript-native

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

on golang help sign in

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

f93d365Andy Arvanitis11 years ago

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

compare with golang

unifiedsplit

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

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

53import qualified Language.PureScript.Types as T

55−-- import Debug.Trace

56−

57-- |

55-- |

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

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

59-- module.

57-- module.

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

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

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

121 return CppNoOp -- skip operator aliases

119 return CppNoOp -- skip operator aliases

122

120

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−

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

121 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

137 then do

123 then do

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

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

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

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

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

231 block <- valueToCpp $

217 block <- valueToCpp $

232 curriedApp

218 curriedApp

233 (tail argNames)

219 (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))

238 let fn' = CppFunction

221 let fn' = CppFunction

239 (curriedName name)

222 (curriedName name)

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

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

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

245 (tail argNames)

228 (tail argNames)

246 (CppApp (CppVar name)

229 (CppApp (CppVar name)

247 (CppVar <$> argNames)))

230 (CppVar <$> argNames)))

248− return $ CppNamespace ""

231+ return $ CppNamespace "" $

249 [ CppFunction

232 [ CppFunction

250 name

233 name

251 (zip argNames $ repeat aty)

234 (zip argNames $ repeat aty)

252 rty

235 rty

253 []

236 []

254 (asReturnBlock block)

237 (asReturnBlock block)

238+ ] ++ if argcnt > 1

255− , fn'

239+ then [fn']

256− ]

240+ else []

257 where

241 where

258 name = identToCpp ident

242 name = identToCpp ident

259 aty = Just $ CppAny [CppConst, CppRef]

243 aty = Just $ CppAny [CppConst, CppRef]

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

362 valueToCpp :: Expr Ann -> m Cpp

346 valueToCpp :: Expr Ann -> m Cpp

363 -------------------------------------------------------------------------------------------------

347 -------------------------------------------------------------------------------------------------

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

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

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

349+ return $ CppApp (varToCpp ident) []

366

350

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

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

368− return . CppVar $ qualifiedToStr' id ident

352+ return $ varToCpp ident

369

353

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

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

371 return . curriedName' $ varToCpp ident

355 return . curriedName' $ varToCpp ident

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

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

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

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

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

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

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

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

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

441− | argcnt <- countArgs ty,

425+ | argcnt <- maybe 0 countArgs ty,

442− argcnt > 1,

426+ argcnt > 1 -> do

443− length args >= argcnt -> do

444 f' <- valueToCpp f

427 f' <- valueToCpp f

428+ let (uncurriedArgs, curriedArgs) =

429+ if length args' >= argcnt

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

430+ then splitAt argcnt args'

431+ else ([], args')

432+ fn' =

433+ if null uncurriedArgs

434+ then curriedName' f'

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

435+ else CppApp (uncurried' f') uncurriedArgs

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

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

448 _ ->

441 _ ->

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

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

450

443

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

788---------------------------------------------------------------------------------------------------

781---------------------------------------------------------------------------------------------------

789countArgs :: T.Type -> Int

782countArgs :: T.Type -> Int

790---------------------------------------------------------------------------------------------------

783---------------------------------------------------------------------------------------------------

791−countArgs = go 0 . T.everywhereOnTypes rmForAll

784+countArgs = go 0

792 where

785 where

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

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

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

787 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

795 go argcnt _ = argcnt

789 go argcnt _ = argcnt

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

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

798− rmForAll t = t

799

790

800---------------------------------------------------------------------------------------------------

791---------------------------------------------------------------------------------------------------

801curriedName :: String -> String

792curriedName :: String -> String

802---------------------------------------------------------------------------------------------------

793---------------------------------------------------------------------------------------------------

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

803curriedName name = '$' : name

795curriedName name = '$' : name

804

796

805---------------------------------------------------------------------------------------------------

797---------------------------------------------------------------------------------------------------

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

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

33--

34identToCpp :: Ident -> String

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

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

36identToCpp (Ident name) = concatMap identCharToString name

37identToCpp (Ident name) = concatMap identCharToString name

37identToCpp (Op op) = concatMap identCharToString op

38identToCpp (Op op) = concatMap identCharToString op

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

50identCharToString c | isAlphaNum c = [c]

51identCharToString c | isAlphaNum c = [c]

51identCharToString '_' = "_"

52identCharToString '_' = "_"

52identCharToString '.' = "_dot_"

53identCharToString '.' = "_dot_"

53−identCharToString '$' = "$"

54+identCharToString '$' = "_dollar_"

54identCharToString '~' = "_tilde_"

55identCharToString '~' = "_tilde_"

55identCharToString '=' = "_eq_"

56identCharToString '=' = "_eq_"

56identCharToString '<' = "_less_"

57identCharToString '<' = "_less_"

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

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

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

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

111 | 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

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

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

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

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

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

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

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

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

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

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

122+

117 convert other = other

123 convert other = other

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

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

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

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

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

128inlineOperator (m, op) f = everywhereOnCpp convert

134inlineOperator (m, op) f = everywhereOnCpp convert

129 where

135 where

130 convert :: Cpp -> Cpp

136 convert :: Cpp -> Cpp

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

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

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

132 convert other = other

139 convert other = other

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

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

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

188 binary dict opString op = everywhereOnCpp convert

195 binary dict opString op = everywhereOnCpp convert

189 where

196 where

190 convert :: Cpp -> Cpp

197 convert :: Cpp -> Cpp

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

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

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

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

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

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

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

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

196 binary' moduleName opString op = everywhereOnCpp convert

204 binary' moduleName opString op = everywhereOnCpp convert

197 where

205 where

198 convert :: Cpp -> Cpp

206 convert :: Cpp -> Cpp

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

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

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

200 convert other = other

209 convert other = other

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

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

202 binaryFunction dict fnName op = everywhereOnCpp convert

211 binaryFunction dict fnName op = everywhereOnCpp convert

203 where

212 where

204 convert :: Cpp -> Cpp

213 convert :: Cpp -> Cpp

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

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

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

206 convert other = other

216 convert other = other

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

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

208 unary dict fnName op = everywhereOnCpp convert

218 unary dict fnName op = everywhereOnCpp convert

209 where

219 where

210 convert :: Cpp -> Cpp

220 convert :: Cpp -> Cpp

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

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

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

212 convert other = other

223 convert other = other

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

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

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

258inlineFnComposition = everywhereOnCppTopDownM convert

269inlineFnComposition = everywhereOnCppTopDownM convert

259 where

270 where

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

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

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

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

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

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

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

277 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

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

54 convert :: Cpp -> Cpp

55 -- Desugar return

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

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

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

57 -- Desugar pure

58 -- Desugar pure

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

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

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

59 -- Desugar >>

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

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

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

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

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

62 -- Desugar >>=

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

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

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

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

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

65 -- Desugar untilE

71 -- Desugar untilE

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

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

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

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

68 -- Desugar whileE

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

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

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

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

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

71 convert other = other

79 convert other = other