git.iko.soy/Idris-dev
on abc2002 help sign in
Idris-dev/src/IRTS/CodegenJava.hs
757 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 \"$@\"\n"
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 , ImportDecl False byteBuffer False
316 ] ++ otherHdrs
317 )
318 <$> mkTypeDecl clsName globalInit defs
319 where
320 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
321 idrisPrelude = J.Name $ map Ident ["org", "idris", "rts", "Prelude"]
322 bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
323 runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
324 byteBuffer = J.Name $ map Ident ["java", "nio", "ByteBuffer"]
325 otherHdrs = map ( (\ name -> ImportDecl False name False)
326 . J.Name
327 . map (Ident . T.unpack)
328 . T.splitOn (T.pack ".")
329 . T.pack)
330 $ filter (not . isSuffixOf ".h") hdrs
332-----------------------------------------------------------------------
333-- Main class
335mkTypeDecl :: Ident -> [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration [TypeDecl]
336mkTypeDecl name globalInit defs =
337 (\ body -> [ClassTypeDecl $ ClassDecl [ Public
338 , Annotation $ SingleElementAnnotation
339 (jName "SuppressWarnings")
340 (EVVal . InitExp $ jString "unchecked")
341 ]
342 name
343 []
344 Nothing
345 []
346 body])
347 <$> mkClassBody globalInit (map (second (prefixCallNamespaces name)) defs)
349mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody
350mkClassBody globalInit defs =
351 (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)
352 <$> mkGlobalContext globalInit
353 <*> mapM mkDecl defs
355mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
356mkGlobalContext [] = return []
357mkGlobalContext initExps = do
358 pushScope
359 varInit <-
360 mapM (\ (name, exp) -> do
361 pos <- setVariable (Glob name)
362 mkUpdate ignoreResult (Glob name) exp
363 ) initExps
364 popScope
365 return [ MemberDecl $ FieldDecl [Private, Static, Final]
366 (array objectType)
367 [ VarDecl (VarId $ globalContextID). Just . InitExp
368 $ ArrayCreate objectType [jInt $ length initExps] 0
369 ]
370 , InitDecl True (Block $ concat varInit)
371 ]
373addMainMethod :: [Decl] -> [Decl]
374addMainMethod decls
375 | findMainMethod decls = mkMainMethod : decls
376 | otherwise = decls
377 where
378 findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_)
379 | name == mangle' (sMN 0 "runMain") = True
380 findMainMethod (_:decls) = findMainMethod decls
381 findMainMethod [] = False
383mkMainMethod :: Decl
384mkMainMethod =
385 simpleMethod
386 [Public, Static]
387 Nothing
388 "main"
389 [FormalParam [] (array stringType) False (VarId $ Ident "args")]
390 $ Block [ BlockStmt . ExpStmt
391 $ call "idris_initArgs" [ jConst "args" ]
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 up 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 LRegisterPtr [ptr, i]) =
488 (Nothing <>@! ptr) >>= ppExp pp
489mkExp pp (SOp LNoOp args) =
490 (Nothing <>@! (last args)) >>= ppExp pp
491mkExp pp (SOp LNullPtr args) =
492 ppExp pp $ Lit Null
493mkExp pp (SOp op args) =
494 (mkPrimitiveFunction op args) >>= ppExp pp
496-- Empty expressions
497mkExp pp (SNothing) = ppExp pp $ Lit Null
499-- Errors
500mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err)
502-----------------------------------------------------------------------
503-- Variable access
505(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp
506(<>@!) Nothing var =
507 either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var
508(<>@!) (Just castTo) var =
509 (castTo <>) <$> (Nothing <>@! var)
511-----------------------------------------------------------------------
512-- Application (wrap method calls in tail call closures)
514mkApp :: Bool -> Name -> [LVar] -> CodeGeneration Exp
515mkApp False name args =
516 (\ methodName params ->
517 (idrisClosureType ~> "unwrapTailCall") [call methodName params]
518 )
519 <$> mangleFull name
520 <*> mapM (Nothing <>@!) args
521mkApp True name args = mkMethodCallClosure name args
523mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp
524mkMethodCallClosure name args =
525 (\ name args -> closure (call name args))
526 <$> mangleFull name
527 <*> mapM (Nothing <>@!) args
529-----------------------------------------------------------------------
530-- Updates (change context array) and Let bindings (Update, execute)
532mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt]
533mkUpdate pp var exp =
534 mkExp
535 ( pp
536 { ppInnerBlock =
537 (\ blk rhs -> do
538 pos <- setVariable var
539 vExp <- Nothing <>@! var
540 ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp
541 )
542 }
543 ) exp
545mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt]
546mkLet pp var@(Loc pos) newExp inExp =
547 mkUpdate (pp { ppInnerBlock =
548 (\ blk _ -> do
549 inBlk <- mkExp pp inExp
550 return (blk ++ inBlk)
551 )
552 }
553 ) var newExp
554mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
556-----------------------------------------------------------------------
557-- Object creation
559mkIdrisObject :: Int -> [LVar] -> CodeGeneration Exp
560mkIdrisObject conId args =
561 (\ args ->
562 InstanceCreation [] (toClassType idrisObjectType) ((jInt conId):args) Nothing
563 )
564 <$> mapM (Nothing <>@!) args
566-----------------------------------------------------------------------
567-- Case expressions
569mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt]
570mkCase pp checked var cases
571 | isDefaultOnlyCase cases = mkDefaultMatch pp cases
572 | isConstCase cases = do
573 ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
574 ppOuterBlock pp [BlockStmt ifte]
575 | otherwise = do
576 switchExp <- mkGetConstructorId checked var
577 matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
578 ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks]
580isConstCase :: [SAlt] -> Bool
581isConstCase ((SConstCase _ _):_) = True
582isConstCase ((SDefaultCase _):cases) = isConstCase cases
583isConstCase _ = False
585isDefaultOnlyCase :: [SAlt] -> Bool
586isDefaultOnlyCase [SDefaultCase _] = True
587isDefaultOnlyCase [] = True
588isDefaultOnlyCase _ = False
590mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt]
591mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) =
592 do pushScope
593 stmt <- mkExp pp branchExpression
594 popScope
595 return stmt
596mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs
597mkDefaultMatch pp [] =
598 ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern")
600mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp
601mkMatchConstExp var c
602 | isPrimitive cty =
603 (\ var -> (primFnType ~> opName (LEq undefined)) [var, jc] ~==~ jInt 1)
604 <$> (Just cty <>@! var)
605 | isArray cty =
606 (\ var -> (arraysType ~> "equals") [var, jc])
607 <$> (Just cty <>@! var)
608 | isString cty =
609 (\ var -> ((primFnType ~> opName (LStrEq)) [var, jc] ~==~ jInt 1))
610 <$> (Just cty <>@! var)
611 | otherwise =
612 (\ var -> (var ~> "equals") [jc])
613 <$> (Just cty <>@! var)
614 where
615 cty = constType c
616 jc = mkConstant c
618mkConstMatch :: BlockPostprocessor ->
619 (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
620 LVar ->
621 [SAlt] ->
622 CodeGeneration Stmt
623mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do
624 matchExp <- mkMatchConstExp var constant
625 pushScope
626 branchBlock <- mkExp pp branchExpression
627 popScope
628 otherBranches <- mkConstMatch pp getDefaultStmts var cases
629 return
630 $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches
631mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases
632mkConstMatch pp getDefaultStmts _ [] = do
633 defaultBlock <- getDefaultStmts pp
634 return $ StmtBlock (Block defaultBlock)
636mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp
637mkGetConstructorId True var =
638 (\ var -> ((idrisObjectType <> var) ~> "getConstructorId") [])
639 <$> (Nothing <>@! var)
640mkGetConstructorId False var =
641 (\ var match ->
642 Cond (InstanceOf var (toRefType idrisObjectType)) match (jInt (-1))
643 )
644 <$> (Nothing <>@! var)
645 <*> mkGetConstructorId True var
647mkConsMatch :: BlockPostprocessor ->
648 (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
649 LVar ->
650 [SAlt] ->
651 CodeGeneration [SwitchBlock]
652mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do
653 pushScope
654 caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression
655 popScope
656 otherBranches <- mkConsMatch pp getDefaultStmts var cases
657 return $
658 (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches
659mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases
660mkConsMatch pp getDefaultStmts _ [] = do
661 defaultBlock <- getDefaultStmts pp
662 return $
663 [SwitchBlock Default defaultBlock]
665mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt]
666mkCaseBinding pp var stackStart params branchExpression =
667 mkExp pp (toLetIn var stackStart params branchExpression)
668 where
669 toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp
670 toLetIn var stackStart members start =
671 foldr
672 (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp)
673 start
674 [0.. (length members - 1)]
676-----------------------------------------------------------------------
677-- Projection (retrieve the n-th field of an object)
679mkProjection :: LVar -> Int -> CodeGeneration Exp
680mkProjection var memberNr =
681 (\ var -> ArrayAccess $ ((var ~> "getData") []) @! memberNr)
682 <$> (Just idrisObjectType <>@! var)
684-----------------------------------------------------------------------
685-- Constants
687mkConstantArray :: (V.Unbox a) => J.Type -> (a -> Const) -> V.Vector a -> Exp
688mkConstantArray cty elemToConst elems =
689 ArrayCreateInit
690 cty
691 0
692 (ArrayInit . map (InitExp . mkConstant . elemToConst) $ V.toList elems)
694mkConstant :: Const -> Exp
695mkConstant c@(I x) = constType c <> (Lit . Word $ toInteger x)
696mkConstant c@(BI x) = bigInteger (show x)
697mkConstant c@(Fl x) = constType c <> (Lit . Double $ x)
698mkConstant c@(Ch x) = constType c <> (Lit . Char $ x)
699mkConstant c@(Str x) = constType c <> (Lit . String $ x)
700mkConstant c@(B8 x) = constType c <> (Lit . Word $ toInteger x)
701mkConstant c@(B16 x) = constType c <> (Lit . Word $ toInteger x)
702mkConstant c@(B32 x) = constType c <> (Lit . Word $ toInteger x)
703mkConstant c@(B64 x) = (bigInteger (show c) ~> "longValue") []
704mkConstant c@(B8V x) = mkConstantArray (constType c) B8 x
705mkConstant c@(B16V x) = mkConstantArray (constType c) B16 x
706mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x
707mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x
708mkConstant c@(AType x) = ClassLit (Just $ box (constType c))
709mkConstant c@(StrType ) = ClassLit (Just $ stringType)
710mkConstant c@(PtrType ) = ClassLit (Just $ objectType)
711mkConstant c@(ManagedPtrType) = ClassLit (Just $ objectType)
712mkConstant c@(BufferType) = ClassLit (Just $ bufferType)
713mkConstant c@(VoidType ) = ClassLit (Just $ voidType)
714mkConstant c@(Forgot ) = ClassLit (Just $ objectType)
716-----------------------------------------------------------------------
717-- Foreign function calls
719mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt]
720mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params
721mkForeign pp (LANG_JAVA callType) resTy text params
722 | callType <- FStatic = do
723 method <- liftParsed (parser name text)
724 args <- foreignVarAccess params
725 wrapReturn resTy (call method args)
726 | callType <- FObject = do
727 method <- liftParsed (parser ident text)
728 (tgt:args) <- foreignVarAccess params
729 wrapReturn resTy ((tgt ~> (show $ pretty method)) args)
730 | callType <- FConstructor = do
731 clsTy <- liftParsed (parser classType text)
732 args <- foreignVarAccess params
733 wrapReturn resTy (InstanceCreation [] clsTy args Nothing)
734 where
735 foreignVarAccess args =
736 mapM (\ (fty, var) -> (foreignType fty <>@! var)) args
738 pp' = rethrowAsRuntimeException pp
740 wrapReturn FUnit exp =
741 ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp'
742 wrapReturn _ exp =
743 ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp'
745-----------------------------------------------------------------------
746-- Primitive functions
748mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp
749mkPrimitiveFunction op args =
750 (\ args -> (primFnType ~> opName op) (endiannessArguments op ++ args))
751 <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op))
753mkThread :: LVar -> CodeGeneration Exp
754mkThread arg =
755 (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (sMN 0 "EVAL") [arg]