git.iko.soy/Idris-dev
on db306ca help sign in
Idris-dev/src/IRTS/CodegenJava.hs
749 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 ] ++ otherHdrs
311 )
312 <$> mkTypeDecl clsName globalInit defs
313 where
314 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
315 idrisPrelude = J.Name $ map Ident ["org", "idris", "rts", "Prelude"]
316 bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
317 runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
318 otherHdrs = map ( (\ name -> ImportDecl False name False)
319 . J.Name
320 . map (Ident . T.unpack)
321 . T.splitOn (T.pack ".")
322 . T.pack)
323 $ filter (not . isSuffixOf ".h") hdrs
325-----------------------------------------------------------------------
326-- Main class
328mkTypeDecl :: Ident -> [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration [TypeDecl]
329mkTypeDecl name globalInit defs =
330 (\ body -> [ClassTypeDecl $ ClassDecl [ Public
331 , Annotation $ SingleElementAnnotation
332 (jName "SuppressWarnings")
333 (EVVal . InitExp $ jString "unchecked")
334 ]
335 name
336 []
337 Nothing
338 []
339 body])
340 <$> mkClassBody globalInit (map (second (prefixCallNamespaces name)) defs)
342mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody
343mkClassBody globalInit defs =
344 (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)
345 <$> mkGlobalContext globalInit
346 <*> mapM mkDecl defs
348mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
349mkGlobalContext [] = return []
350mkGlobalContext initExps = do
351 pushScope
352 varInit <-
353 mapM (\ (name, exp) -> do
354 pos <- setVariable (Glob name)
355 mkUpdate ignoreResult (Glob name) exp
356 ) initExps
357 popScope
358 return [ MemberDecl $ FieldDecl [Private, Static, Final]
359 (array objectType)
360 [ VarDecl (VarId $ globalContextID). Just . InitExp
361 $ ArrayCreate objectType [jInt $ length initExps] 0
362 ]
363 , InitDecl True (Block $ concat varInit)
364 ]
366addMainMethod :: [Decl] -> [Decl]
367addMainMethod decls
368 | findMainMethod decls = mkMainMethod : decls
369 | otherwise = decls
370 where
371 findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_)
372 | name == mangle' (sMN 0 "runMain") = True
373 findMainMethod (_:decls) = findMainMethod decls
374 findMainMethod [] = False
376mkMainMethod :: Decl
377mkMainMethod =
378 simpleMethod
379 [Public, Static]
380 Nothing
381 "main"
382 [FormalParam [] (array stringType) False (VarId $ Ident "args")]
383 $ Block [ BlockStmt . ExpStmt
384 $ call "idris_initArgs" [ (threadType ~> "currentThread") []
385 , jConst "args"
386 ]
387 , BlockStmt . ExpStmt $ call (mangle' (sMN 0 "runMain")) []
388 ]
390-----------------------------------------------------------------------
391-- Inner classes (idris namespaces)
393mergeInnerClasses :: [Decl] -> [Decl]
394mergeInnerClasses = foldl' mergeInner []
395 where
396 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)
397 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))
398 | name == name' =
399 (MemberDecl $ MemberClassDecl $
400 ClassDecl priv
401 name
402 targs
403 (mplus ext ext')
404 (imp ++ imp')
405 (ClassBody $ mergeInnerClasses (body ++ body')))
406 : decls
407 | otherwise = decl:(mergeInner decls decl')
408 mergeInner (decl:decls) decl' = decl:(mergeInner decls decl')
409 mergeInner [] decl' = [decl']
413mkDecl :: (Name, SDecl) -> CodeGeneration Decl
414mkDecl ((NS n (ns:nss)), decl) =
415 (\ name body ->
416 MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
417 <$> mangle (UN ns)
418 <*> mkClassBody [] [(NS n nss, decl)]
419mkDecl (_, SFun name params stackSize body) = do
420 (Ident methodName) <- mangle name
421 methodParams <- mapM mkFormalParam params
422 paramNames <- mapM mangle params
423 pushParams paramNames
424 methodBody <- mkExp addReturn body
425 popScope
426 return $
427 simpleMethod [Public, Static] (Just objectType) methodName methodParams
428 (Block methodBody)
430mkFormalParam :: Name -> CodeGeneration FormalParam
431mkFormalParam name =
432 (\ name -> FormalParam [Final] objectType False (VarId name))
433 <$> mangle name
435-----------------------------------------------------------------------
436-- Expressions
438-- | Compile a simple expression and use the given continuation to postprocess
439-- the resulting value.
440mkExp :: BlockPostprocessor -> SExp -> CodeGeneration [BlockStmt]
441-- Variables
442mkExp pp (SV var) =
443 (Nothing <>@! var) >>= ppExp pp
445-- Applications
446mkExp pp (SApp pushTail name args) =
447 mkApp pushTail name args >>= ppExp pp
449-- Bindings
450mkExp pp (SLet var newExp inExp) =
451 mkLet pp var newExp inExp
452mkExp pp (SUpdate var@(Loc i) newExp) = -- can only update locals
453 mkUpdate pp var newExp
454mkExp pp (SUpdate var newExp) =
455 mkExp pp newExp
457-- Objects
458mkExp pp (SCon conId _ args) =
459 mkIdrisObject conId args >>= ppExp pp
461-- Case expressions
462mkExp pp (SCase var alts) = mkCase pp True var alts
463mkExp pp (SChkCase var alts) = mkCase pp False var alts
465-- Projections
466mkExp pp (SProj var i) =
467 mkProjection var i >>= ppExp pp
469-- Constants
470mkExp pp (SConst c) =
471 ppExp pp $ mkConstant c
473-- Foreign function calls
474mkExp pp (SForeign lang resTy text params) =
475 mkForeign pp lang resTy text params
477-- Primitive functions
478mkExp pp (SOp LFork [arg]) =
479 (mkThread arg) >>= ppExp pp
480mkExp pp (SOp LPar [arg]) =
481 (Nothing <>@! arg) >>= ppExp pp
482mkExp pp (SOp LNoOp args) =
483 (Nothing <>@! (last args)) >>= ppExp pp
484mkExp pp (SOp LNullPtr args) =
485 ppExp pp $ Lit Null
486mkExp pp (SOp op args) =
487 (mkPrimitiveFunction op args) >>= ppExp pp
489-- Empty expressions
490mkExp pp (SNothing) = ppExp pp $ Lit Null
492-- Errors
493mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err)
495-----------------------------------------------------------------------
496-- Variable access
498(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp
499(<>@!) Nothing var =
500 either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var
501(<>@!) (Just castTo) var =
502 (castTo <>) <$> (Nothing <>@! var)
504-----------------------------------------------------------------------
505-- Application (wrap method calls in tail call closures)
507mkApp :: Bool -> Name -> [LVar] -> CodeGeneration Exp
508mkApp False name args =
509 (\ methodName params ->
510 (idrisClosureType ~> "unwrapTailCall") [call methodName params]
511 )
512 <$> mangleFull name
513 <*> mapM (Nothing <>@!) args
514mkApp True name args = mkMethodCallClosure name args
516mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp
517mkMethodCallClosure name args =
518 (\ name args -> closure (call name args))
519 <$> mangleFull name
520 <*> mapM (Nothing <>@!) args
522-----------------------------------------------------------------------
523-- Updates (change context array) and Let bindings (Update, execute)
525mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt]
526mkUpdate pp var exp =
527 mkExp
528 ( pp
529 { ppInnerBlock =
530 (\ blk rhs -> do
531 pos <- setVariable var
532 vExp <- Nothing <>@! var
533 ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp
534 )
535 }
536 ) exp
538mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt]
539mkLet pp var@(Loc pos) newExp inExp =
540 mkUpdate (pp { ppInnerBlock =
541 (\ blk _ -> do
542 inBlk <- mkExp pp inExp
543 return (blk ++ inBlk)
544 )
545 }
546 ) var newExp
547mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
549-----------------------------------------------------------------------
550-- Object creation
552mkIdrisObject :: Int -> [LVar] -> CodeGeneration Exp
553mkIdrisObject conId args =
554 (\ args ->
555 InstanceCreation [] (toClassType idrisObjectType) ((jInt conId):args) Nothing
556 )
557 <$> mapM (Nothing <>@!) args
559-----------------------------------------------------------------------
560-- Case expressions
562mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt]
563mkCase pp checked var cases
564 | isDefaultOnlyCase cases = mkDefaultMatch pp cases
565 | isConstCase cases = do
566 ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
567 ppOuterBlock pp [BlockStmt ifte]
568 | otherwise = do
569 switchExp <- mkGetConstructorId checked var
570 matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
571 ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks]
573isConstCase :: [SAlt] -> Bool
574isConstCase ((SConstCase _ _):_) = True
575isConstCase ((SDefaultCase _):cases) = isConstCase cases
576isConstCase _ = False
578isDefaultOnlyCase :: [SAlt] -> Bool
579isDefaultOnlyCase [SDefaultCase _] = True
580isDefaultOnlyCase [] = True
581isDefaultOnlyCase _ = False
583mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt]
584mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) =
585 do pushScope
586 stmt <- mkExp pp branchExpression
587 popScope
588 return stmt
589mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs
590mkDefaultMatch pp [] =
591 ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern")
593mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp
594mkMatchConstExp var c
595 | isPrimitive cty =
596 (\ var -> (primFnType ~> opName (LEq undefined)) [var, jc] ~==~ jInt 1)
597 <$> (Just cty <>@! var)
598 | isArray cty =
599 (\ var -> (arraysType ~> "equals") [var, jc])
600 <$> (Just cty <>@! var)
601 | isString cty =
602 (\ var -> ((primFnType ~> opName (LStrEq)) [var, jc] ~==~ jInt 1))
603 <$> (Just cty <>@! var)
604 | otherwise =
605 (\ var -> (var ~> "equals") [jc])
606 <$> (Just cty <>@! var)
607 where
608 cty = constType c
609 jc = mkConstant c
611mkConstMatch :: BlockPostprocessor ->
612 (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
613 LVar ->
614 [SAlt] ->
615 CodeGeneration Stmt
616mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do
617 matchExp <- mkMatchConstExp var constant
618 pushScope
619 branchBlock <- mkExp pp branchExpression
620 popScope
621 otherBranches <- mkConstMatch pp getDefaultStmts var cases
622 return
623 $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches
624mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases
625mkConstMatch pp getDefaultStmts _ [] = do
626 defaultBlock <- getDefaultStmts pp
627 return $ StmtBlock (Block defaultBlock)
629mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp
630mkGetConstructorId True var =
631 (\ var -> ((idrisObjectType <> var) ~> "getConstructorId") [])
632 <$> (Nothing <>@! var)
633mkGetConstructorId False var =
634 (\ var match ->
635 Cond (InstanceOf var (toRefType idrisObjectType)) match (jInt (-1))
636 )
637 <$> (Nothing <>@! var)
638 <*> mkGetConstructorId True var
640mkConsMatch :: BlockPostprocessor ->
641 (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
642 LVar ->
643 [SAlt] ->
644 CodeGeneration [SwitchBlock]
645mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do
646 pushScope
647 caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression
648 popScope
649 otherBranches <- mkConsMatch pp getDefaultStmts var cases
650 return $
651 (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches
652mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases
653mkConsMatch pp getDefaultStmts _ [] = do
654 defaultBlock <- getDefaultStmts pp
655 return $
656 [SwitchBlock Default defaultBlock]
658mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt]
659mkCaseBinding pp var stackStart params branchExpression =
660 mkExp pp (toLetIn var stackStart params branchExpression)
661 where
662 toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp
663 toLetIn var stackStart members start =
664 foldr
665 (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp)
666 start
667 [0.. (length members - 1)]
669-----------------------------------------------------------------------
670-- Projection (retrieve the n-th field of an object)
672mkProjection :: LVar -> Int -> CodeGeneration Exp
673mkProjection var memberNr =
674 (\ var -> ArrayAccess $ ((var ~> "getData") []) @! memberNr)
675 <$> (Just idrisObjectType <>@! var)
677-----------------------------------------------------------------------
678-- Constants
680mkConstantArray :: (V.Unbox a) => J.Type -> (a -> Const) -> V.Vector a -> Exp
681mkConstantArray cty elemToConst elems =
682 ArrayCreateInit
683 cty
684 0
685 (ArrayInit . map (InitExp . mkConstant . elemToConst) $ V.toList elems)
687mkConstant :: Const -> Exp
688mkConstant c@(I x) = constType c <> (Lit . Word $ toInteger x)
689mkConstant c@(BI x) = bigInteger (show x)
690mkConstant c@(Fl x) = constType c <> (Lit . Double $ x)
691mkConstant c@(Ch x) = constType c <> (Lit . Char $ x)
692mkConstant c@(Str x) = constType c <> (Lit . String $ x)
693mkConstant c@(B8 x) = constType c <> (Lit . Word $ toInteger x)
694mkConstant c@(B16 x) = constType c <> (Lit . Word $ toInteger x)
695mkConstant c@(B32 x) = constType c <> (Lit . Word $ toInteger x)
696mkConstant c@(B64 x) = (bigInteger (show c) ~> "longValue") []
697mkConstant c@(B8V x) = mkConstantArray (constType c) B8 x
698mkConstant c@(B16V x) = mkConstantArray (constType c) B16 x
699mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x
700mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x
701mkConstant c@(AType x) = ClassLit (Just $ box (constType c))
702mkConstant c@(StrType ) = ClassLit (Just $ stringType)
703mkConstant c@(PtrType ) = ClassLit (Just $ objectType)
704mkConstant c@(ManagedPtrType) = ClassLit (Just $ objectType)
705mkConstant c@(VoidType ) = ClassLit (Just $ voidType)
706mkConstant c@(Forgot ) = ClassLit (Just $ objectType)
708-----------------------------------------------------------------------
709-- Foreign function calls
711mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt]
712mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params
713mkForeign pp (LANG_JAVA callType) resTy text params
714 | callType <- FStatic = do
715 method <- liftParsed (parser name text)
716 args <- foreignVarAccess params
717 wrapReturn resTy (call method args)
718 | callType <- FObject = do
719 method <- liftParsed (parser ident text)
720 (tgt:args) <- foreignVarAccess params
721 wrapReturn resTy ((tgt ~> (show $ pretty method)) args)
722 | callType <- FConstructor = do
723 clsTy <- liftParsed (parser classType text)
724 args <- foreignVarAccess params
725 wrapReturn resTy (InstanceCreation [] clsTy args Nothing)
726 where
727 foreignVarAccess args =
728 mapM (\ (fty, var) -> (foreignType fty <>@! var)) args
730 pp' = rethrowAsRuntimeException pp
732 wrapReturn FUnit exp =
733 ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp'
734 wrapReturn _ exp =
735 ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp'
737-----------------------------------------------------------------------
738-- Primitive functions
740mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp
741mkPrimitiveFunction op args =
742 (\ args -> (primFnType ~> opName op) args)
743 <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op))
745mkThread :: LVar -> CodeGeneration Exp
746mkThread arg =
747 (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (sMN 0 "EVAL") [arg]