git.iko.soy/Idris-dev
on f869396 help sign in
Idris-dev/src/IRTS/CodegenJava.hs
780 lines 28 kB history raw
1{-# LANGUAGE PatternGuards #-}
2module IRTS.CodegenJava (codegenJava) where
4import Core.TT hiding (mkApp)
5import IRTS.BCImp
6import IRTS.CodegenCommon
7import IRTS.Java.ASTBuilding
8import IRTS.Java.JTypes
9import IRTS.Java.Mangling
10import IRTS.Lang
11import IRTS.Simplified
12import Paths_idris
13import Util.System
15import Control.Applicative hiding (Const)
16import Control.Arrow
17import Control.Monad
18import Control.Monad.Error
19import qualified Control.Monad.Trans as T
20import Control.Monad.Trans.State
21import Data.Int
22import Data.List (foldl', intercalate, isPrefixOf,
23 isSuffixOf)
24import Data.Maybe (fromJust)
25import qualified Data.Text as T
26import qualified Data.Text.IO as TIO
27import qualified Data.Vector.Unboxed as V
28import Language.Java.Parser
29import Language.Java.Pretty
30import Language.Java.Syntax hiding (Name)
31import qualified Language.Java.Syntax as J
32import System.Directory
33import System.Exit
34import System.FilePath
35import System.IO
36import System.Process
38-----------------------------------------------------------------------
39-- Main function
40codegenJava :: [(Name, SExp)] -> -- initialization of globals
41 [(Name, SDecl)] -> -- decls
42 FilePath -> -- output file name
43 [String] -> -- headers
44 [String] -> -- libs
45 OutputType ->
46 IO ()
47codegenJava globalInit defs out hdrs libs exec =
48 withTgtDir exec out (codegenJava' exec)
49 where
50 codegenJava' :: OutputType -> FilePath -> IO ()
51 codegenJava' Raw tgtDir = do
52 srcDir <- prepareSrcDir exec tgtDir
53 generateJavaFile globalInit defs hdrs srcDir out
54 codegenJava' MavenProject tgtDir = do
55 codegenJava' Raw tgtDir
56 generatePom tgtDir out libs
57 codegenJava' Object tgtDir = do
58 codegenJava' MavenProject tgtDir
59 invokeMvn tgtDir "compile"
60 copyClassFiles tgtDir out
61 cleanUpTmp tgtDir
62 codegenJava' _ tgtDir = do
63 codegenJava' MavenProject tgtDir
64 invokeMvn tgtDir "package";
65 copyJar tgtDir out
66 makeJarExecutable out
67 cleanUpTmp tgtDir
69-----------------------------------------------------------------------
70-- Compiler IO
72withTgtDir :: OutputType -> FilePath -> (FilePath -> IO ()) -> IO ()
73withTgtDir Raw out action = action (dropFileName out)
74withTgtDir MavenProject out action = createDirectoryIfMissing False out >> action out
75withTgtDir _ out action = withTempdir (takeBaseName out) action
77prepareSrcDir :: OutputType -> FilePath -> IO FilePath
78prepareSrcDir Raw tgtDir = return tgtDir
79prepareSrcDir _ tgtDir = do
80 let srcDir = (tgtDir </> "src" </> "main" </> "java")
81 createDirectoryIfMissing True srcDir
82 return srcDir
84javaFileName :: FilePath -> FilePath -> FilePath
85javaFileName srcDir out =
86 either error (\ (Ident clsName) -> srcDir </> clsName <.> "java") (mkClassName out)
88generateJavaFile :: [(Name, SExp)] -> -- initialization of globals
89 [(Name, SDecl)] -> -- definitions
90 [String] -> -- headers
91 FilePath -> -- Source dir
92 FilePath -> -- output target
93 IO ()
94generateJavaFile globalInit defs hdrs srcDir out = do
95 let code = either error
96 (prettyPrint)-- flatIndent . prettyPrint)
97 (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv)
98 writeFile (javaFileName srcDir out) code
100pomFileName :: FilePath -> FilePath
101pomFileName tgtDir = tgtDir </> "pom.xml"
103generatePom :: FilePath -> -- tgt dir
104 FilePath -> -- output target
105 [String] -> -- libs
106 IO ()
107generatePom tgtDir out libs = do
108 execPom <- getExecutablePom
109 execPomTemplate <- TIO.readFile execPom
110 let (Ident clsName) = either error id (mkClassName out)
111 let execPom = T.replace (T.pack "$MAIN-CLASS$")
112 (T.pack clsName)
113 (T.replace (T.pack "$ARTIFACT-NAME$")
114 (T.pack $ takeBaseName out)
115 (T.replace (T.pack "$DEPENDENCIES$")
116 (mkPomDependencies libs)
117 execPomTemplate
118 )
119 )
120 TIO.writeFile (pomFileName tgtDir) execPom
122invokeMvn :: FilePath -> String -> IO ()
123invokeMvn tgtDir command = do
124 mvnCmd <- getMvn
125 let args = ["-f", pomFileName tgtDir]
126 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ [command]) ""
127 when (exit /= ExitSuccess) $
128 error ("FAILURE: " ++ mvnCmd ++ " " ++ command ++ "\n" ++ err ++ mvout)
130classFileDir :: FilePath -> FilePath
131classFileDir tgtDir = tgtDir </> "target" </> "classes"
133copyClassFiles :: FilePath -> FilePath -> IO ()
134copyClassFiles tgtDir out = do
135 classFiles <- map (\ clsFile -> classFileDir tgtDir </> clsFile)
136 . filter ((".class" ==) . takeExtension)
137 <$> getDirectoryContents (classFileDir tgtDir)
138 mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile)) classFiles
140jarFileName :: FilePath -> FilePath -> FilePath
141jarFileName tgtDir out = tgtDir </> "target" </> (takeBaseName out) <.> "jar"
143copyJar :: FilePath -> FilePath -> IO ()
144copyJar tgtDir out =
145 copyFile (jarFileName tgtDir out) out
147makeJarExecutable :: FilePath -> IO ()
148makeJarExecutable out = do
149 handle <- openBinaryFile out ReadMode
150 contents <- TIO.hGetContents handle
151 hClose handle
152 handle <- openBinaryFile out WriteMode
153 TIO.hPutStr handle (T.append (T.pack jarHeader) contents)
154 hFlush handle
155 hClose handle
156 perms <- getPermissions out
157 setPermissions out (setOwnerExecutable True perms)
159removePom :: FilePath -> IO ()
160removePom tgtDir = removeFile (pomFileName tgtDir)
162cleanUpTmp :: FilePath -> IO ()
163cleanUpTmp tgtDir = do
164 invokeMvn tgtDir "clean"
165 removePom tgtDir
167-----------------------------------------------------------------------
168-- Jar and Pom infrastructure
170jarHeader :: String
171jarHeader =
172 "#!/bin/sh\n"
173 ++ "MYSELF=`which \"$0\" 2>/dev/null`\n"
174 ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n"
175 ++ "java=java\n"
176 ++ "if test -n \"$JAVA_HOME\"; then\n"
177 ++ " java=\"$JAVA_HOME/bin/java\"\n"
178 ++ "fi\n"
179 ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\""
180 ++ "exit 1\n"
182mkPomDependencies :: [String] -> T.Text
183mkPomDependencies deps =
184 T.concat $ map (T.concat . map (T.append (T.pack " ")) . mkDependency . T.pack) deps
185 where
186 mkDependency s =
187 case T.splitOn (T.pack ":") s of
188 [g, a, v] ->
189 [ T.pack $ "<dependency>\n"
190 , T.append (T.pack " ") $ mkGroupId g
191 , T.append (T.pack " ") $ mkArtifactId a
192 , T.append (T.pack " ") $ mkVersion v
193 , T.pack $ "</dependency>\n"
194 ]
195 _ -> []
196 mkGroupId g = T.append (T.pack $ "<groupId>") (T.append g $ T.pack "</groupId>\n")
197 mkArtifactId a = T.append (T.pack $ "<artifactId>") (T.append a $ T.pack "</artifactId>\n")
198 mkVersion v = T.append (T.pack $ "<version>") (T.append v $ T.pack "</version>\n")
200-----------------------------------------------------------------------
201-- Code generation environment
203data CodeGenerationEnv
204 = CodeGenerationEnv
205 { globalVariables :: [(Name, ArrayIndex)]
206 , localVariables :: [[(Int, Ident)]]
207 , localVarCounter :: Int
208 }
210type CodeGeneration = StateT (CodeGenerationEnv) (Either String)
212mkCodeGenEnv :: CodeGenerationEnv
213mkCodeGenEnv = CodeGenerationEnv [] [] 0
215varPos :: LVar -> CodeGeneration (Either ArrayIndex Ident)
216varPos (Loc i) = do
217 vars <- (concat . localVariables) <$> get
218 case lookup i vars of
219 (Just varName) -> return (Right varName)
220 Nothing -> throwError $ "Invalid local variable id: " ++ show i
221varPos (Glob name) = do
222 vars <- globalVariables <$> get
223 case lookup name vars of
224 (Just varIdx) -> return (Left varIdx)
225 Nothing -> throwError $ "Invalid global variable id: " ++ show name
227pushScope :: CodeGeneration ()
228pushScope =
229 modify (\ env -> env { localVariables = []:(localVariables env) })
231popScope :: CodeGeneration ()
232popScope = do
233 env <- get
234 let lVars = tail $ localVariables env
235 let vC = if null lVars then 0 else localVarCounter env
236 put $ env { localVariables = tail (localVariables env)
237 , localVarCounter = vC }
239setVariable :: LVar -> CodeGeneration (Either ArrayIndex Ident)
240setVariable (Loc i) = do
241 env <- get
242 let lVars = localVariables env
243 let getter = localVar $ localVarCounter env
244 let lVars' = ((i, getter) : head lVars) : tail lVars
245 put $ env { localVariables = lVars'
246 , localVarCounter = 1 + localVarCounter env}
247 return (Right getter)
248setVariable (Glob n) = do
249 env <- get
250 let gVars = globalVariables env
251 let getter = globalContext @! length gVars
252 let gVars' = (n, getter):gVars
253 put (env { globalVariables = gVars' })
254 return (Left getter)
256pushParams :: [Ident] -> CodeGeneration ()
257pushParams paramNames =
258 let varMap = zipWith (flip (,)) paramNames [0..] in
259 modify (\ env -> env { localVariables = varMap:(localVariables env)
260 , localVarCounter = (length varMap) + (localVarCounter env) })
262flatIndent :: String -> String
263flatIndent (' ' : ' ' : xs) = flatIndent xs
264flatIndent (x:xs) = x:flatIndent xs
265flatIndent [] = []
267-----------------------------------------------------------------------
268-- Maintaining control structures over code blocks
270data BlockPostprocessor
271 = BlockPostprocessor
272 { ppInnerBlock :: [BlockStmt] -> Exp -> CodeGeneration [BlockStmt]
273 , ppOuterBlock :: [BlockStmt] -> CodeGeneration [BlockStmt]
274 }
276ppExp :: BlockPostprocessor -> Exp -> CodeGeneration [BlockStmt]
277ppExp pp exp = ((ppInnerBlock pp) [] exp) >>= ppOuterBlock pp
279addReturn :: BlockPostprocessor
280addReturn =
281 BlockPostprocessor
282 { ppInnerBlock = (\ block exp -> return $ block ++ [jReturn exp])
283 , ppOuterBlock = return
284 }
286ignoreResult :: BlockPostprocessor
287ignoreResult =
288 BlockPostprocessor
289 { ppInnerBlock = (\ block exp -> return block)
290 , ppOuterBlock = return
291 }
293ignoreOuter :: BlockPostprocessor -> BlockPostprocessor
294ignoreOuter pp = pp { ppOuterBlock = return }
296throwRuntimeException :: BlockPostprocessor -> BlockPostprocessor
297throwRuntimeException pp =
298 pp
299 { ppInnerBlock =
300 (\ blk exp -> return $
301 blk ++ [ BlockStmt $ Throw
302 ( InstanceCreation
303 []
304 (toClassType runtimeExceptionType)
305 [exp]
306 Nothing
307 )
308 ]
309 )
310 }
313rethrowAsRuntimeException :: BlockPostprocessor -> BlockPostprocessor
314rethrowAsRuntimeException pp =
315 pp
316 { ppOuterBlock =
317 (\ blk -> do
318 ex <- ppInnerBlock (throwRuntimeException pp) [] (ExpName $ J.Name [Ident "ex"])
319 ppOuterBlock pp
320 $ [ BlockStmt $ Try
321 (Block blk)
322 [Catch (FormalParam [] exceptionType False (VarId (Ident "ex"))) $
323 Block ex
324 ]
325 Nothing
326 ]
327 )
328 }
330-----------------------------------------------------------------------
331-- File structure
333mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit
334mkCompilationUnit globalInit defs hdrs out = do
335 clsName <- mkClassName out
336 CompilationUnit Nothing ( [ ImportDecl False idrisRts True
337 , ImportDecl True idrisPrelude True
338 , ImportDecl False bigInteger False
339 , ImportDecl False runtimeException False
340 ] ++ otherHdrs
341 )
342 <$> mkTypeDecl clsName globalInit defs
343 where
344 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
345 idrisPrelude = J.Name $ map Ident ["org", "idris", "rts", "Prelude"]
346 bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
347 runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
348 otherHdrs = map ( (\ name -> ImportDecl False name False)
349 . J.Name
350 . map (Ident . T.unpack)
351 . T.splitOn (T.pack ".")
352 . T.pack)
353 $ filter (not . isSuffixOf ".h") hdrs
355-----------------------------------------------------------------------
356-- Main class
358mkTypeDecl :: Ident -> [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration [TypeDecl]
359mkTypeDecl name globalInit defs =
360 (\ body -> [ClassTypeDecl $ ClassDecl [ Public
361 , Annotation $ SingleElementAnnotation
362 (jName "SuppressWarnings")
363 (EVVal . InitExp $ jString "unchecked")
364 ]
365 name
366 []
367 Nothing
368 []
369 body])
370 <$> mkClassBody globalInit (map (second (prefixCallNamespaces name)) defs)
372mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody
373mkClassBody globalInit defs =
374 (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)
375 <$> mkGlobalContext globalInit
376 <*> mapM mkDecl defs
378mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
379mkGlobalContext [] = return []
380mkGlobalContext initExps = do
381 pushScope
382 varInit <-
383 mapM (\ (name, exp) -> do
384 pos <- setVariable (Glob name)
385 mkUpdate ignoreResult (Glob name) exp
386 ) initExps
387 popScope
388 return [ MemberDecl $ FieldDecl [Private, Static, Final]
389 (array objectType)
390 [ VarDecl (VarId $ globalContextID). Just . InitExp
391 $ ArrayCreate objectType [jInt $ length initExps] 0
392 ]
393 , InitDecl True (Block $ concat varInit)
394 ]
396addMainMethod :: [Decl] -> [Decl]
397addMainMethod decls
398 | findMain decls = mkMainMethod : decls
399 | otherwise = decls
400 where
401 findMain ((MemberDecl (MemberClassDecl (ClassDecl _ name _ _ _ (ClassBody body)))):_)
402 | name == mangle' (UN "Main") = findMainMethod body
403 findMain (_:decls) = findMain decls
404 findMain [] = False
406 innerMainMethod = (either error id $ mangle (UN "main"))
407 findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_)
408 | name == mangle' (UN "main") = True
409 findMainMethod (_:decls) = findMainMethod decls
410 findMainMethod [] = False
412mkMainMethod :: Decl
413mkMainMethod =
414 simpleMethod
415 [Public, Static]
416 Nothing
417 "main"
418 [FormalParam [] (array stringType) False (VarId $ Ident "args")]
419 $ Block [ BlockStmt . ExpStmt
420 $ call "idris_initArgs" [ (threadType ~> "currentThread") []
421 , jConst "args"
422 ]
423 , BlockStmt . ExpStmt $ call (mangle' (MN 0 "runMain")) []
424 ]
426-----------------------------------------------------------------------
427-- Inner classes (idris namespaces)
429mergeInnerClasses :: [Decl] -> [Decl]
430mergeInnerClasses = foldl' mergeInner []
431 where
432 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)
433 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))
434 | name == name' =
435 (MemberDecl $ MemberClassDecl $
436 ClassDecl priv
437 name
438 targs
439 (mplus ext ext')
440 (imp ++ imp')
441 (ClassBody $ mergeInnerClasses (body ++ body')))
442 : decls
443 | otherwise = decl:(mergeInner decls decl')
444 mergeInner (decl:decls) decl' = decl:(mergeInner decls decl')
445 mergeInner [] decl' = [decl']
449mkDecl :: (Name, SDecl) -> CodeGeneration Decl
450mkDecl ((NS n (ns:nss)), decl) =
451 (\ name body ->
452 MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
453 <$> mangle (UN ns)
454 <*> mkClassBody [] [(NS n nss, decl)]
455mkDecl (_, SFun name params stackSize body) = do
456 (Ident methodName) <- mangle name
457 methodParams <- mapM mkFormalParam params
458 paramNames <- mapM mangle params
459 pushParams paramNames
460 methodBody <- mkExp addReturn body
461 popScope
462 return $
463 simpleMethod [Public, Static] (Just objectType) methodName methodParams
464 (Block methodBody)
466mkFormalParam :: Name -> CodeGeneration FormalParam
467mkFormalParam name =
468 (\ name -> FormalParam [Final] objectType False (VarId name))
469 <$> mangle name
471-----------------------------------------------------------------------
472-- Expressions
474-- | Compile a simple expression and use the given continuation to postprocess
475-- the resulting value.
476mkExp :: BlockPostprocessor -> SExp -> CodeGeneration [BlockStmt]
477-- Variables
478mkExp pp (SV var) =
479 (Nothing <>@! var) >>= ppExp pp
481-- Applications
482mkExp pp (SApp pushTail name args) =
483 mkApp pushTail name args >>= ppExp pp
485-- Bindings
486mkExp pp (SLet var newExp inExp) =
487 mkLet pp var newExp inExp
488mkExp pp (SUpdate var newExp) =
489 mkUpdate pp var newExp
491-- Objects
492mkExp pp (SCon conId _ args) =
493 mkIdrisObject conId args >>= ppExp pp
495-- Case expressions
496mkExp pp (SCase var alts) = mkCase pp True var alts
497mkExp pp (SChkCase var alts) = mkCase pp False var alts
499-- Projections
500mkExp pp (SProj var i) =
501 mkProjection var i >>= ppExp pp
503-- Constants
504mkExp pp (SConst c) =
505 ppExp pp $ mkConstant c
507-- Foreign function calls
508mkExp pp (SForeign lang resTy text params) =
509 mkForeign pp lang resTy text params
511-- Primitive functions
512mkExp pp (SOp LFork [arg]) =
513 (mkThread arg) >>= ppExp pp
514mkExp pp (SOp LPar [arg]) =
515 (Nothing <>@! arg) >>= ppExp pp
516mkExp pp (SOp LNoOp args) =
517 (Nothing <>@! (last args)) >>= ppExp pp
518mkExp pp (SOp op args) =
519 (mkPrimitiveFunction op args) >>= ppExp pp
521-- Empty expressions
522mkExp pp (SNothing) = ppExp pp $ Lit Null
524-- Errors
525mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err)
527-----------------------------------------------------------------------
528-- Variable access
530(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp
531(<>@!) Nothing var =
532 either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var
533(<>@!) (Just castTo) var =
534 (castTo <>) <$> (Nothing <>@! var)
536-----------------------------------------------------------------------
537-- Application (wrap method calls in tail call closures)
539mkApp :: Bool -> Name -> [LVar] -> CodeGeneration Exp
540mkApp False name args =
541 (\ methodName params ->
542 (idrisClosureType ~> "unwrapTailCall") [call methodName params]
543 )
544 <$> mangleFull name
545 <*> mapM (Nothing <>@!) args
546mkApp True name args = mkMethodCallClosure name args
548mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp
549mkMethodCallClosure name args =
550 (\ name args -> closure (call name args))
551 <$> mangleFull name
552 <*> mapM (Nothing <>@!) args
554-----------------------------------------------------------------------
555-- Updates (change context array) and Let bindings (Update, execute)
557mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt]
558mkUpdate pp var exp =
559 mkExp
560 ( pp
561 { ppInnerBlock =
562 (\ blk rhs -> do
563 pos <- setVariable var
564 vExp <- Nothing <>@! var
565 ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp
566 )
567 }
568 ) exp
570mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt]
571mkLet pp var@(Loc pos) newExp inExp =
572 mkUpdate (pp { ppInnerBlock =
573 (\ blk _ -> do
574 inBlk <- mkExp pp inExp
575 return (blk ++ inBlk)
576 )
577 }
578 ) var newExp
579mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
581-----------------------------------------------------------------------
582-- Object creation
584mkIdrisObject :: Int -> [LVar] -> CodeGeneration Exp
585mkIdrisObject conId args =
586 (\ args ->
587 InstanceCreation [] (toClassType idrisObjectType) ((jInt conId):args) Nothing
588 )
589 <$> mapM (Nothing <>@!) args
591-----------------------------------------------------------------------
592-- Case expressions
594mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt]
595mkCase pp checked var cases
596 | isDefaultOnlyCase cases = mkDefaultMatch pp cases
597 | isConstCase cases = do
598 ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
599 ppOuterBlock pp [BlockStmt ifte]
600 | otherwise = do
601 switchExp <- mkGetConstructorId checked var
602 matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
603 ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks]
605isConstCase :: [SAlt] -> Bool
606isConstCase ((SConstCase _ _):_) = True
607isConstCase ((SDefaultCase _):cases) = isConstCase cases
608isConstCase _ = False
610isDefaultOnlyCase :: [SAlt] -> Bool
611isDefaultOnlyCase [SDefaultCase _] = True
612isDefaultOnlyCase [] = True
613isDefaultOnlyCase _ = False
615mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt]
616mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) =
617 do pushScope
618 stmt <- mkExp pp branchExpression
619 popScope
620 return stmt
621mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs
622mkDefaultMatch pp [] =
623 ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern")
625mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp
626mkMatchConstExp var c
627 | isPrimitive cty =
628 (\ var -> (primFnType ~> opName (LEq undefined)) [var, jc] ~==~ jInt 1)
629 <$> (Just cty <>@! var)
630 | isArray cty =
631 (\ var -> (arraysType ~> "equals") [var, jc])
632 <$> (Just cty <>@! var)
633 | isString cty =
634 (\ var -> ((primFnType ~> opName (LStrEq)) [var, jc] ~==~ jInt 1))
635 <$> (Just cty <>@! var)
636 | otherwise =
637 (\ var -> (var ~> "equals") [jc])
638 <$> (Just cty <>@! var)
639 where
640 cty = constType c
641 jc = mkConstant c
643mkConstMatch :: BlockPostprocessor ->
644 (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
645 LVar ->
646 [SAlt] ->
647 CodeGeneration Stmt
648mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do
649 matchExp <- mkMatchConstExp var constant
650 pushScope
651 branchBlock <- mkExp pp branchExpression
652 popScope
653 otherBranches <- mkConstMatch pp getDefaultStmts var cases
654 return
655 $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches
656mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases
657mkConstMatch pp getDefaultStmts _ [] = do
658 defaultBlock <- getDefaultStmts pp
659 return $ StmtBlock (Block defaultBlock)
661mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp
662mkGetConstructorId True var =
663 (\ var -> ((idrisObjectType <> var) ~> "getConstructorId") [])
664 <$> (Nothing <>@! var)
665mkGetConstructorId False var =
666 (\ var match ->
667 Cond (InstanceOf var (toRefType idrisObjectType)) match (jInt (-1))
668 )
669 <$> (Nothing <>@! var)
670 <*> mkGetConstructorId True var
672mkConsMatch :: BlockPostprocessor ->
673 (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
674 LVar ->
675 [SAlt] ->
676 CodeGeneration [SwitchBlock]
677mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do
678 pushScope
679 caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression
680 popScope
681 otherBranches <- mkConsMatch pp getDefaultStmts var cases
682 return $
683 (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches
684mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases
685mkConsMatch pp getDefaultStmts _ [] = do
686 defaultBlock <- getDefaultStmts pp
687 return $
688 [SwitchBlock Default defaultBlock]
690mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt]
691mkCaseBinding pp var stackStart params branchExpression =
692 mkExp pp (toLetIn var stackStart params branchExpression)
693 where
694 toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp
695 toLetIn var stackStart members start =
696 foldr
697 (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp)
698 start
699 [0.. (length members - 1)]
701-----------------------------------------------------------------------
702-- Projection (retrieve the n-th field of an object)
704mkProjection :: LVar -> Int -> CodeGeneration Exp
705mkProjection var memberNr =
706 (\ var -> ArrayAccess $ ((var ~> "getData") []) @! memberNr)
707 <$> (Just idrisObjectType <>@! var)
709-----------------------------------------------------------------------
710-- Constants
712mkConstantArray :: (V.Unbox a) => J.Type -> (a -> Const) -> V.Vector a -> Exp
713mkConstantArray cty elemToConst elems =
714 ArrayCreateInit
715 cty
716 0
717 (ArrayInit . map (InitExp . mkConstant . elemToConst) $ V.toList elems)
719mkConstant :: Const -> Exp
720mkConstant c@(I x) = constType c <> (Lit . Word $ toInteger x)
721mkConstant c@(BI x) = bigInteger (show x)
722mkConstant c@(Fl x) = constType c <> (Lit . Double $ x)
723mkConstant c@(Ch x) = constType c <> (Lit . Char $ x)
724mkConstant c@(Str x) = constType c <> (Lit . String $ x)
725mkConstant c@(B8 x) = constType c <> (Lit . Word $ toInteger x)
726mkConstant c@(B16 x) = constType c <> (Lit . Word $ toInteger x)
727mkConstant c@(B32 x) = constType c <> (Lit . Word $ toInteger x)
728mkConstant c@(B64 x) = (bigInteger (show c) ~> "longValue") []
729mkConstant c@(B8V x) = mkConstantArray (constType c) B8 x
730mkConstant c@(B16V x) = mkConstantArray (constType c) B16 x
731mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x
732mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x
733mkConstant c@(AType x) = ClassLit (Just $ box (constType c))
734mkConstant c@(StrType ) = ClassLit (Just $ stringType)
735mkConstant c@(PtrType ) = ClassLit (Just $ objectType)
736mkConstant c@(VoidType ) = ClassLit (Just $ voidType)
737mkConstant c@(Forgot ) = ClassLit (Just $ objectType)
739-----------------------------------------------------------------------
740-- Foreign function calls
742mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt]
743mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params
744mkForeign pp (LANG_JAVA callType) resTy text params
745 | callType <- FStatic = do
746 method <- liftParsed (parser name text)
747 args <- foreignVarAccess params
748 wrapReturn resTy (call method args)
749 | callType <- FObject = do
750 method <- liftParsed (parser ident text)
751 (tgt:args) <- foreignVarAccess params
752 wrapReturn resTy ((tgt ~> (show $ pretty method)) args)
753 | callType <- FConstructor = do
754 clsTy <- liftParsed (parser classType text)
755 args <- foreignVarAccess params
756 wrapReturn resTy (InstanceCreation [] clsTy args Nothing)
757 where
758 foreignVarAccess args =
759 mapM (\ (fty, var) -> (foreignType fty <>@! var)) args
761 pp' = rethrowAsRuntimeException pp
763 wrapReturn FUnit exp =
764 ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp'
765 wrapReturn _ exp =
766 ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp'
768-----------------------------------------------------------------------
769-- Primitive functions
771mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp
772mkPrimitiveFunction op args =
773 (\ args -> (primFnType ~> opName op) args)
774 <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op))
776mkThread :: LVar -> CodeGeneration Exp
777mkThread arg =
778 (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (MN 0 "EVAL") [arg]