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