git.iko.soy/rowtype-yoga/purescript-native
on a5cbe85 help sign in
rowtype-yoga/purescript-native/src/CodeGen/Cpp.hs
401 lines 20 kB history raw
1-- | This module generates code in the core imperative representation from
2-- elaborated PureScript code.
3module CodeGen.Cpp
4 ( module AST
5 , module Common
6 , moduleToCpp
7 ) where
9import Prelude.Compat
10import Protolude (ordNub)
12import Control.Arrow ((&&&))
13import Control.Monad (forM, liftM, replicateM, void)
14import Control.Monad.Supply.Class
16import Data.List ((\\), delete, intersect)
17import qualified Data.Foldable as F
18import qualified Data.Map as M
19import Data.Maybe (fromMaybe, isNothing, mapMaybe)
20import Data.Monoid ((<>))
21import Data.String (fromString)
22import Data.Text (Text)
23import qualified Data.Text as T
25import Language.PureScript.AST.SourcePos
26import Language.PureScript.CoreImp.AST (AST)
27import qualified Language.PureScript.CoreImp.AST as AST
28import Language.PureScript.CoreFn
29import Language.PureScript.Crash
30import Language.PureScript.Names
31import Language.PureScript.Options
32import Language.PureScript.PSString (PSString, mkString)
33import Language.PureScript.Traversals (sndM)
34import qualified Language.PureScript.Constants as C
36import System.FilePath.Posix ((</>))
38import CodeGen.Cpp.Common as Common
39import CodeGen.Cpp.Optimizer
40import CodeGen.Cpp.Printer
42data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)
44-- | Generate code in the simplified intermediate representation for all declarations in a
45-- module.
46moduleToCpp
47 :: forall m
48 -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
49 . (Monad m, MonadSupply m)
50 => Module Ann
51 -> Maybe AST
52 -> m (Text, [Text], [AST], Text, Text)
53moduleToCpp (Module _ coms mn _ imps exports foreigns decls) _ =
54 do
55 let usedNames = concatMap getNames decls
56 let mnLookup = renameImports usedNames imps
57 cppImports <- traverse (importToCpp mnLookup) . (\\ (mn : C.primModules)) . (\\ [mn]) $ ordNub $ map snd imps
58 interfaceImport <- importToCpp (renameImports [] [(emptyAnn, mn)]) mn
59 let decls' = renameModules mnLookup decls
60 cppDecls <- mapM (bindToCpp ModuleDecl) decls'
61 optimized <- traverse (traverse (optimize modName')) cppDecls
62 let optimized' = concat optimized
63 exports' = mapMaybe (export $ identToCpp <$> exports) optimized'
64 foreigns' = identToCpp <$> foreigns
65 interface = interfaceSource modName exports' foreigns
66 implHeader = implHeaderSource modName cppImports interfaceImport
67 implFooter = implFooterSource modName foreigns
68 return $ (interface, foreigns', optimized', implHeader, implFooter)
69 where
70 modName = moduleNameToCpp mn
71 modName' = AST.Var Nothing modName
73 export :: [Text] -> AST -> Maybe (Text, Bool)
74 export names (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))
75 | name `elem` names && isLiteral ret = Just (name, True)
76 export names (AST.Function _ (Just name) [] _)
77 | name `elem` names = Just (name, False)
78 export _ _ = Nothing
80 -- | Extracts all declaration names from a binding group.
81 getNames :: Bind Ann -> [Ident]
82 getNames (NonRec _ ident _) = [ident]
83 getNames (Rec vals) = map (snd . fst) vals
85 -- | Creates alternative names for each module to ensure they don't collide
86 -- with declaration names.
87 renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
88 renameImports = go M.empty
89 where
90 go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
91 go acc used ((ann, mn') : mns') =
92 let mni = Ident $ runModuleName mn'
93 in if mn' /= mn && mni `elem` used
94 then let newName = freshModuleName 1 mn' used
95 in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'
96 else go (M.insert mn' (ann, mn') acc) used mns'
97 go acc _ [] = acc
99 freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
100 freshModuleName i mn'@(ModuleName pns) used =
101 let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) <> "_" <> T.pack (show i)]
102 in if Ident (runModuleName newName) `elem` used
103 then freshModuleName (i + 1) mn' used
104 else newName
106 -- | Generates C++ code for a module import, binding the required module
107 -- to the alternative
108 importToCpp :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m Text
109 importToCpp mnLookup mn' = do
110 let ((_, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
111 mname = moduleNameToCpp mnSafe
112 pure $ "#include \"" <> mname <> "/" <> mname <> ".h\"\n"
114 -- | Replaces the `ModuleName`s in the AST so that the generated code refers to
115 -- the collision-avoiding renamed module imports.
116 renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]
117 renameModules mnLookup binds =
118 let (f, _, _) = everywhereOnValues id goExpr goBinder
119 in map f binds
120 where
121 goExpr :: Expr a -> Expr a
122 goExpr (Var ann q) = Var ann (renameQual q)
123 goExpr e = e
124 goBinder :: Binder a -> Binder a
125 goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs
126 goBinder b = b
127 renameQual :: Qualified a -> Qualified a
128 renameQual (Qualified (Just mn') a) =
129 let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
130 in Qualified (Just mnSafe) a
131 renameQual q = q
133 -- |
134 -- Generate code in the simplified intermediate representation for a declaration
135 --
136 bindToCpp :: DeclType -> Bind Ann -> m [AST]
137 bindToCpp dt (NonRec ann ident val) = return <$> nonRecToCpp dt ann ident val
138 bindToCpp dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToCpp dt')
139 where
140 dt' = if dt == LetDecl then RecLetDecl else dt
142 -- | Generate code in the simplified intermediate representation for a single non-recursive
143 -- declaration.
144 --
145 -- The main purpose of this function is to handle code generation for comments.
146 nonRecToCpp :: DeclType -> Ann -> Ident -> Expr Ann -> m AST
147 nonRecToCpp dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
148 -- withoutComment <- asks optionsNoComments
149 let withoutComment = False
150 if withoutComment
151 then nonRecToCpp dt a i (modifyAnn removeComments e)
152 else AST.Comment Nothing com <$> nonRecToCpp dt a i (modifyAnn removeComments e)
153 nonRecToCpp ModuleDecl (ss, _, _, _) ident val = do
154 cpp <- valueToCpp val
155 pure $ AST.Function Nothing (Just $ identToCpp ident) [] (AST.Block Nothing [AST.Return Nothing cpp])
156 nonRecToCpp RecLetDecl (ss, _, _, _) ident val = do
157 cpp <- valueToCpp val
158 pure $
159 let retainedName = identToCpp ident
160 retained = AST.Var Nothing $ retainedName
161 -- unretained = AST.Var Nothing $ retainedName <> unretainedSuffix
162 -- alias = AST.Var Nothing . -- Note: prevents optimizer from eliminating this
163 -- prettyPrintCpp1 $
164 -- AST.VariableIntroduction Nothing retainedName (Just unretained)
165 in
166 case cpp of
167 AST.Function _ name args (AST.Block Nothing cpps) ->
168 AST.Assignment Nothing
169 (retained)
170 (AST.Function Nothing
171 name
172 args
173 (AST.Block Nothing cpps))
174 _ -> AST.Assignment Nothing retained cpp
175 nonRecToCpp _ (ss, _, _, _) ident val = do
176 cpp <- valueToCpp val
177 pure $ AST.VariableIntroduction Nothing (identToCpp ident) (Just cpp)
179 -- | Generate code in the simplified intermediate representation for a variable based on a
180 -- PureScript identifier.
181 var :: Ident -> AST
182 var = AST.Var Nothing . identToCpp
184 -- | Generate code in the simplified intermediate representation for an accessor based on
185 -- a PureScript identifier. If the name is not valid in C++ (symbol based, reserved name) an
186 -- indexer is returned.
187 accessor :: Ident -> AST -> AST
188 accessor (Ident prop) = accessorString $ mkString prop
189 accessor (GenIdent _ _) = internalError "GenIdent in accessor"
190 accessor UnusedIdent = internalError "UnusedIdent in accessor"
192 accessorString :: PSString -> AST -> AST
193 accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
195 -- | Generate code in the simplified intermediate representation for a value or expression.
197 valueToCpp :: Expr Ann -> m AST
198 valueToCpp (Literal (pos, _, _, _) l) = literalToValueCpp pos l
199 valueToCpp (Accessor _ prop val) =
200 accessorString prop <$> valueToCpp val
201 valueToCpp (ObjectUpdate _ o ps) = do
202 obj <- valueToCpp o
203 updates <- mapM (sndM valueToCpp) ps
204 obj' <- freshName
205 let objVar = AST.Var Nothing obj'
206 copy = AST.VariableIntroduction Nothing obj' (Just $ AST.App Nothing (AST.Var Nothing (unbox dictType)) [obj])
207 assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
208 sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
209 return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
210 valueToCpp (Abs _ arg val) = do
211 ret <- valueToCpp val
212 let cppArg = case arg of
213 UnusedIdent -> []
214 _ -> [identToCpp arg]
215 return $ AST.Function Nothing Nothing cppArg (AST.Block Nothing [AST.Return Nothing ret])
216 valueToCpp e@App{} = do
217 let (f, args) = unApp e []
218 args' <- mapM valueToCpp args
219 case f of
220 Var (_, _, _, Just IsNewtype) _ -> return (head args')
221 _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToCpp f
222 where
223 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
224 unApp (App _ val arg) args = unApp val (arg : args)
225 unApp other args = (other, args)
226 -- valueToCpp (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
227 -- return $ if mn' == mn
228 -- then AST.Var Nothing (moduleNameToCpp mn' <> "::" <> identToCpp ident)
229 -- else varToCpp qi
230 -- valueToCpp (Var (_, _, _, Just IsForeign) (Qualified (Just mn') ident)) =
231 -- return $ AST.Var Nothing (moduleNameToCpp mn' <> "::" <> identToCpp ident)
232 -- valueToCpp (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
233 -- return $ if mn' == mn
234 -- then foreignIdent ident
235 -- else varToCpp qi
236 -- valueToCpp (Var (_, _, _, Just IsForeign) ident) =
237 -- internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident)
238 valueToCpp (Var _ ident) = return $ varToCpp ident
239 valueToCpp (Case (ss, _, _, _) values binders) = do
240 vals <- mapM valueToCpp values
241 bindersToCpp ss binders vals
242 valueToCpp (Let _ ds val) = do
243 let recurs = concatMap getNames $ filter isRec ds
244 recurDs = (\v -> AST.VariableIntroduction Nothing (identToCpp v) (Just (AST.Var Nothing "box<fn_t>()"))) <$> recurs
245 -- recurDsWeak = (\v -> AST.VariableIntroduction Nothing ("__unsafe_unretained " <> identToCpp v <> unretainedSuffix) Nothing) <$> recurs
246 ds' <- concat <$> mapM (bindToCpp LetDecl) ds
247 ret <- valueToCpp val
248 return $
249 AST.App Nothing
250 (AST.Function Nothing
251 Nothing
252 []
253 (AST.Block Nothing (recurDs ++ ds' ++ [AST.Return Nothing ret])))
254 []
255 where
256 isRec :: Bind Ann -> Bool
257 isRec (Rec _) = True
258 isRec _ = False
259 valueToCpp (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"
260 valueToCpp (Constructor _ _ (ProperName ctor) fields) =
261 let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :
262 ((\field -> (mkString (identToCpp field), var field)) `map` fields)
263 fn = foldr (\f inner -> AST.Function Nothing Nothing [identToCpp f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
264 in return fn
267 iife :: Text -> [AST] -> AST
268 iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
270 literalToValueCpp :: SourceSpan -> Literal (Expr Ann) -> m AST
271 literalToValueCpp ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
272 literalToValueCpp ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)
273 literalToValueCpp ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s
274 literalToValueCpp ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])
275 literalToValueCpp ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b
276 literalToValueCpp ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToCpp xs
277 literalToValueCpp ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToCpp) ps
279 -- | Generate code in the simplified intermediate representation for a reference to a
280 -- variable.
281 varToCpp :: Qualified Ident -> AST
282 varToCpp (Qualified Nothing ident) = var ident
283 varToCpp qual = qualifiedToCpp id qual
285 -- | Generate code in the simplified intermediate representation for a reference to a
286 -- variable that may have a qualified name.
287 qualifiedToCpp :: (a -> Ident) -> Qualified a -> AST
288 qualifiedToCpp f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = AST.Var Nothing . runIdent $ f a
289 qualifiedToCpp f (Qualified (Just mn') a) = AST.Indexer Nothing (AST.Var Nothing . identToCpp $ f a) (AST.Var Nothing (moduleNameToCpp mn'))
290 qualifiedToCpp f (Qualified _ a) = AST.Var Nothing $ identToCpp (f a)
292 -- foreignIdent :: Ident -> AST
293 -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")
295 -- | Generate code in the simplified intermediate representation for pattern match binders
296 -- and guards.
297 bindersToCpp :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
298 bindersToCpp ss binders vals = do
299 valNames <- replicateM (length vals) freshName
300 let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
301 cpps <- forM binders $ \(CaseAlternative bs result) -> do
302 ret <- guardsToCpp result
303 go valNames ret bs
304 return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat cpps ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))
305 []
306 where
307 go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
308 go _ done [] = return done
309 go (v:vs) done' (b:bs) = do
310 done'' <- go vs done' bs
311 binderToCpp v done'' b
312 go _ _ _ = internalError "Invalid arguments to bindersToCpp"
314 failedPatternMessage :: Text
315 failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss <> ": "
317 guardsToCpp :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
318 guardsToCpp (Left gs) = traverse genGuard gs where
319 genGuard (cond, val) = do
320 cond' <- valueToCpp cond
321 val' <- valueToCpp val
322 return
323 (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))
324 (AST.Block Nothing [AST.Return Nothing val']) Nothing)
326 guardsToCpp (Right v) = return . AST.Return Nothing <$> valueToCpp v
328 -- | Generate code in the simplified intermediate representation for a pattern match
329 -- binder.
330 binderToCpp :: Text -> [AST] -> Binder Ann -> m [AST]
331 binderToCpp _ done NullBinder{} = return done
332 binderToCpp varName done (LiteralBinder _ l) =
333 literalToBinderCpp varName done l
334 binderToCpp varName done (VarBinder _ ident) =
335 return (AST.VariableIntroduction Nothing (identToCpp ident) (Just (AST.Var Nothing varName)) : done)
336 binderToCpp varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
337 binderToCpp varName done b
338 binderToCpp varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do
339 cpp <- go (zip fields bs) done
340 return $ case ctorType of
341 ProductType -> cpp
342 SumType ->
343 [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))
344 (AST.Block Nothing cpp)
345 Nothing]
346 where
347 go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
348 go [] done' = return done'
349 go ((field, binder) : remain) done' = do
350 argVar <- freshName
351 done'' <- go remain done'
352 cpp <- binderToCpp argVar done'' binder
353 return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToCpp field) $ AST.Var Nothing varName) : cpp)
355 binderToCpp _ _ ConstructorBinder{} =
356 internalError "binderToCpp: Invalid ConstructorBinder in binderToCpp"
357 binderToCpp varName done (NamedBinder _ ident binder) = do
358 cpp <- binderToCpp varName done binder
359 return (AST.VariableIntroduction Nothing (identToCpp ident) (Just (AST.Var Nothing varName)) : cpp)
361 literalToBinderCpp :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
362 literalToBinderCpp varName done (NumericLiteral num) =
363 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
364 literalToBinderCpp varName done (CharLiteral c) =
365 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
366 literalToBinderCpp varName done (StringLiteral str) =
367 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
368 literalToBinderCpp varName done (BooleanLiteral True) =
369 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]
370 literalToBinderCpp varName done (BooleanLiteral False) =
371 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]
372 -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
373 literalToBinderCpp varName done (ObjectLiteral bs) = go done bs
374 where
375 go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
376 go done' [] = return done'
377 go done' ((prop, binder):bs') = do
378 propVar <- freshName
379 done'' <- go done' bs'
380 cpp <- binderToCpp propVar done'' binder
381 return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : cpp)
382 literalToBinderCpp varName done (ArrayLiteral bs) = do
383 cpp <- go done 0 bs
384 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo
385 (arrayLength $ AST.Var Nothing varName)
386 (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))
387 (AST.Block Nothing cpp) Nothing]
388 where
389 go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
390 go done' _ [] = return done'
391 go done' index (binder:bs') = do
392 elVar <- freshName
393 done'' <- go done' (index + 1) bs'
394 cpp <- binderToCpp elVar done'' binder
395 return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : cpp)
397emptyAnn :: Ann
398emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)
400arrayLength :: AST -> AST
401arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]