git.iko.soy/rowtype-yoga/purescript-native
on 127af89 help sign in
rowtype-yoga/purescript-native/src/CodeGen/IL.hs
421 lines 20 kB history raw
1-- | This module generates code in the core imperative representation from
2-- elaborated PureScript code.
3module CodeGen.IL
4 ( module AST
5 , module Common
6 , moduleToIL
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, nub)
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.IL.Common as Common
39import CodeGen.IL.Optimizer
40import CodeGen.IL.Printer
42data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)
44-- | Generate code in the simplified intermediate representation for all declarations in a
45-- module.
46moduleToIL
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)
53moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =
54 do
55 let usedNames = concatMap getNames decls
56 let mnLookup = renameImports usedNames imps
57 ilImports <- traverse (importToIL mnLookup) . (\\ (mn : C.primModules)) . (\\ [mn]) $ ordNub $ map snd imps
58 interfaceImport <- importToIL (renameImports [] [(emptyAnn, mn)]) mn
59 let decls' = renameModules mnLookup decls
60 ilDecls <- mapM (bindToIL ModuleDecl) decls'
61 optimized <- traverse (traverse (optimize modName')) ilDecls
62 let optimized' = concat optimized
63 values = annotValue <$> optimized'
64 foreigns' = identToIL <$> foreigns
65 interface = interfaceSource modName values foreigns
66 implHeader = implHeaderSource modName ilImports interfaceImport
67 implFooter = implFooterSource modName foreigns
68 return $ (interface, foreigns', optimized', implHeader, implFooter)
69 where
70 modName = moduleNameToIL mn
71 modName' = AST.Var Nothing modName
73 annotValue :: AST -> (Text, Bool)
74 annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))
75 | isLiteral ret = (name, True)
76 annotValue (AST.Function _ (Just name) [] _) = (name, False)
77 annotValue _ = error "Unexpected top-level value form"
79 -- | Extracts all declaration names from a binding group.
80 getNames :: Bind Ann -> [Ident]
81 getNames (NonRec _ ident _) = [ident]
82 getNames (Rec vals) = map (snd . fst) vals
84 -- | Creates alternative names for each module to ensure they don't collide
85 -- with declaration names.
86 renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
87 renameImports = go M.empty
88 where
89 go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
90 go acc used ((ann, mn') : mns') =
91 let mni = Ident $ runModuleName mn'
92 in if mn' /= mn && mni `elem` used
93 then let newName = freshModuleName 1 mn' used
94 in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'
95 else go (M.insert mn' (ann, mn') acc) used mns'
96 go acc _ [] = acc
98 freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
99 freshModuleName i mn'@(ModuleName pns) used =
100 let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) <> "_" <> T.pack (show i)]
101 in if Ident (runModuleName newName) `elem` used
102 then freshModuleName (i + 1) mn' used
103 else newName
105 -- | Generates C++ code for a module import, binding the required module
106 -- to the alternative
107 importToIL :: M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m Text
108 importToIL mnLookup mn' = do
109 let ((_, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
110 mname = moduleNameToIL mnSafe
111 pure $ "#include \"" <> mname <> "/" <> mname <> ".h\"\n"
113 -- | Replaces the `ModuleName`s in the AST so that the generated code refers to
114 -- the collision-avoiding renamed module imports.
115 renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]
116 renameModules mnLookup binds =
117 let (f, _, _) = everywhereOnValues id goExpr goBinder
118 in map f binds
119 where
120 goExpr :: Expr a -> Expr a
121 goExpr (Var ann q) = Var ann (renameQual q)
122 goExpr e = e
123 goBinder :: Binder a -> Binder a
124 goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs
125 goBinder b = b
126 renameQual :: Qualified a -> Qualified a
127 renameQual (Qualified (Just mn') a) =
128 let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
129 in Qualified (Just mnSafe) a
130 renameQual q = q
132 -- |
133 -- Generate code in the simplified intermediate representation for a declaration
134 --
135 bindToIL :: DeclType -> Bind Ann -> m [AST]
136 bindToIL dt (NonRec ann ident val) = return <$> nonRecToIL dt ann ident val
137 bindToIL dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToIL dt')
138 where
139 dt' = if dt == LetDecl then RecLetDecl else dt
141 -- | Generate code in the simplified intermediate representation for a single non-recursive
142 -- declaration.
143 --
144 -- The main purpose of this function is to handle code generation for comments.
145 nonRecToIL :: DeclType -> Ann -> Ident -> Expr Ann -> m AST
146 nonRecToIL dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
147 -- withoutComment <- asks optionsNoComments
148 let withoutComment = False
149 if withoutComment
150 then nonRecToIL dt a i (modifyAnn removeComments e)
151 else AST.Comment Nothing com <$> nonRecToIL dt a i (modifyAnn removeComments e)
152 nonRecToIL ModuleDecl (ss, _, _, _) ident val = do
153 il <- valueToIL val
154 pure $ AST.Function Nothing (Just $ identToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])
155 nonRecToIL RecLetDecl (ss, _, _, _) ident val = do
156 il <- valueToIL val
157 pure $
158 let retainedName = identToIL ident
159 retained = AST.Var Nothing $ retainedName
160 unretainedName = retainedName <> unretainedSuffix
161 unretained = AST.Var Nothing $ unretainedName
162 boxed = AST.Var Nothing . -- Note: prevents optimizer from eliminating this
163 prettyPrintIL1 $
164 AST.VariableIntroduction
165 Nothing
166 retainedName
167 (Just unretained)
168 alias = AST.Var Nothing $ "auto& " <> retainedName <> " = " <> unretainedName
169 in
170 case il of
171 AST.Function _ name args (AST.Block Nothing ils) ->
172 AST.Assignment Nothing
173 retained
174 (AST.Function Nothing
175 name
176 args
177 (AST.Block Nothing (boxed : ils)))
178 _ ->
179 AST.Assignment Nothing
180 retained
181 (AST.App Nothing
182 (AST.Function Nothing
183 Nothing
184 []
185 (AST.Block Nothing ([ alias
186 , AST.Return Nothing il
187 ])))
188 [])
189 nonRecToIL _ (ss, _, _, _) ident val = do
190 il <- valueToIL val
191 pure $ AST.VariableIntroduction Nothing (identToIL ident) (Just il)
193 -- | Generate code in the simplified intermediate representation for a variable based on a
194 -- PureScript identifier.
195 var :: Ident -> AST
196 var = AST.Var Nothing . identToIL
198 accessorString :: PSString -> AST -> AST
199 accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
201 -- | Generate code in the simplified intermediate representation for a value or expression.
203 valueToIL :: Expr Ann -> m AST
204 valueToIL (Literal (pos, _, _, _) l) = literalToValueIL pos l
205 valueToIL (Accessor _ prop val) =
206 accessorString prop <$> valueToIL val
207 valueToIL (ObjectUpdate _ o ps) = do
208 obj <- valueToIL o
209 updates <- mapM (sndM valueToIL) ps
210 obj' <- freshName'
211 let objVar = AST.Var Nothing obj'
212 copy = AST.VariableIntroduction Nothing obj' (Just $ AST.App Nothing (AST.Var Nothing (unbox dictType)) [obj])
213 assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
214 sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
215 return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
216 valueToIL (Abs _ arg val) = do
217 ret <- valueToIL val
218 let ilArg = case arg of
219 UnusedIdent -> []
220 _ -> [identToIL arg]
221 return $ AST.Function Nothing Nothing ilArg (AST.Block Nothing [AST.Return Nothing ret])
222 valueToIL e@App{} = do
223 let (f, args) = unApp e []
224 args' <- mapM valueToIL args
225 case f of
226 Var (_, _, _, Just IsNewtype) _ -> return (head args')
227 _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToIL f
228 where
229 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
230 unApp (App _ val arg) args = unApp val (arg : args)
231 unApp other args = (other, args)
232 -- valueToIL (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
233 -- return $ if mn' == mn
234 -- then AST.Var Nothing (moduleNameToIL mn' <> "::" <> identToIL ident)
235 -- else varToIL qi
236 -- valueToIL (Var (_, _, _, Just IsForeign) (Qualified (Just mn') ident)) =
237 -- return $ AST.Var Nothing (moduleNameToIL mn' <> "::" <> identToIL ident)
238 -- valueToIL (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
239 -- return $ if mn' == mn
240 -- then foreignIdent ident
241 -- else varToIL qi
242 -- valueToIL (Var (_, _, _, Just IsForeign) ident) =
243 -- internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident)
244 valueToIL (Var _ ident) = return $ varToIL ident
245 valueToIL (Case (ss, _, _, _) values binders) = do
246 vals <- mapM valueToIL values
247 bindersToIL ss binders vals
248 valueToIL (Let _ ds val) = do
249 let recurs = concatMap getNames $ filter isRec ds
250 recurDs = (\v -> AST.Var Nothing $ "boxed::recur " <> identToIL v) <$> recurs
251 recurDsWeak = (\v -> AST.Var
252 Nothing
253 ("boxed::recur::weak " <> identToIL v <> unretainedSuffix <> "(" <> identToIL v <> ")")
254 ) <$> recurs
255 mutualRecurWarning = if any isMutRec $ filter isRec ds
256 then [AST.Var Nothing "#pragma message(\"Mutually recursive lets will cause retain cycles (memory leaks)\") //"]
257 else []
258 ds' <- concat <$> mapM (bindToIL LetDecl) ds
259 ret <- valueToIL val
260 return $
261 AST.App Nothing
262 (AST.Function Nothing
263 Nothing
264 []
265 (AST.Block Nothing (recurDs ++ recurDsWeak ++ mutualRecurWarning ++ ds' ++ [AST.Return Nothing ret])))
266 []
267 where
268 isRec :: Bind Ann -> Bool
269 isRec (Rec _) = True
270 isRec _ = False
271 isMutRec :: Bind Ann -> Bool
272 isMutRec b | (length . nub $ getNames b) > 1 = True
273 | otherwise = False
274 valueToIL (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"
275 valueToIL (Constructor _ _ (ProperName ctor) fields) =
276 let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :
277 ((\field -> (mkString (identToIL field), var field)) `map` fields)
278 fn = foldr (\f inner -> AST.Function Nothing Nothing [identToIL f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
279 in return fn
282 iife :: Text -> [AST] -> AST
283 iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
285 literalToValueIL :: SourceSpan -> Literal (Expr Ann) -> m AST
286 literalToValueIL ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
287 literalToValueIL ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)
288 literalToValueIL ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s
289 literalToValueIL ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])
290 literalToValueIL ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b
291 literalToValueIL ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToIL xs
292 literalToValueIL ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToIL) ps
294 -- | Generate code in the simplified intermediate representation for a reference to a
295 -- variable.
296 varToIL :: Qualified Ident -> AST
297 varToIL (Qualified Nothing ident) = var ident
298 varToIL qual = qualifiedToIL id qual
300 -- | Generate code in the simplified intermediate representation for a reference to a
301 -- variable that may have a qualified name.
302 qualifiedToIL :: (a -> Ident) -> Qualified a -> AST
303 qualifiedToIL f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = AST.Var Nothing . runIdent $ f a
304 qualifiedToIL f (Qualified (Just mn') a) = AST.Indexer Nothing (AST.Var Nothing . identToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))
305 qualifiedToIL f (Qualified _ a) = AST.Var Nothing $ identToIL (f a)
307 -- foreignIdent :: Ident -> AST
308 -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")
310 -- | Generate code in the simplified intermediate representation for pattern match binders
311 -- and guards.
312 bindersToIL :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
313 bindersToIL ss binders vals = do
314 valNames <- replicateM (length vals) freshName'
315 let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
316 ils <- forM binders $ \(CaseAlternative bs result) -> do
317 ret <- guardsToIL result
318 go valNames ret bs
319 return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat ils ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))
320 []
321 where
322 go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
323 go _ done [] = return done
324 go (v:vs) done' (b:bs) = do
325 done'' <- go vs done' bs
326 binderToIL v done'' b
327 go _ _ _ = internalError "Invalid arguments to bindersToIL"
329 failedPatternMessage :: Text
330 failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss <> ": "
332 guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
333 guardsToIL (Left gs) = traverse genGuard gs where
334 genGuard (cond, val) = do
335 cond' <- valueToIL cond
336 val' <- valueToIL val
337 return
338 (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))
339 (AST.Block Nothing [AST.Return Nothing val']) Nothing)
341 guardsToIL (Right v) = return . AST.Return Nothing <$> valueToIL v
343 -- | Generate code in the simplified intermediate representation for a pattern match
344 -- binder.
345 binderToIL :: Text -> [AST] -> Binder Ann -> m [AST]
346 binderToIL _ done NullBinder{} = return done
347 binderToIL varName done (LiteralBinder _ l) =
348 literalToBinderIL varName done l
349 binderToIL varName done (VarBinder _ ident) =
350 return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : done)
351 binderToIL varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
352 binderToIL varName done b
353 binderToIL varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do
354 il <- go (zip fields bs) done
355 return $ case ctorType of
356 ProductType -> il
357 SumType ->
358 [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))
359 (AST.Block Nothing il)
360 Nothing]
361 where
362 go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
363 go [] done' = return done'
364 go ((field, binder) : remain) done' = do
365 argVar <- freshName'
366 done'' <- go remain done'
367 il <- binderToIL argVar done'' binder
368 return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToIL field) $ AST.Var Nothing varName) : il)
370 binderToIL _ _ ConstructorBinder{} =
371 internalError "binderToIL: Invalid ConstructorBinder in binderToIL"
372 binderToIL varName done (NamedBinder _ ident binder) = do
373 il <- binderToIL varName done binder
374 return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : il)
376 literalToBinderIL :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
377 literalToBinderIL varName done (NumericLiteral num) =
378 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
379 literalToBinderIL varName done (CharLiteral c) =
380 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
381 literalToBinderIL varName done (StringLiteral str) =
382 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
383 literalToBinderIL varName done (BooleanLiteral True) =
384 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]
385 literalToBinderIL varName done (BooleanLiteral False) =
386 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]
387 -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
388 literalToBinderIL varName done (ObjectLiteral bs) = go done bs
389 where
390 go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
391 go done' [] = return done'
392 go done' ((prop, binder):bs') = do
393 propVar <- freshName'
394 done'' <- go done' bs'
395 il <- binderToIL propVar done'' binder
396 return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : il)
397 literalToBinderIL varName done (ArrayLiteral bs) = do
398 il <- go done 0 bs
399 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo
400 (arrayLength $ AST.Var Nothing varName)
401 (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))
402 (AST.Block Nothing il) Nothing]
403 where
404 go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
405 go done' _ [] = return done'
406 go done' index (binder:bs') = do
407 elVar <- freshName'
408 done'' <- go done' (index + 1) bs'
409 il <- binderToIL elVar done'' binder
410 return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : il)
412emptyAnn :: Ann
413emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)
415arrayLength :: AST -> AST
416arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
418freshName' :: MonadSupply m => m Text
419freshName' = do
420 name <- freshName
421 return $ T.replace "$" "_Local_" name