@@ -32,23 +32,22 @@ import Data.Char (isLetter)
3232import Data.Function (on)
3333import Data.List
3434import qualified Data.Map as M
35−import Data.Maybe (catMaybes, fromJust)
35+import Data.Maybe (catMaybes)
3636import Data.Monoid ((<>))
3737import Data.Text (Text, unpack)
3838import qualified Data.Text as Text
3939
4040import Control.Monad (forM, replicateM)
41−import Control.Monad.Reader (MonadReader, ask)
41+import Control.Monad.Reader (MonadReader)
4242import Control.Monad.Supply.Class
4343import Language.PureScript.AST.SourcePos
4444import Language.PureScript.CodeGen.Cpp.AST as AST
4545import Language.PureScript.CodeGen.Cpp.Common as Common
4646import Language.PureScript.CodeGen.Cpp.File
4747import Language.PureScript.CodeGen.Cpp.Optimizer
48−import Language.PureScript.CodeGen.Cpp.Optimizer.TCO
48+import Language.PureScript.CodeGen.Cpp.Recursion
4949import Language.PureScript.CodeGen.Cpp.Types
5050import Language.PureScript.CodeGen.Cpp.Unicode
51−import Language.PureScript.Comments
5251import Language.PureScript.CoreFn
5352import Language.PureScript.Names
5453import Language.PureScript.Options
@@ -93,7 +92,7 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do
9392 E.dataConstructors env
9493 cpps' <- traverse (optimize $ namesmap ++ datamap) cpps
9594 foreignWrappers <- curriedForeigns
96− let optimized = (otherTransforms otherOpts <$> cpps') ++ foreignWrappers
95+ let optimized = (otherTransforms otherOpts . convertRecursiveRefs <$> cpps') ++ foreignWrappers
9796 let moduleHeader =
9897 fileBegin mn "HH" ++
9998 P.linebreak ++
@@ -333,7 +332,7 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do
333332 fnToLambda (CppFunction name args _ qs body) =
334333 CppVariableIntroduction
335334 (name, Just $ Any [Const])
336− (filter (== Static) qs)
335+ qs -- (filter (== Static) qs)
337336 (Just $ CppLambda cs args (Just $ Any []) body)
338337 where
339338 cs
@@ -350,82 +349,6 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do
350349 go f@(CppFunction {}) = maybeRemCaps $ fnToLambda f
351350 go (CppLambda _ args rtyp body) = maybeRemCaps $ CppLambda [CaptureAll] args rtyp body
352351 go cpp = cpp
353− -------------------------------------------------------------------------------------------------
354− convertRecursiveFns :: [Cpp] -> Cpp -> [Cpp]
355− -------------------------------------------------------------------------------------------------
356− convertRecursiveFns cpps otherCpp
357− | not $ null fns = dict : (accessor topdict <$> filteredFns allCpps) ++ cpps'
358− where
359− cpps' = everywhereOnCpp removeRec <$> cpps
360− allCpps = CppBlock $ otherCpp : cpps'
361− fns :: [(Text, Cpp)]
362− fns = toelem <$> concatMap (everythingOnCpp (++) recursive) cpps
363− filteredFns :: Cpp -> [(Text, Cpp)]
364− filteredFns cpp = filter (\(f, _) -> everythingOnCpp (||) (== CppVar f) cpp) fns
365− recursive :: Cpp -> [Cpp]
366− recursive cpp'@(CppFunction _ _ _ qs _)
367− | Recursive `elem` qs = [cpp']
368− recursive cpp'@(CppVariableIntroduction _ qs _)
369− | Recursive `elem` qs = [cpp']
370− recursive _ = []
371− removeRec :: Cpp -> Cpp
372− removeRec (CppFunction _ _ _ qs _)
373− | Recursive `elem` qs = CppNoOp
374− removeRec (CppVariableIntroduction _ qs _)
375− | Recursive `elem` qs = CppNoOp
376− removeRec cpp' = cpp'
377− replaceVar :: [(Text, Cpp)] -> Cpp -> Cpp
378− replaceVar rs = go
379− where
380− go (CppVar var)
381− | Just var' <- lookup var rs = var'
382− go cpp' = cpp'
383− dict :: Cpp
384− dict =
385− CppVariableIntroduction
386− (topdict, Just $ Any [Const])
387− []
388− (Just $ CppDataLiteral ((\(f, cpp) -> CppComment [LineComment f] cpp) <$> fns))
389− accessed :: Text -> Text -> (Text, Cpp)
390− accessed dictname name =
391− ( name
392− , CppApp
393− (CppDataGet
394− (CppNumericLiteral . Left . fromIntegral . fromJust $ findIndex ((== name) . fst) fns)
395− dict')
396− [dict'])
397− where
398− dict' = CppVar dictname
399− accessor :: Text -> (Text, Cpp) -> Cpp
400− accessor dictname (name, _) =
401− CppVariableIntroduction (name, Just $ Any [Const]) [] (Just . snd $ accessed dictname name)
402− toelem :: Cpp -> (Text, Cpp)
403− toelem (CppFunction name args rtyp _ body'@(CppBlock body)) =
404− ( name
405− , withdict . maybeRemCaps $
406− CppLambda
407− [CaptureAll]
408− args
409− rtyp
410− (CppBlock $ (accessor localdict <$> filteredFns body') ++ body))
411− toelem (CppVariableIntroduction (name, _) _ (Just body')) =
412− let replacements = accessed localdict . fst <$> filteredFns body'
413− replaced = everywhereOnCpp (replaceVar replacements) body'
414− in (name, withdict . maybeRemCaps $ CppBlock [CppReturn replaced])
415− toelem _ = error "not a function"
416− withdict :: Cpp -> Cpp
417− withdict cpp' =
418− maybeRemCaps $
419− CppLambda
420− [CaptureAll]
421− [(localdict, Just $ Any [Const, Ref])]
422− (Just $ Any [])
423− (returnBlock cpp')
424− topdict :: Text
425− topdict = "_$dict$_"
426− localdict :: Text
427− localdict = "$dict$"
428− convertRecursiveFns cpps _ = cpps
429352
430353 -- |
431354 -- Generate code in the simplified C++1x intermediate representation for a value or expression.
@@ -437,6 +360,9 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do
437360 valueToCpp (Var (_, _, _, Just (IsConstructor _ [])) ident) = return $ CppApp (varToCpp ident) []
438361 valueToCpp (Var (_, _, Just ty, _) ident@(Qualified (Just _) _))
439362 | arity ty > 0 = return . curriedName' $ varToCpp ident
363+ valueToCpp (Var (_, _, Nothing, _) ident@(Qualified (Just _) _))
364+ | Just (ty, _, _) <- M.lookup ident (E.names env)
365+ , arity ty > 0 = return . curriedName' $ varToCpp ident
440366 valueToCpp (Var _ ident) = return $ varToCpp ident
441367 valueToCpp (Literal _ (NumericLiteral n)) = return (CppNumericLiteral n)
442368 valueToCpp (Literal _ (StringLiteral s)) = return (CppStringLiteral s)
@@ -500,32 +426,8 @@ moduleToCpp otherOpts env (Module _ mn imps _ foreigns decls) = do
500426 valueToCpp (Let _ ds val) = do
501427 ds' <- concat <$> mapM (bindToCpp []) ds
502428 ret <- valueToCpp val
503− opts <- ask
504− let ds'' = tco opts <$> ds'
505− let rs =
506− if hasRecursion ds''
507− then convertRecursiveFns ds'' ret
508− else ds''
509− let cpps = innerLambdas <$> rs
510− return $ CppApp (CppLambda [] [] Nothing (CppBlock (cpps ++ [CppReturn ret]))) []
511− where
512− hasRecursion :: [Cpp] -> Bool
513− hasRecursion cpps' = any (everythingOnCpp (||) hasRecursiveRef) cpps'
514− where
515− valnames :: [Text]
516− valnames = concatMap (everythingOnCpp (++) valname) cpps'
517− valname :: Cpp -> [Text]
518− valname (CppFunction name _ _ _ _) = [name]
519− valname (CppVariableIntroduction (name, _) _ _) = [name]
520− valname _ = []
521− hasRecursiveRef :: Cpp -> Bool
522− hasRecursiveRef (CppFunction _ _ _ _ body) = everythingOnCpp (||) ref body
523− hasRecursiveRef (CppVariableIntroduction _ _ (Just value)) = everythingOnCpp (||) ref value
524− hasRecursiveRef _ = False
525− ref :: Cpp -> Bool
526− ref (CppVar name)
527− | name `elem` valnames = True
528− ref _ = False
429+ let cpps = (innerLambdas <$> ds') ++ [CppReturn ret]
430+ return $ CppApp (CppLambda [] [] Nothing (CppBlock cpps)) []
529431 valueToCpp Constructor {} = return CppNoOp
530432
531433 -- |