git.iko.soy/rowtype-yoga/purescript-native
on 54ee44d help sign in
rowtype-yoga/purescript-native/src/CodeGen/IL.hs
368 lines 18 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)
43data ImportType = Imported | Ignored
45-- | Generate code in the simplified intermediate representation for all declarations in a
46-- module.
47moduleToIL
48 :: forall m
49 -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
50 . (Monad m, MonadSupply m)
51 => Module Ann
52 -> Maybe AST
53 -> m (Text, [Text], [AST], Text, Text)
54moduleToIL (Module _ coms mn _ imps _ foreigns decls) _ =
55 do
56 let usedNames = concatMap getNames decls
57 let mnLookup = renameImports usedNames imps
58 imports <- traverse (importToIL Imported mnLookup) . (\\ (mn : C.primModules)) . (\\ [mn]) $ ordNub $ map snd imps
59 ignoredImports <- traverse (importToIL Ignored mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ (mn : C.primModules)) $ ordNub $ map snd imps
60 interfaceImport <- importToIL Imported (renameImports [] [(emptyAnn, mn)]) mn
61 let decls' = renameModules mnLookup decls
62 ilDecls <- mapM (bindToIL ModuleDecl) decls'
63 optimized <- traverse (traverse (optimize modName')) ilDecls
64 let optimized' = concat optimized
65 values = annotValue <$> optimized'
66 foreigns' = moduleIdentToIL <$> foreigns
67 interface = interfaceSource modName values foreigns
68 implHeader = implHeaderSource modName (imports ++ ignoredImports) interfaceImport
69 implFooter = implFooterSource modName foreigns
70 return $ (interface, foreigns', optimized', implHeader, implFooter)
71 where
72 modName = moduleNameToIL mn
73 modName' = AST.Var Nothing modName
75 annotValue :: AST -> (Text, Bool)
76 annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))
77 | isLiteral ret = (name, True)
78 annotValue (AST.Function _ (Just name) [] _) = (name, False)
79 annotValue _ = error "Unexpected top-level value form"
81 -- | Extracts all declaration names from a binding group.
82 getNames :: Bind Ann -> [Ident]
83 getNames (NonRec _ ident _) = [ident]
84 getNames (Rec vals) = map (snd . fst) vals
86 -- | Creates alternative names for each module to ensure they don't collide
87 -- with declaration names.
88 renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
89 renameImports = go M.empty
90 where
91 go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)
92 go acc used ((ann, mn') : mns') =
93 let mni = Ident $ runModuleName mn'
94 in if mn' /= mn && mni `elem` used
95 then let newName = freshModuleName 1 mn' used
96 in go (M.insert mn' (ann, newName) acc) (Ident (runModuleName newName) : used) mns'
97 else go (M.insert mn' (ann, mn') acc) used mns'
98 go acc _ [] = acc
100 freshModuleName :: Integer -> ModuleName -> [Ident] -> ModuleName
101 freshModuleName i mn'@(ModuleName pns) used =
102 let newName = ModuleName $ init pns ++ [ProperName $ runProperName (last pns) <> "_" <> T.pack (show i)]
103 in if Ident (runModuleName newName) `elem` used
104 then freshModuleName (i + 1) mn' used
105 else newName
107 -- | Generates IL code for a module import, binding the required module
108 -- to the alternative
109 importToIL :: ImportType -> M.Map ModuleName (Ann, ModuleName) -> ModuleName -> m Text
110 importToIL t mnLookup mn' = do
111 let ((_, _, _, _), mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
112 mname = moduleNameToIL mnSafe
113 pure $ case t of
114 Imported -> "import \"" <> mname <> "\"\n"
115 Ignored -> "type _ = " <> mname <> ".IGNORE_UNUSED_IMPORTS\n"
117 -- | Replaces the `ModuleName`s in the AST so that the generated code refers to
118 -- the collision-avoiding renamed module imports.
119 renameModules :: M.Map ModuleName (Ann, ModuleName) -> [Bind Ann] -> [Bind Ann]
120 renameModules mnLookup binds =
121 let (f, _, _) = everywhereOnValues id ilExpr goBinder
122 in map f binds
123 where
124 ilExpr :: Expr a -> Expr a
125 ilExpr (Var ann q) = Var ann (renameQual q)
126 ilExpr e = e
127 goBinder :: Binder a -> Binder a
128 goBinder (ConstructorBinder ann q1 q2 bs) = ConstructorBinder ann (renameQual q1) (renameQual q2) bs
129 goBinder b = b
130 renameQual :: Qualified a -> Qualified a
131 renameQual (Qualified (Just mn') a) =
132 let (_,mnSafe) = fromMaybe (internalError "Missing value in mnLookup") $ M.lookup mn' mnLookup
133 in Qualified (Just mnSafe) a
134 renameQual q = q
136 -- |
137 -- Generate code in the simplified intermediate representation for a declaration
138 --
139 bindToIL :: DeclType -> Bind Ann -> m [AST]
140 bindToIL dt (NonRec ann ident val) = return <$> nonRecToIL dt ann ident val
141 bindToIL dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToIL dt')
142 where
143 dt' = if dt == LetDecl then RecLetDecl else dt
145 -- | Generate code in the simplified intermediate representation for a single non-recursive
146 -- declaration.
147 --
148 -- The main purpose of this function is to handle code generation for comments.
149 nonRecToIL :: DeclType -> Ann -> Ident -> Expr Ann -> m AST
150 nonRecToIL dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
151 -- withoutComment <- asks optionsNoComments
152 let withoutComment = False
153 if withoutComment
154 then nonRecToIL dt a i (modifyAnn removeComments e)
155 else AST.Comment Nothing com <$> nonRecToIL dt a i (modifyAnn removeComments e)
156 nonRecToIL ModuleDecl (ss, _, _, _) ident val = do
157 il <- valueToIL val
158 pure $ AST.Function Nothing (Just $ moduleIdentToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])
159 nonRecToIL RecLetDecl (ss, _, _, _) ident val = do
160 ilExpr <- valueToIL val
161 pure $ AST.Assignment Nothing (AST.Var Nothing $ identToIL ident) ilExpr
162 nonRecToIL _ (ss, _, _, _) ident val = do
163 il <- valueToIL val
164 pure $ AST.VariableIntroduction Nothing (identToIL ident) (Just il)
166 -- | Generate code in the simplified intermediate representation for a variable based on a
167 -- PureScript identifier.
168 var :: Ident -> AST
169 var = AST.Var Nothing . identToIL
171 accessorString :: PSString -> AST -> AST
172 accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
174 -- | Generate code in the simplified intermediate representation for a value or expression.
176 valueToIL :: Expr Ann -> m AST
177 valueToIL (Literal (pos, _, _, _) l) = literalToValueIL pos l
178 valueToIL (Accessor _ prop val) =
179 accessorString prop <$> valueToIL val
180 valueToIL (ObjectUpdate _ o ps) = do
181 obj <- valueToIL o
182 updates <- mapM (sndM valueToIL) ps
183 obj' <- freshName'
184 let objVar = AST.Var Nothing obj'
185 copy = AST.VariableIntroduction Nothing obj' (Just $ AST.App Nothing (AST.Var Nothing (unbox dictType)) [obj])
186 assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
187 sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
188 return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
189 valueToIL (Abs _ arg val) = do
190 ret <- valueToIL val
191 let ilArg = case arg of
192 UnusedIdent -> []
193 _ -> [identToIL arg]
194 return $ AST.Function Nothing Nothing ilArg (AST.Block Nothing [AST.Return Nothing ret])
195 valueToIL e@App{} = do
196 let (f, args) = unApp e []
197 args' <- mapM valueToIL args
198 fn <- valueToIL f
199 case f of
200 Var (_, _, _, Just IsNewtype) _ -> return (head args')
201 _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToIL f
202 where
203 unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
204 unApp (App _ val arg) args = unApp val (arg : args)
205 unApp other args = (other, args)
206 valueToIL (Var _ ident) = return $ varToIL ident
207 valueToIL (Case (ss, _, _, _) values binders) = do
208 vals <- mapM valueToIL values
209 bindersToIL ss binders vals
210 valueToIL (Let _ ds val) = do
211 let recurs = concatMap getNames $ filter isRec ds
212 recurDs = (\v -> AST.VariableIntroduction Nothing (identToIL v) Nothing) <$> recurs
213 ds' <- concat <$> mapM (bindToIL LetDecl) ds
214 ret <- valueToIL val
215 return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (recurDs ++ ds' ++ [AST.Return Nothing ret]))) []
216 where
217 isRec :: Bind Ann -> Bool
218 isRec (Rec _) = True
219 isRec _ = False
220 valueToIL (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"
221 valueToIL (Constructor _ _ (ProperName ctor) fields) =
222 let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :
223 ((\field -> (mkString (identToIL field), var field)) `map` fields)
224 fn = foldr (\f inner -> AST.Function Nothing Nothing [identToIL f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
225 in return fn
228 iife :: Text -> [AST] -> AST
229 iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
231 literalToValueIL :: SourceSpan -> Literal (Expr Ann) -> m AST
232 literalToValueIL ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
233 literalToValueIL ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)
234 literalToValueIL ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s
235 literalToValueIL ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])
236 literalToValueIL ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b
237 literalToValueIL ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToIL xs
238 literalToValueIL ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToIL) ps
240 -- | Generate code in the simplified intermediate representation for a reference to a
241 -- variable.
242 varToIL :: Qualified Ident -> AST
243 varToIL (Qualified Nothing ident) = var ident
244 varToIL qual = qualifiedToIL id qual
246 -- | Generate code in the simplified intermediate representation for a reference to a
247 -- variable that may have a qualified name.
248 qualifiedToIL :: (a -> Ident) -> Qualified a -> AST
249 qualifiedToIL f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = AST.Var Nothing . moduleIdentToIL $ f a
250 qualifiedToIL f (Qualified (Just mn') a) | mn /= mn' = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))
251 qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing "")
253 -- foreignIdent :: Ident -> AST
254 -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")
256 -- | Generate code in the simplified intermediate representation for pattern match binders
257 -- and guards.
258 bindersToIL :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
259 bindersToIL ss binders vals = do
260 valNames <- replicateM (length vals) freshName'
261 let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
262 ils <- forM binders $ \(CaseAlternative bs result) -> do
263 ret <- guardsToIL result
264 go valNames ret bs
265 return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat ils ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))
266 []
267 where
268 go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
269 go _ done [] = return done
270 go (v:vs) done' (b:bs) = do
271 done'' <- go vs done' bs
272 binderToIL v done'' b
273 go _ _ _ = internalError "Invalid arguments to bindersToIL"
275 failedPatternMessage :: Text
276 failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss <> ": "
278 guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
279 guardsToIL (Left gs) = traverse genGuard gs where
280 genGuard (cond, val) = do
281 cond' <- valueToIL cond
282 val' <- valueToIL val
283 return
284 (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))
285 (AST.Block Nothing [AST.Return Nothing val']) Nothing)
287 guardsToIL (Right v) = return . AST.Return Nothing <$> valueToIL v
289 -- | Generate code in the simplified intermediate representation for a pattern match
290 -- binder.
291 binderToIL :: Text -> [AST] -> Binder Ann -> m [AST]
292 binderToIL _ done NullBinder{} = return done
293 binderToIL varName done (LiteralBinder _ l) =
294 literalToBinderIL varName done l
295 binderToIL varName done (VarBinder _ ident) =
296 return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : done)
297 binderToIL varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
298 binderToIL varName done b
299 binderToIL varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do
300 il <- go (zip fields bs) done
301 return $ case ctorType of
302 ProductType -> il
303 SumType ->
304 [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))
305 (AST.Block Nothing il)
306 Nothing]
307 where
308 go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
309 go [] done' = return done'
310 go ((field, binder) : remain) done' = do
311 argVar <- freshName'
312 done'' <- go remain done'
313 il <- binderToIL argVar done'' binder
314 return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToIL field) $ AST.Var Nothing varName) : il)
316 binderToIL _ _ ConstructorBinder{} =
317 internalError "binderToIL: Invalid ConstructorBinder in binderToIL"
318 binderToIL varName done (NamedBinder _ ident binder) = do
319 il <- binderToIL varName done binder
320 return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : il)
322 literalToBinderIL :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
323 literalToBinderIL varName done (NumericLiteral num) =
324 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
325 literalToBinderIL varName done (CharLiteral c) =
326 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
327 literalToBinderIL varName done (StringLiteral str) =
328 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
329 literalToBinderIL varName done (BooleanLiteral True) =
330 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]
331 literalToBinderIL varName done (BooleanLiteral False) =
332 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]
333 -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
334 literalToBinderIL varName done (ObjectLiteral bs) = go done bs
335 where
336 go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
337 go done' [] = return done'
338 go done' ((prop, binder):bs') = do
339 propVar <- freshName'
340 done'' <- go done' bs'
341 il <- binderToIL propVar done'' binder
342 return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : il)
343 literalToBinderIL varName done (ArrayLiteral bs) = do
344 il <- go done 0 bs
345 return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo
346 (arrayLength $ AST.Var Nothing varName)
347 (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))
348 (AST.Block Nothing il) Nothing]
349 where
350 go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
351 go done' _ [] = return done'
352 go done' index (binder:bs') = do
353 elVar <- freshName'
354 done'' <- go done' (index + 1) bs'
355 il <- binderToIL elVar done'' binder
356 return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : il)
358emptyAnn :: Ann
359emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)
361arrayLength :: AST -> AST
362arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
363-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")
365freshName' :: MonadSupply m => m Text
366freshName' = do
367 name <- freshName
368 return $ T.replace "$" "ᵗ" name