git.iko.soy/Idris-dev
on 3c58bbf 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 :: [(Name, SExp)] -> -- initialization of globals
38 [(Name, SDecl)] -> -- decls
39 FilePath -> -- output file name
40 [String] -> -- headers
41 [String] -> -- libs
42 OutputType ->
43 IO ()
44codegenJava globalInit defs out hdrs libs exec =
45 withTgtDir exec out (codegenJava' exec)
46 where
47 codegenJava' :: OutputType -> FilePath -> IO ()
48 codegenJava' Raw tgtDir = do
49 srcDir <- prepareSrcDir exec tgtDir
50 generateJavaFile globalInit defs hdrs srcDir out
51 codegenJava' MavenProject tgtDir = do
52 codegenJava' Raw tgtDir
53 generatePom tgtDir out libs
54 codegenJava' Object tgtDir = do
55 codegenJava' MavenProject tgtDir
56 invokeMvn tgtDir "compile"
57 copyClassFiles tgtDir out
58 cleanUpTmp tgtDir
59 codegenJava' _ tgtDir = do
60 codegenJava' MavenProject tgtDir
61 invokeMvn tgtDir "package";
62 copyJar tgtDir out
63 makeJarExecutable out
64 cleanUpTmp tgtDir
66-----------------------------------------------------------------------
67-- Compiler IO
69withTgtDir :: OutputType -> FilePath -> (FilePath -> IO ()) -> IO ()
70withTgtDir Raw out action = action (dropFileName out)
71withTgtDir MavenProject out action = createDirectoryIfMissing False out >> action out
72withTgtDir _ out action = withTempdir (takeBaseName out) action
74prepareSrcDir :: OutputType -> FilePath -> IO FilePath
75prepareSrcDir Raw tgtDir = return tgtDir
76prepareSrcDir _ tgtDir = do
77 let srcDir = (tgtDir </> "src" </> "main" </> "java")
78 createDirectoryIfMissing True srcDir
79 return srcDir
81javaFileName :: FilePath -> FilePath -> FilePath
82javaFileName srcDir out =
83 either error (\ (Ident clsName) -> srcDir </> clsName <.> "java") (mkClassName out)
85generateJavaFile :: [(Name, SExp)] -> -- initialization of globals
86 [(Name, SDecl)] -> -- definitions
87 [String] -> -- headers
88 FilePath -> -- Source dir
89 FilePath -> -- output target
90 IO ()
91generateJavaFile globalInit defs hdrs srcDir out = do
92 let code = either error
93 (prettyPrint)-- flatIndent . prettyPrint)
94 (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv)
95 writeFile (javaFileName srcDir out) code
97pomFileName :: FilePath -> FilePath
98pomFileName tgtDir = tgtDir </> "pom.xml"
100generatePom :: FilePath -> -- tgt dir
101 FilePath -> -- output target
102 [String] -> -- libs
103 IO ()
104generatePom tgtDir out libs = writeFile (pomFileName tgtDir) execPom
105 where
106 (Ident clsName) = either error id (mkClassName out)
107 execPom = pomString clsName (takeBaseName out) libs
110invokeMvn :: FilePath -> String -> IO ()
111invokeMvn tgtDir command = do
112 mvnCmd <- getMvn
113 let args = ["-f", pomFileName tgtDir]
114 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ [command]) ""
115 when (exit /= ExitSuccess) $
116 error ("FAILURE: " ++ mvnCmd ++ " " ++ command ++ "\n" ++ err ++ mvout)
118classFileDir :: FilePath -> FilePath
119classFileDir tgtDir = tgtDir </> "target" </> "classes"
121copyClassFiles :: FilePath -> FilePath -> IO ()
122copyClassFiles tgtDir out = do
123 classFiles <- map (\ clsFile -> classFileDir tgtDir </> clsFile)
124 . filter ((".class" ==) . takeExtension)
125 <$> getDirectoryContents (classFileDir tgtDir)
126 mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile)) classFiles
128jarFileName :: FilePath -> FilePath -> FilePath
129jarFileName tgtDir out = tgtDir </> "target" </> (takeBaseName out) <.> "jar"
131copyJar :: FilePath -> FilePath -> IO ()
132copyJar tgtDir out =
133 copyFile (jarFileName tgtDir out) out
135makeJarExecutable :: FilePath -> IO ()
136makeJarExecutable out = do
137 handle <- openBinaryFile out ReadMode
138 contents <- TIO.hGetContents handle
139 hClose handle
140 handle <- openBinaryFile out WriteMode
141 TIO.hPutStr handle (T.append (T.pack jarHeader) contents)
142 hFlush handle
143 hClose handle
144 perms <- getPermissions out
145 setPermissions out (setOwnerExecutable True perms)
147removePom :: FilePath -> IO ()
148removePom tgtDir = removeFile (pomFileName tgtDir)
150cleanUpTmp :: FilePath -> IO ()
151cleanUpTmp tgtDir = do
152 invokeMvn tgtDir "clean"
153 removePom tgtDir
155-----------------------------------------------------------------------
156-- Jar and Pom infrastructure
158jarHeader :: String
159jarHeader =
160 "#!/usr/bin/env sh\n"
161 ++ "MYSELF=`which \"$0\" 2>/dev/null`\n"
162 ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n"
163 ++ "java=java\n"
164 ++ "if test -n \"$JAVA_HOME\"; then\n"
165 ++ " java=\"$JAVA_HOME/bin/java\"\n"
166 ++ "fi\n"
167 ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\""
168 ++ "exit 1\n"
170-----------------------------------------------------------------------
171-- Code generation environment
173data CodeGenerationEnv
174 = CodeGenerationEnv
175 { globalVariables :: [(Name, ArrayIndex)]
176 , localVariables :: [[(Int, Ident)]]
177 , localVarCounter :: Int
178 }
180type CodeGeneration = StateT (CodeGenerationEnv) (Either String)
182mkCodeGenEnv :: CodeGenerationEnv
183mkCodeGenEnv = CodeGenerationEnv [] [] 0
185varPos :: LVar -> CodeGeneration (Either ArrayIndex Ident)
186varPos (Loc i) = do
187 vars <- (concat . localVariables) <$> get
188 case lookup i vars of
189 (Just varName) -> return (Right varName)
190 Nothing -> throwError $ "Invalid local variable id: " ++ show i
191varPos (Glob name) = do
192 vars <- globalVariables <$> get
193 case lookup name vars of
194 (Just varIdx) -> return (Left varIdx)
195 Nothing -> throwError $ "Invalid global variable id: " ++ show name
197pushScope :: CodeGeneration ()
198pushScope =
199 modify (\ env -> env { localVariables = []:(localVariables env) })
201popScope :: CodeGeneration ()
202popScope = do
203 env <- get
204 let lVars = tail $ localVariables env
205 let vC = if null lVars then 0 else localVarCounter env
206 put $ env { localVariables = tail (localVariables env)
207 , localVarCounter = vC }
209setVariable :: LVar -> CodeGeneration (Either ArrayIndex Ident)
210setVariable (Loc i) = do
211 env <- get
212 let lVars = localVariables env
213 let getter = localVar $ localVarCounter env
214 let lVars' = ((i, getter) : head lVars) : tail lVars
215 put $ env { localVariables = lVars'
216 , localVarCounter = 1 + localVarCounter env}
217 return (Right getter)
218setVariable (Glob n) = do
219 env <- get
220 let gVars = globalVariables env
221 let getter = globalContext @! length gVars
222 let gVars' = (n, getter):gVars
223 put (env { globalVariables = gVars' })
224 return (Left getter)
226pushParams :: [Ident] -> CodeGeneration ()
227pushParams paramNames =
228 let varMap = zipWith (flip (,)) paramNames [0..] in
229 modify (\ env -> env { localVariables = varMap:(localVariables env)
230 , localVarCounter = (length varMap) + (localVarCounter env) })
232flatIndent :: String -> String
233flatIndent (' ' : ' ' : xs) = flatIndent xs
234flatIndent (x:xs) = x:flatIndent xs
235flatIndent [] = []
237-----------------------------------------------------------------------
238-- Maintaining control structures over code blocks
240data BlockPostprocessor
241 = BlockPostprocessor
242 { ppInnerBlock :: [BlockStmt] -> Exp -> CodeGeneration [BlockStmt]
243 , ppOuterBlock :: [BlockStmt] -> CodeGeneration [BlockStmt]
244 }
246ppExp :: BlockPostprocessor -> Exp -> CodeGeneration [BlockStmt]
247ppExp pp exp = ((ppInnerBlock pp) [] exp) >>= ppOuterBlock pp
249addReturn :: BlockPostprocessor
250addReturn =
251 BlockPostprocessor
252 { ppInnerBlock = (\ block exp -> return $ block ++ [jReturn exp])
253 , ppOuterBlock = return
254 }
256ignoreResult :: BlockPostprocessor
257ignoreResult =
258 BlockPostprocessor
259 { ppInnerBlock = (\ block exp -> return block)
260 , ppOuterBlock = return
261 }
263ignoreOuter :: BlockPostprocessor -> BlockPostprocessor
264ignoreOuter pp = pp { ppOuterBlock = return }
266throwRuntimeException :: BlockPostprocessor -> BlockPostprocessor
267throwRuntimeException pp =
268 pp
269 { ppInnerBlock =
270 (\ blk exp -> return $
271 blk ++ [ BlockStmt $ Throw
272 ( InstanceCreation
273 []
274 (toClassType runtimeExceptionType)
275 [exp]
276 Nothing
277 )
278 ]
279 )
280 }
283rethrowAsRuntimeException :: BlockPostprocessor -> BlockPostprocessor
284rethrowAsRuntimeException pp =
285 pp
286 { ppOuterBlock =
287 (\ blk -> do
288 ex <- ppInnerBlock (throwRuntimeException pp) [] (ExpName $ J.Name [Ident "ex"])
289 ppOuterBlock pp
290 $ [ BlockStmt $ Try
291 (Block blk)
292 [Catch (FormalParam [] exceptionType False (VarId (Ident "ex"))) $
293 Block ex
294 ]
295 Nothing
296 ]
297 )
298 }
300-----------------------------------------------------------------------
301-- File structure
303mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit
304mkCompilationUnit globalInit defs hdrs out = do
305 clsName <- mkClassName out
306 CompilationUnit Nothing ( [ ImportDecl False idrisRts True
307 , ImportDecl True idrisPrelude True
308 , ImportDecl False bigInteger False
309 , ImportDecl False runtimeException False
310 , ImportDecl False byteBuffer False
311 ] ++ otherHdrs
312 )
313 <$> mkTypeDecl clsName globalInit defs
314 where
315 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
316 idrisPrelude = J.Name $ map Ident ["org", "idris", "rts", "Prelude"]
317 bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
318 runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
319 byteBuffer = J.Name $ map Ident ["java", "nio", "ByteBuffer"]
320 otherHdrs = map ( (\ name -> ImportDecl False name False)
321 . J.Name
322 . map (Ident . T.unpack)
323 . T.splitOn (T.pack ".")
324 . T.pack)
325 $ filter (not . isSuffixOf ".h") hdrs
327-----------------------------------------------------------------------
328-- Main class
330mkTypeDecl :: Ident -> [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration [TypeDecl]
331mkTypeDecl name globalInit defs =
332 (\ body -> [ClassTypeDecl $ ClassDecl [ Public
333 , Annotation $ SingleElementAnnotation
334 (jName "SuppressWarnings")
335 (EVVal . InitExp $ jString "unchecked")
336 ]
337 name
338 []
339 Nothing
340 []
341 body])
342 <$> mkClassBody globalInit (map (second (prefixCallNamespaces name)) defs)
344mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody
345mkClassBody globalInit defs =
346 (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)
347 <$> mkGlobalContext globalInit
348 <*> mapM mkDecl defs
350mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
351mkGlobalContext [] = return []
352mkGlobalContext initExps = do
353 pushScope
354 varInit <-
355 mapM (\ (name, exp) -> do
356 pos <- setVariable (Glob name)
357 mkUpdate ignoreResult (Glob name) exp
358 ) initExps
359 popScope
360 return [ MemberDecl $ FieldDecl [Private, Static, Final]
361 (array objectType)
362 [ VarDecl (VarId $ globalContextID). Just . InitExp
363 $ ArrayCreate objectType [jInt $ length initExps] 0
364 ]
365 , InitDecl True (Block $ concat varInit)
366 ]
368addMainMethod :: [Decl] -> [Decl]
369addMainMethod decls
370 | findMain decls = mkMainMethod : decls
371 | otherwise = decls
372 where
373 findMain ((MemberDecl (MemberClassDecl (ClassDecl _ name _ _ _ (ClassBody body)))):_)
374 | name == mangle' (sUN "Main") = findMainMethod body
375 findMain (_:decls) = findMain decls
376 findMain [] = False
378 innerMainMethod = (either error id $ mangle (sUN "main"))
379 findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_)
380 | name == mangle' (sUN "main") = True
381 findMainMethod (_:decls) = findMainMethod decls
382 findMainMethod [] = False
384mkMainMethod :: Decl
385mkMainMethod =
386 simpleMethod
387 [Public, Static]
388 Nothing
389 "main"
390 [FormalParam [] (array stringType) False (VarId $ Ident "args")]
391 $ Block [ BlockStmt . ExpStmt
392 $ call "idris_initArgs" [ (threadType ~> "currentThread") []
393 , jConst "args"
394 ]
395 , BlockStmt . ExpStmt $ call (mangle' (sMN 0 "runMain")) []
396 ]
398-----------------------------------------------------------------------
399-- Inner classes (idris namespaces)
401mergeInnerClasses :: [Decl] -> [Decl]
402mergeInnerClasses = foldl' mergeInner []
403 where
404 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)
405 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))
406 | name == name' =
407 (MemberDecl $ MemberClassDecl $
408 ClassDecl priv
409 name
410 targs
411 (mplus ext ext')
412 (imp ++ imp')
413 (ClassBody $ mergeInnerClasses (body ++ body')))
414 : decls
415 | otherwise = decl:(mergeInner decls decl')
416 mergeInner (decl:decls) decl' = decl:(mergeInner decls decl')
417 mergeInner [] decl' = [decl']
421mkDecl :: (Name, SDecl) -> CodeGeneration Decl
422mkDecl ((NS n (ns:nss)), decl) =
423 (\ name body ->
424 MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
425 <$> mangle (UN ns)
426 <*> mkClassBody [] [(NS n nss, decl)]
427mkDecl (_, SFun name params stackSize body) = do
428 (Ident methodName) <- mangle name
429 methodParams <- mapM mkFormalParam params
430 paramNames <- mapM mangle params
431 pushParams paramNames
432 methodBody <- mkExp addReturn body
433 popScope
434 return $
435 simpleMethod [Public, Static] (Just objectType) methodName methodParams
436 (Block methodBody)
438mkFormalParam :: Name -> CodeGeneration FormalParam
439mkFormalParam name =
440 (\ name -> FormalParam [Final] objectType False (VarId name))
441 <$> mangle name
443-----------------------------------------------------------------------
444-- Expressions
446-- | Compile a simple expression and use the given continuation to postprocess
447-- the resulting value.
448mkExp :: BlockPostprocessor -> SExp -> CodeGeneration [BlockStmt]
449-- Variables
450mkExp pp (SV var) =
451 (Nothing <>@! var) >>= ppExp pp
453-- Applications
454mkExp pp (SApp pushTail name args) =
455 mkApp pushTail name args >>= ppExp pp
457-- Bindings
458mkExp pp (SLet var newExp inExp) =
459 mkLet pp var newExp inExp
460mkExp pp (SUpdate var@(Loc i) newExp) = -- can only update locals
461 mkUpdate pp var newExp
462mkExp pp (SUpdate var newExp) =
463 mkExp pp newExp
465-- Objects
466mkExp pp (SCon conId _ args) =
467 mkIdrisObject conId args >>= ppExp pp
469-- Case expressions
470mkExp pp (SCase var alts) = mkCase pp True var alts
471mkExp pp (SChkCase var alts) = mkCase pp False var alts
473-- Projections
474mkExp pp (SProj var i) =
475 mkProjection var i >>= ppExp pp
477-- Constants
478mkExp pp (SConst c) =
479 ppExp pp $ mkConstant c
481-- Foreign function calls
482mkExp pp (SForeign lang resTy text params) =
483 mkForeign pp lang resTy text params
485-- Primitive functions
486mkExp pp (SOp LFork [arg]) =
487 (mkThread arg) >>= ppExp pp
488mkExp pp (SOp LPar [arg]) =
489 (Nothing <>@! arg) >>= ppExp pp
490mkExp pp (SOp LNoOp args) =
491 (Nothing <>@! (last args)) >>= ppExp pp
492mkExp pp (SOp LNullPtr args) =
493 ppExp pp $ Lit Null
494mkExp pp (SOp op args) =
495 (mkPrimitiveFunction op args) >>= ppExp pp
497-- Empty expressions
498mkExp pp (SNothing) = ppExp pp $ Lit Null
500-- Errors
501mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err)
503-----------------------------------------------------------------------
504-- Variable access
506(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp
507(<>@!) Nothing var =
508 either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var
509(<>@!) (Just castTo) var =
510 (castTo <>) <$> (Nothing <>@! var)
512-----------------------------------------------------------------------
513-- Application (wrap method calls in tail call closures)
515mkApp :: Bool -> Name -> [LVar] -> CodeGeneration Exp
516mkApp False name args =
517 (\ methodName params ->
518 (idrisClosureType ~> "unwrapTailCall") [call methodName params]
519 )
520 <$> mangleFull name
521 <*> mapM (Nothing <>@!) args
522mkApp True name args = mkMethodCallClosure name args
524mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp
525mkMethodCallClosure name args =
526 (\ name args -> closure (call name args))
527 <$> mangleFull name
528 <*> mapM (Nothing <>@!) args
530-----------------------------------------------------------------------
531-- Updates (change context array) and Let bindings (Update, execute)
533mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt]
534mkUpdate pp var exp =
535 mkExp
536 ( pp
537 { ppInnerBlock =
538 (\ blk rhs -> do
539 pos <- setVariable var
540 vExp <- Nothing <>@! var
541 ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp
542 )
543 }
544 ) exp
546mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt]
547mkLet pp var@(Loc pos) newExp inExp =
548 mkUpdate (pp { ppInnerBlock =
549 (\ blk _ -> do
550 inBlk <- mkExp pp inExp
551 return (blk ++ inBlk)
552 )
553 }
554 ) var newExp
555mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
557-----------------------------------------------------------------------
558-- Object creation
560mkIdrisObject :: Int -> [LVar] -> CodeGeneration Exp
561mkIdrisObject conId args =
562 (\ args ->
563 InstanceCreation [] (toClassType idrisObjectType) ((jInt conId):args) Nothing
564 )
565 <$> mapM (Nothing <>@!) args
567-----------------------------------------------------------------------
568-- Case expressions
570mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt]
571mkCase pp checked var cases
572 | isDefaultOnlyCase cases = mkDefaultMatch pp cases
573 | isConstCase cases = do
574 ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
575 ppOuterBlock pp [BlockStmt ifte]
576 | otherwise = do
577 switchExp <- mkGetConstructorId checked var
578 matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
579 ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks]
581isConstCase :: [SAlt] -> Bool
582isConstCase ((SConstCase _ _):_) = True
583isConstCase ((SDefaultCase _):cases) = isConstCase cases
584isConstCase _ = False
586isDefaultOnlyCase :: [SAlt] -> Bool
587isDefaultOnlyCase [SDefaultCase _] = True
588isDefaultOnlyCase [] = True
589isDefaultOnlyCase _ = False
591mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt]
592mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) =
593 do pushScope
594 stmt <- mkExp pp branchExpression
595 popScope
596 return stmt
597mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs
598mkDefaultMatch pp [] =
599 ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern")
601mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp
602mkMatchConstExp var c
603 | isPrimitive cty =
604 (\ var -> (primFnType ~> opName (LEq undefined)) [var, jc] ~==~ jInt 1)
605 <$> (Just cty <>@! var)
606 | isArray cty =
607 (\ var -> (arraysType ~> "equals") [var, jc])
608 <$> (Just cty <>@! var)
609 | isString cty =
610 (\ var -> ((primFnType ~> opName (LStrEq)) [var, jc] ~==~ jInt 1))
611 <$> (Just cty <>@! var)
612 | otherwise =
613 (\ var -> (var ~> "equals") [jc])
614 <$> (Just cty <>@! var)
615 where
616 cty = constType c
617 jc = mkConstant c
619mkConstMatch :: BlockPostprocessor ->
620 (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
621 LVar ->
622 [SAlt] ->
623 CodeGeneration Stmt
624mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do
625 matchExp <- mkMatchConstExp var constant
626 pushScope
627 branchBlock <- mkExp pp branchExpression
628 popScope
629 otherBranches <- mkConstMatch pp getDefaultStmts var cases
630 return
631 $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches
632mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases
633mkConstMatch pp getDefaultStmts _ [] = do
634 defaultBlock <- getDefaultStmts pp
635 return $ StmtBlock (Block defaultBlock)
637mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp
638mkGetConstructorId True var =
639 (\ var -> ((idrisObjectType <> var) ~> "getConstructorId") [])
640 <$> (Nothing <>@! var)
641mkGetConstructorId False var =
642 (\ var match ->
643 Cond (InstanceOf var (toRefType idrisObjectType)) match (jInt (-1))
644 )
645 <$> (Nothing <>@! var)
646 <*> mkGetConstructorId True var
648mkConsMatch :: BlockPostprocessor ->
649 (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
650 LVar ->
651 [SAlt] ->
652 CodeGeneration [SwitchBlock]
653mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do
654 pushScope
655 caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression
656 popScope
657 otherBranches <- mkConsMatch pp getDefaultStmts var cases
658 return $
659 (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches
660mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases
661mkConsMatch pp getDefaultStmts _ [] = do
662 defaultBlock <- getDefaultStmts pp
663 return $
664 [SwitchBlock Default defaultBlock]
666mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt]
667mkCaseBinding pp var stackStart params branchExpression =
668 mkExp pp (toLetIn var stackStart params branchExpression)
669 where
670 toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp
671 toLetIn var stackStart members start =
672 foldr
673 (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp)
674 start
675 [0.. (length members - 1)]
677-----------------------------------------------------------------------
678-- Projection (retrieve the n-th field of an object)
680mkProjection :: LVar -> Int -> CodeGeneration Exp
681mkProjection var memberNr =
682 (\ var -> ArrayAccess $ ((var ~> "getData") []) @! memberNr)
683 <$> (Just idrisObjectType <>@! var)
685-----------------------------------------------------------------------
686-- Constants
688mkConstantArray :: (V.Unbox a) => J.Type -> (a -> Const) -> V.Vector a -> Exp
689mkConstantArray cty elemToConst elems =
690 ArrayCreateInit
691 cty
692 0
693 (ArrayInit . map (InitExp . mkConstant . elemToConst) $ V.toList elems)
695mkConstant :: Const -> Exp
696mkConstant c@(I x) = constType c <> (Lit . Word $ toInteger x)
697mkConstant c@(BI x) = bigInteger (show x)
698mkConstant c@(Fl x) = constType c <> (Lit . Double $ x)
699mkConstant c@(Ch x) = constType c <> (Lit . Char $ x)
700mkConstant c@(Str x) = constType c <> (Lit . String $ x)
701mkConstant c@(B8 x) = constType c <> (Lit . Word $ toInteger x)
702mkConstant c@(B16 x) = constType c <> (Lit . Word $ toInteger x)
703mkConstant c@(B32 x) = constType c <> (Lit . Word $ toInteger x)
704mkConstant c@(B64 x) = (bigInteger (show c) ~> "longValue") []
705mkConstant c@(B8V x) = mkConstantArray (constType c) B8 x
706mkConstant c@(B16V x) = mkConstantArray (constType c) B16 x
707mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x
708mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x
709mkConstant c@(AType x) = ClassLit (Just $ box (constType c))
710mkConstant c@(StrType ) = ClassLit (Just $ stringType)
711mkConstant c@(PtrType ) = 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]