git.iko.soy/Idris-dev
on d1663cc help sign in
Idris-dev/src/IRTS/CodegenJava.hs
753 lines 27 kB history raw
1{-# LANGUAGE PatternGuards #-}
2module IRTS.CodegenJava (codegenJava) where
4import 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 Util.System
14import Control.Applicative hiding (Const)
15import Control.Arrow
16import Control.Monad
17import Control.Monad.Error
18import qualified Control.Monad.Trans as T
19import Control.Monad.Trans.State
20import Data.List (foldl', isSuffixOf)
21import qualified Data.Text as T
22import qualified Data.Text.IO as TIO
23import qualified Data.Vector.Unboxed as V
24import Language.Java.Parser
25import Language.Java.Pretty
26import Language.Java.Syntax hiding (Name)
27import qualified Language.Java.Syntax as J
28import System.Directory
29import System.Exit
30import System.FilePath
31import System.IO
32import System.Process
34-----------------------------------------------------------------------
35-- Main function
36codegenJava :: [(Name, SExp)] -> -- initialization of globals
37 [(Name, SDecl)] -> -- decls
38 FilePath -> -- output file name
39 [String] -> -- headers
40 [String] -> -- libs
41 OutputType ->
42 IO ()
43codegenJava globalInit defs out hdrs libs exec =
44 withTgtDir exec out (codegenJava' exec)
45 where
46 codegenJava' :: OutputType -> FilePath -> IO ()
47 codegenJava' Raw tgtDir = do
48 srcDir <- prepareSrcDir exec tgtDir
49 generateJavaFile globalInit defs hdrs srcDir out
50 codegenJava' MavenProject tgtDir = do
51 codegenJava' Raw tgtDir
52 generatePom tgtDir out libs
53 codegenJava' Object tgtDir = do
54 codegenJava' MavenProject tgtDir
55 invokeMvn tgtDir "compile"
56 copyClassFiles tgtDir out
57 cleanUpTmp tgtDir
58 codegenJava' _ tgtDir = do
59 codegenJava' MavenProject tgtDir
60 invokeMvn tgtDir "package";
61 copyJar tgtDir out
62 makeJarExecutable out
63 cleanUpTmp tgtDir
65-----------------------------------------------------------------------
66-- Compiler IO
68withTgtDir :: OutputType -> FilePath -> (FilePath -> IO ()) -> IO ()
69withTgtDir Raw out action = action (dropFileName out)
70withTgtDir MavenProject out action = createDirectoryIfMissing False out >> action out
71withTgtDir _ out action = withTempdir (takeBaseName out) action
73prepareSrcDir :: OutputType -> FilePath -> IO FilePath
74prepareSrcDir Raw tgtDir = return tgtDir
75prepareSrcDir _ tgtDir = do
76 let srcDir = (tgtDir </> "src" </> "main" </> "java")
77 createDirectoryIfMissing True srcDir
78 return srcDir
80javaFileName :: FilePath -> FilePath -> FilePath
81javaFileName srcDir out =
82 either error (\ (Ident clsName) -> srcDir </> clsName <.> "java") (mkClassName out)
84generateJavaFile :: [(Name, SExp)] -> -- initialization of globals
85 [(Name, SDecl)] -> -- definitions
86 [String] -> -- headers
87 FilePath -> -- Source dir
88 FilePath -> -- output target
89 IO ()
90generateJavaFile globalInit defs hdrs srcDir out = do
91 let code = either error
92 (prettyPrint)-- flatIndent . prettyPrint)
93 (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv)
94 writeFile (javaFileName srcDir out) code
96pomFileName :: FilePath -> FilePath
97pomFileName tgtDir = tgtDir </> "pom.xml"
99generatePom :: FilePath -> -- tgt dir
100 FilePath -> -- output target
101 [String] -> -- libs
102 IO ()
103generatePom tgtDir out libs = writeFile (pomFileName tgtDir) execPom
104 where
105 (Ident clsName) = either error id (mkClassName out)
106 execPom = pomString clsName (takeBaseName out) libs
109invokeMvn :: FilePath -> String -> IO ()
110invokeMvn tgtDir command = do
111 mvnCmd <- getMvn
112 let args = ["-f", pomFileName tgtDir]
113 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ [command]) ""
114 when (exit /= ExitSuccess) $
115 error ("FAILURE: " ++ mvnCmd ++ " " ++ command ++ "\n" ++ err ++ mvout)
117classFileDir :: FilePath -> FilePath
118classFileDir tgtDir = tgtDir </> "target" </> "classes"
120copyClassFiles :: FilePath -> FilePath -> IO ()
121copyClassFiles tgtDir out = do
122 classFiles <- map (\ clsFile -> classFileDir tgtDir </> clsFile)
123 . filter ((".class" ==) . takeExtension)
124 <$> getDirectoryContents (classFileDir tgtDir)
125 mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile)) classFiles
127jarFileName :: FilePath -> FilePath -> FilePath
128jarFileName tgtDir out = tgtDir </> "target" </> (takeBaseName out) <.> "jar"
130copyJar :: FilePath -> FilePath -> IO ()
131copyJar tgtDir out =
132 copyFile (jarFileName tgtDir out) out
134makeJarExecutable :: FilePath -> IO ()
135makeJarExecutable out = do
136 handle <- openBinaryFile out ReadMode
137 contents <- TIO.hGetContents handle
138 hClose handle
139 handle <- openBinaryFile out WriteMode
140 TIO.hPutStr handle (T.append (T.pack jarHeader) contents)
141 hFlush handle
142 hClose handle
143 perms <- getPermissions out
144 setPermissions out (setOwnerExecutable True perms)
146removePom :: FilePath -> IO ()
147removePom tgtDir = removeFile (pomFileName tgtDir)
149cleanUpTmp :: FilePath -> IO ()
150cleanUpTmp tgtDir = do
151 invokeMvn tgtDir "clean"
152 removePom tgtDir
154-----------------------------------------------------------------------
155-- Jar and Pom infrastructure
157jarHeader :: String
158jarHeader =
159 "#!/bin/sh\n"
160 ++ "MYSELF=`which \"$0\" 2>/dev/null`\n"
161 ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n"
162 ++ "java=java\n"
163 ++ "if test -n \"$JAVA_HOME\"; then\n"
164 ++ " java=\"$JAVA_HOME/bin/java\"\n"
165 ++ "fi\n"
166 ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\""
167 ++ "exit 1\n"
169-----------------------------------------------------------------------
170-- Code generation environment
172data CodeGenerationEnv
173 = CodeGenerationEnv
174 { globalVariables :: [(Name, ArrayIndex)]
175 , localVariables :: [[(Int, Ident)]]
176 , localVarCounter :: Int
177 }
179type CodeGeneration = StateT (CodeGenerationEnv) (Either String)
181mkCodeGenEnv :: CodeGenerationEnv
182mkCodeGenEnv = CodeGenerationEnv [] [] 0
184varPos :: LVar -> CodeGeneration (Either ArrayIndex Ident)
185varPos (Loc i) = do
186 vars <- (concat . localVariables) <$> get
187 case lookup i vars of
188 (Just varName) -> return (Right varName)
189 Nothing -> throwError $ "Invalid local variable id: " ++ show i
190varPos (Glob name) = do
191 vars <- globalVariables <$> get
192 case lookup name vars of
193 (Just varIdx) -> return (Left varIdx)
194 Nothing -> throwError $ "Invalid global variable id: " ++ show name
196pushScope :: CodeGeneration ()
197pushScope =
198 modify (\ env -> env { localVariables = []:(localVariables env) })
200popScope :: CodeGeneration ()
201popScope = do
202 env <- get
203 let lVars = tail $ localVariables env
204 let vC = if null lVars then 0 else localVarCounter env
205 put $ env { localVariables = tail (localVariables env)
206 , localVarCounter = vC }
208setVariable :: LVar -> CodeGeneration (Either ArrayIndex Ident)
209setVariable (Loc i) = do
210 env <- get
211 let lVars = localVariables env
212 let getter = localVar $ localVarCounter env
213 let lVars' = ((i, getter) : head lVars) : tail lVars
214 put $ env { localVariables = lVars'
215 , localVarCounter = 1 + localVarCounter env}
216 return (Right getter)
217setVariable (Glob n) = do
218 env <- get
219 let gVars = globalVariables env
220 let getter = globalContext @! length gVars
221 let gVars' = (n, getter):gVars
222 put (env { globalVariables = gVars' })
223 return (Left getter)
225pushParams :: [Ident] -> CodeGeneration ()
226pushParams paramNames =
227 let varMap = zipWith (flip (,)) paramNames [0..] in
228 modify (\ env -> env { localVariables = varMap:(localVariables env)
229 , localVarCounter = (length varMap) + (localVarCounter env) })
231flatIndent :: String -> String
232flatIndent (' ' : ' ' : xs) = flatIndent xs
233flatIndent (x:xs) = x:flatIndent xs
234flatIndent [] = []
236-----------------------------------------------------------------------
237-- Maintaining control structures over code blocks
239data BlockPostprocessor
240 = BlockPostprocessor
241 { ppInnerBlock :: [BlockStmt] -> Exp -> CodeGeneration [BlockStmt]
242 , ppOuterBlock :: [BlockStmt] -> CodeGeneration [BlockStmt]
243 }
245ppExp :: BlockPostprocessor -> Exp -> CodeGeneration [BlockStmt]
246ppExp pp exp = ((ppInnerBlock pp) [] exp) >>= ppOuterBlock pp
248addReturn :: BlockPostprocessor
249addReturn =
250 BlockPostprocessor
251 { ppInnerBlock = (\ block exp -> return $ block ++ [jReturn exp])
252 , ppOuterBlock = return
253 }
255ignoreResult :: BlockPostprocessor
256ignoreResult =
257 BlockPostprocessor
258 { ppInnerBlock = (\ block exp -> return block)
259 , ppOuterBlock = return
260 }
262ignoreOuter :: BlockPostprocessor -> BlockPostprocessor
263ignoreOuter pp = pp { ppOuterBlock = return }
265throwRuntimeException :: BlockPostprocessor -> BlockPostprocessor
266throwRuntimeException pp =
267 pp
268 { ppInnerBlock =
269 (\ blk exp -> return $
270 blk ++ [ BlockStmt $ Throw
271 ( InstanceCreation
272 []
273 (toClassType runtimeExceptionType)
274 [exp]
275 Nothing
276 )
277 ]
278 )
279 }
282rethrowAsRuntimeException :: BlockPostprocessor -> BlockPostprocessor
283rethrowAsRuntimeException pp =
284 pp
285 { ppOuterBlock =
286 (\ blk -> do
287 ex <- ppInnerBlock (throwRuntimeException pp) [] (ExpName $ J.Name [Ident "ex"])
288 ppOuterBlock pp
289 $ [ BlockStmt $ Try
290 (Block blk)
291 [Catch (FormalParam [] exceptionType False (VarId (Ident "ex"))) $
292 Block ex
293 ]
294 Nothing
295 ]
296 )
297 }
299-----------------------------------------------------------------------
300-- File structure
302mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit
303mkCompilationUnit globalInit defs hdrs out = do
304 clsName <- mkClassName out
305 CompilationUnit Nothing ( [ ImportDecl False idrisRts True
306 , ImportDecl True idrisPrelude True
307 , ImportDecl False bigInteger False
308 , ImportDecl False runtimeException False
309 ] ++ otherHdrs
310 )
311 <$> mkTypeDecl clsName globalInit defs
312 where
313 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
314 idrisPrelude = J.Name $ map Ident ["org", "idris", "rts", "Prelude"]
315 bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
316 runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
317 otherHdrs = map ( (\ name -> ImportDecl False name False)
318 . J.Name
319 . map (Ident . T.unpack)
320 . T.splitOn (T.pack ".")
321 . T.pack)
322 $ filter (not . isSuffixOf ".h") hdrs
324-----------------------------------------------------------------------
325-- Main class
327mkTypeDecl :: Ident -> [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration [TypeDecl]
328mkTypeDecl name globalInit defs =
329 (\ body -> [ClassTypeDecl $ ClassDecl [ Public
330 , Annotation $ SingleElementAnnotation
331 (jName "SuppressWarnings")
332 (EVVal . InitExp $ jString "unchecked")
333 ]
334 name
335 []
336 Nothing
337 []
338 body])
339 <$> mkClassBody globalInit (map (second (prefixCallNamespaces name)) defs)
341mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody
342mkClassBody globalInit defs =
343 (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)
344 <$> mkGlobalContext globalInit
345 <*> mapM mkDecl defs
347mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
348mkGlobalContext [] = return []
349mkGlobalContext initExps = do
350 pushScope
351 varInit <-
352 mapM (\ (name, exp) -> do
353 pos <- setVariable (Glob name)
354 mkUpdate ignoreResult (Glob name) exp
355 ) initExps
356 popScope
357 return [ MemberDecl $ FieldDecl [Private, Static, Final]
358 (array objectType)
359 [ VarDecl (VarId $ globalContextID). Just . InitExp
360 $ ArrayCreate objectType [jInt $ length initExps] 0
361 ]
362 , InitDecl True (Block $ concat varInit)
363 ]
365addMainMethod :: [Decl] -> [Decl]
366addMainMethod decls
367 | findMain decls = mkMainMethod : decls
368 | otherwise = decls
369 where
370 findMain ((MemberDecl (MemberClassDecl (ClassDecl _ name _ _ _ (ClassBody body)))):_)
371 | name == mangle' (UN "Main") = findMainMethod body
372 findMain (_:decls) = findMain decls
373 findMain [] = False
375 innerMainMethod = (either error id $ mangle (UN "main"))
376 findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_)
377 | name == mangle' (UN "main") = 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' (MN 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@(VoidType ) = ClassLit (Just $ voidType)
710mkConstant c@(Forgot ) = ClassLit (Just $ objectType)
712-----------------------------------------------------------------------
713-- Foreign function calls
715mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt]
716mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params
717mkForeign pp (LANG_JAVA callType) resTy text params
718 | callType <- FStatic = do
719 method <- liftParsed (parser name text)
720 args <- foreignVarAccess params
721 wrapReturn resTy (call method args)
722 | callType <- FObject = do
723 method <- liftParsed (parser ident text)
724 (tgt:args) <- foreignVarAccess params
725 wrapReturn resTy ((tgt ~> (show $ pretty method)) args)
726 | callType <- FConstructor = do
727 clsTy <- liftParsed (parser classType text)
728 args <- foreignVarAccess params
729 wrapReturn resTy (InstanceCreation [] clsTy args Nothing)
730 where
731 foreignVarAccess args =
732 mapM (\ (fty, var) -> (foreignType fty <>@! var)) args
734 pp' = rethrowAsRuntimeException pp
736 wrapReturn FUnit exp =
737 ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp'
738 wrapReturn _ exp =
739 ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp'
741-----------------------------------------------------------------------
742-- Primitive functions
744mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp
745mkPrimitiveFunction op args =
746 (\ args -> (primFnType ~> opName op) args)
747 <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op))
749mkThread :: LVar -> CodeGeneration Exp
750mkThread arg =
751 (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (MN 0 "EVAL") [arg]