6d56ee3 · rowtype-yoga/purescript-native

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

on golang help sign in

C++: generate and use uncurried funcs where possible; use uncurried FFI funcs

6d56ee3Andy Arvanitis11 years ago

src/Language/PureScript/CodeGen/Cpp.hs+222−57

compare with golang

unifiedsplit

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

69 imps

70 let cppImports' = "PureScript" : cppImports

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

72− optimized <- traverse optimize cppDecls

72+ cppDecls' <- traverse optimize cppDecls

73+ foreignWrappers <- curriedForeigns

74+ let optimized = cppDecls' ++ foreignWrappers

73 let moduleHeader =

75 let moduleHeader =

74 fileBegin mn "HH" ++

76 fileBegin mn "HH" ++

75 P.linebreak ++

77 P.linebreak ++

@@ -115,6 +117,9 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

115 declToCpp _ _ (Abs (_, _, _, Just IsTypeClassConstructor) _ _) =

117 declToCpp _ _ (Abs (_, _, _, Just IsTypeClassConstructor) _ _) =

116 return CppNoOp

118 return CppNoOp

117

119

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

121+ return CppNoOp -- skip operator aliases

122+

118 declToCpp _ ident (Abs _ arg@(Ident "dict")

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

119 body@(Accessor _ _ (Var _ (Qualified Nothing arg'))))

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

120 | arg' == arg = do

125 | arg' == arg = do

@@ -127,16 +132,51 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

127 block

132 block

128 return fn'

133 return fn'

129

134

130− declToCpp vqs ident (Abs (_, com, _, _) arg body) = do

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

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

137+ then do

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

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

131− block <- asReturnBlock <$> valueToCpp body

140+ block <- asReturnBlock <$> valueToCpp

141+ (if null argNames

142+ then snd abs'

143+ else curriedApp

144+ (tail argNames)

145+ (App

146+ nullAnn

147+ (snd abs')

148+ (Var nullAnn . Qualified Nothing . Ident $ head argNames)))

132− let block' = convertNestedLambdas block

149+ let block' = convertNestedLambdas block

150+ return $ CppNamespace ""

151+ [ CppFunction

152+ name

153+ (arg' : args' ++ args'')

154+ rty

155+ vqs

156+ block'

133− fn' = CppFunction

157+ , CppFunction

134− (identToCpp ident)

158+ (curriedName name)

159+ [arg']

160+ rty

161+ []

162+ (asReturnBlock $

163+ curriedLambda

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

165+ (CppApp (CppVar name)

166+ (CppVar . fst <$> (arg' : args' ++ args''))))

167+ ]

168+ else do

169+ block <- asReturnBlock <$> valueToCpp body

170+ return $ CppFunction name [arg'] rty vqs (convertNestedLambdas block)

171+ return (CppComment com fn)

172+ where

173+ argcnt = maybe 0 countArgs ty

174+ name = identToCpp ident

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

175+ aty = Just $ CppAny [CppConst, CppRef]

136− (Just $ CppAny [])

176+ rty = Just $ CppAny []

137− vqs

177+ arg' = (identToCpp arg, aty)

138− block'

178+ args' = (\i -> (identToCpp i, aty)) <$> fst abs'

139− return (CppComment com fn')

179+ abs' = unAbs body []

140

180

141 declToCpp _ ident (Constructor _ _ (ProperName _) []) =

181 declToCpp _ ident (Constructor _ _ (ProperName _) []) =

142 return $

182 return $

@@ -145,22 +185,28 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

145 []

185 []

146 (Just $ CppAny [])

186 (Just $ CppAny [])

147 [CppInline]

187 [CppInline]

148− (CppBlock [CppReturn (CppDataLiteral [CppStringLiteral (identToCpp ident)])])

188+ (asReturnBlock (CppDataLiteral [CppStringLiteral (identToCpp ident)]))

149

189

150− declToCpp _ ident (Constructor _ _ (ProperName _) fields) = return . CppNamespace [] $

190+ declToCpp _ ident (Constructor _ _ (ProperName _) fields) =

191+ return . CppNamespace "" $

151 [ CppFunction

192 [ CppFunction

152− ('$' : identToCpp ident)

193+ name

153 (farg <$> fields')

194 (farg <$> fields')

154 (Just $ CppAny [])

195 (Just $ CppAny [])

155 [CppInline]

196 [CppInline]

156− (CppBlock fullyConstructed)

197+ (asReturnBlock (CppDataLiteral (CppStringLiteral name : (CppVar <$> fields'))))

198+ ] ++

199+ if length fields > 1

200+ then

157− , CppFunction

201+ [ CppFunction

158− (identToCpp ident)

202+ (curriedName name)

159− (farg <$> f)

203+ (farg <$> f)

160− (Just $ CppAny [])

204+ (Just $ CppAny [])

161− []

205+ []

162− (CppBlock (fieldLambdas fs))

206+ (CppBlock (fieldLambdas fs))

207+ ]

208+ else

163− ]

209+ []

164 where

210 where

165 name = identToCpp ident

211 name = identToCpp ident

166 fields' = identToCpp <$> fields

212 fields' = identToCpp <$> fields

@@ -174,35 +220,44 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

174 (farg <$> [f'])

220 (farg <$> [f'])

175 (Just $ CppAny [])

221 (Just $ CppAny [])

176 (CppBlock $ fieldLambdas fs') ]

222 (CppBlock $ fieldLambdas fs') ]

177− | otherwise = fullyConstructed

178− fullyConstructed = [CppReturn (CppDataLiteral (CppStringLiteral name : (CppVar <$> fields')))]

223+ | otherwise = [CppReturn $ CppApp (CppVar name) (CppVar <$> fields')]

179−

224+

180− declToCpp qs ident e@(App (_, _, Just ty, _) _ _)

225+ declToCpp qs ident e

226+ | Just ty <- exprType e,

181− | CppTopLevel `elem` qs,

227+ CppTopLevel `elem` qs,

182− count <- countArgs ty,

228+ argcnt <- countArgs ty,

183− count > 0 = do

229+ argcnt > 0 = do

184− argNames <- replicateM count freshName

230+ argNames <- replicateM argcnt freshName

185− block <- flip (foldl (\fn a -> CppApp fn [a])) (CppVar <$> argNames) <$> valueToCpp e

231+ block <- valueToCpp $

232+ curriedApp

233+ (tail argNames)

234+ (App

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

236+ e

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

186− return $ CppFunction

238+ let fn' = CppFunction

187− (identToCpp ident)

239+ (curriedName name)

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

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

189− (Just $ CppAny [])

241+ rty

190 []

242 []

191− (asReturnBlock $ curried (tail argNames) block)

243+ (asReturnBlock $

244+ curriedLambda

245+ (tail argNames)

246+ (CppApp (CppVar name)

247+ (CppVar <$> argNames)))

248+ return $ CppNamespace ""

249+ [ CppFunction

250+ name

251+ (zip argNames $ repeat aty)

252+ rty

253+ []

254+ (asReturnBlock block)

255+ , fn'

256+ ]

192 where

257 where

193− curried :: [String] -> Cpp -> Cpp

258+ name = identToCpp ident

194− curried args vals = foldl (\val arg -> CppLambda

195− [CppCaptureAll]

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

259+ aty = Just $ CppAny [CppConst, CppRef]

197− (Just $ CppAny [])

260+ rty = Just $ CppAny []

198− (asReturnBlock val)

199− ) vals args

200− countArgs :: T.Type -> Int

201− countArgs = go 0

202− where

203− go argcnt (T.ForAll _ t _) = go argcnt t

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

205− go argcnt _ = argcnt

206

261

207 declToCpp _ ident val = do

262 declToCpp _ ident val = do

208 val' <- valueToCpp val

263 val' <- valueToCpp val

@@ -212,6 +267,15 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

212 []

267 []

213 (Just val')

268 (Just val')

214

269

270+ -------------------------------------------------------------------------------------------------

271+ exprType :: Expr Ann -> Maybe T.Type

272+ -------------------------------------------------------------------------------------------------

273+ exprType (Var (_, _, Just ty, _) _) = Just ty

274+ exprType (App (_, _, Just ty, _) _ _) = Just ty

275+ exprType (Case (_, _, Just ty, _) _ _) = Just ty

276+ exprType (Let (_, _, Just ty, _) _ _) = Just ty

277+ exprType _ = Nothing

278+

215 -------------------------------------------------------------------------------------------------

279 -------------------------------------------------------------------------------------------------

216 fnToLambda :: Cpp -> Cpp

280 fnToLambda :: Cpp -> Cpp

217 -------------------------------------------------------------------------------------------------

281 -------------------------------------------------------------------------------------------------

@@ -226,11 +290,6 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

226 fnToLambda (CppComment com cpp) = CppComment com (fnToLambda cpp)

290 fnToLambda (CppComment com cpp) = CppComment com (fnToLambda cpp)

227 fnToLambda _ = error "Not a function!"

291 fnToLambda _ = error "Not a function!"

228

292

229− -------------------------------------------------------------------------------------------------

230− asReturnBlock :: Cpp -> Cpp

231− -------------------------------------------------------------------------------------------------

232− asReturnBlock cpp = CppBlock [CppReturn cpp]

233−

234 -------------------------------------------------------------------------------------------------

293 -------------------------------------------------------------------------------------------------

235 convertNestedLambdas :: Cpp -> Cpp

294 convertNestedLambdas :: Cpp -> Cpp

236 -------------------------------------------------------------------------------------------------

295 -------------------------------------------------------------------------------------------------

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

288 [CppCaptureAll]

347 [CppCaptureAll]

289 [(localdict, Just $ CppAny [CppConst, CppRef])]

348 [(localdict, Just $ CppAny [CppConst, CppRef])]

290 (Just $ CppAny [])

349 (Just $ CppAny [])

291− (CppBlock [CppReturn cpp'])

350+ (asReturnBlock cpp')

292 topdict :: String

351 topdict :: String

293 topdict = "__dict__"

352 topdict = "__dict__"

294 localdict :: String

353 localdict :: String

@@ -305,9 +364,16 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

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

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

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

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

307

366

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

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

309 return . CppVar $ qualifiedToStr' id ident

368 return . CppVar $ qualifiedToStr' id ident

310

369

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

371+ return . curriedName' $ varToCpp ident

372+

373+ valueToCpp (Var (_, _, Just ty, _) ident@(Qualified (Just _) _))

374+ | countArgs ty > 1 =

375+ return . curriedName' $ varToCpp ident

376+

311 valueToCpp (Var _ ident) =

377 valueToCpp (Var _ ident) =

312 return $ varToCpp ident

378 return $ varToCpp ident

313

379

@@ -365,11 +431,20 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

365 args' <- mapM valueToCpp args

431 args' <- mapM valueToCpp args

366 case f of

432 case f of

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

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

368− Var (_, _, _, Just (IsConstructor _ fields)) (Qualified qual (Ident name)) | length args == length fields ->

434+ Var (_, _, _, Just (IsConstructor _ fields)) ident

435+ | length args == length fields ->

369− return $ CppApp (qualifiedToCpp id . Qualified qual . Ident $ '$' : name) args'

436+ return $ CppApp (uncurried' $ qualifiedToCpp id ident) args'

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

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

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

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

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

439 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

444+ 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

373 _ ->

448 _ ->

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

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

375

450

@@ -625,6 +700,12 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

625 unApp (App _ val arg) args = unApp val (arg : args)

700 unApp (App _ val arg) args = unApp val (arg : args)

626 unApp other args = (other, args)

701 unApp other args = (other, args)

627

702

703+ -------------------------------------------------------------------------------------------------

704+ unAbs :: Expr Ann -> [Ident] -> ([Ident], Expr Ann)

705+ -------------------------------------------------------------------------------------------------

706+ unAbs (Abs _ arg val) args = unAbs val (args ++ [arg])

707+ unAbs other args = (args, other)

708+

628 -------------------------------------------------------------------------------------------------

709 -------------------------------------------------------------------------------------------------

629 qualifiedToCpp :: (a -> Ident) -> Qualified a -> Cpp

710 qualifiedToCpp :: (a -> Ident) -> Qualified a -> Cpp

630 -------------------------------------------------------------------------------------------------

711 -------------------------------------------------------------------------------------------------

@@ -650,3 +731,87 @@ moduleToCpp env (Module _ mn imps _ foreigns decls) = do

650 fns' <- (\(i,t) -> (runIdent i, t)) <$> fns

731 fns' <- (\(i,t) -> (runIdent i, t)) <$> fns

651 = Just (fst <$> params, constraints, (sortBy (compare `on` normalizedName . fst) fns'))

732 = Just (fst <$> params, constraints, (sortBy (compare `on` normalizedName . fst) fns'))

652 findClass _ = Nothing

733 findClass _ = Nothing

734+

735+ -------------------------------------------------------------------------------------------------

736+ curriedForeigns :: m [Cpp]

737+ -------------------------------------------------------------------------------------------------

738+ curriedForeigns = concat <$> mapM go allForeigns

739+ where

740+ go (ident, ty)

741+ | argcnt <- countArgs ty,

742+ argcnt > 1 = do

743+ let name = identToCpp ident

744+ argNames <- replicateM argcnt freshName

745+ return $

746+ [ CppFunction

747+ (curriedName name)

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

749+ (Just $ CppAny [])

750+ []

751+ (asReturnBlock $

752+ curriedLambda

753+ (tail argNames)

754+ (CppApp (CppVar name)

755+ (CppVar <$> argNames)))

756+ ]

757+ go _ = return []

758+

759+ allForeigns :: [(Ident, T.Type)]

760+ allForeigns = map (\((_, ident), (ty, _, _)) -> (ident, ty)) .

761+ filter (\((mn', _), (_, kind, _)) -> mn' == mn && kind == E.External) .

762+ M.toList $ E.names env

763+

764+---------------------------------------------------------------------------------------------------

765+asReturnBlock :: Cpp -> Cpp

766+---------------------------------------------------------------------------------------------------

767+asReturnBlock cpp = CppBlock [CppReturn cpp]

768+

769+---------------------------------------------------------------------------------------------------

770+curriedLambda :: [String] -> Cpp -> Cpp

771+---------------------------------------------------------------------------------------------------

772+curriedLambda args ret = foldr (\arg ret' -> CppLambda

773+ [CppCaptureAll]

774+ [(arg, Just $ CppAny [CppConst, CppRef])]

775+ (Just $ CppAny [])

776+ (asReturnBlock ret')

777+ ) ret args

778+

779+---------------------------------------------------------------------------------------------------

780+curriedApp :: [String] -> Expr Ann -> Expr Ann

781+---------------------------------------------------------------------------------------------------

782+curriedApp args vals = foldl (\val arg -> App

783+ nullAnn

784+ val

785+ (Var nullAnn . Qualified Nothing $ Ident arg))

786+ vals args

787+

788+---------------------------------------------------------------------------------------------------

789+countArgs :: T.Type -> Int

790+---------------------------------------------------------------------------------------------------

791+countArgs = go 0 . T.everywhereOnTypes rmForAll

792+ where

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

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

795+ go argcnt _ = argcnt

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

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

798+ rmForAll t = t

799+

800+---------------------------------------------------------------------------------------------------

801+curriedName :: String -> String

802+---------------------------------------------------------------------------------------------------

803+curriedName name = '$' : name

804+

805+---------------------------------------------------------------------------------------------------

806+uncurried' :: Cpp -> Cpp

807+---------------------------------------------------------------------------------------------------

808+uncurried' (CppVar ('$':name)) = CppVar name

809+uncurried' (CppAccessor a b) = CppAccessor (uncurried' a) b

810+uncurried' cpp = cpp

811+

812+---------------------------------------------------------------------------------------------------

813+curriedName' :: Cpp -> Cpp

814+---------------------------------------------------------------------------------------------------

815+curriedName' (CppVar name) = CppVar (curriedName name)

816+curriedName' (CppAccessor a b) = CppAccessor (curriedName' a) b

817+curriedName' cpp = cpp

src/Language/PureScript/CodeGen/Cpp/AST.hs+1−1

@@ -182,7 +182,7 @@ data Cpp

182 --

183 | CppObjectLiteral [(String, Cpp)]

184 -- |

185− -- An general property accessor expression (optional type, property, expr)

185+ -- An general property accessor expression (property, expr)

186 --

187 | CppAccessor Cpp Cpp

188 -- |

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

@@ -79,6 +79,14 @@ evaluateIifes = everywhereOnCpp convert

79 where

80 convert :: Cpp -> Cpp

81 convert (CppApp (CppLambda _ [] _ (CppBlock [CppReturn ret])) []) = ret

82+ convert (CppReturn cpp@(CppApp _ _))

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

84+ CppApp (CppLambda _ [] _ (CppBlock cpps)) [] <- f,

85+ CppReturn ret <- last cpps = CppBlock $ init cpps ++ [CppReturn $foldl (\fn a -> CppApp fn [a]) ret args]

86+ where

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

88+ unApp (CppApp f [arg]) args = unApp f (arg : args)

89+ unApp other args = (other, args)

82 convert cpp = cpp

90 convert cpp = cpp

84inlineVariables :: Cpp -> Cpp

92inlineVariables :: Cpp -> Cpp