git.iko.soy/Idris-dev
on 0875310 help sign in
Idris-dev/src/IRTS/CodegenJava.hs
754 lines 27 kB history raw
1{-# LANGUAGE PatternGuards #-}
2module IRTS.CodegenJava (codegenJava) where
4import Idris.Core.TT hiding (mkApp)
5import IRTS.CodegenCommon
6import IRTS.Java.ASTBuilding
7import IRTS.Java.JTypes
8import IRTS.Java.Mangling
9import IRTS.Java.Pom (pomString)
10import IRTS.Lang
11import IRTS.Simplified
12import IRTS.System
13import Util.System
15import Control.Applicative hiding (Const)
16import Control.Arrow
17import Control.Monad
18import Control.Monad.Error
19import qualified Control.Monad.Trans as T
20import Control.Monad.Trans.State
21import Data.List (foldl', isSuffixOf)
22import qualified Data.Text as T
23import qualified Data.Text.IO as TIO
24import qualified Data.Vector.Unboxed as V
25import Language.Java.Parser
26import Language.Java.Pretty
27import Language.Java.Syntax hiding (Name)
28import qualified Language.Java.Syntax as J
29import System.Directory
30import System.Exit
31import System.FilePath
32import System.IO
33import System.Process
35-----------------------------------------------------------------------
36-- Main function
37codegenJava :: [(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 | findMain decls = mkMainMethod : decls
369 | otherwise = decls
370 where
371 findMain ((MemberDecl (MemberClassDecl (ClassDecl _ name _ _ _ (ClassBody body)))):_)
372 | name == mangle' (sUN "Main") = findMainMethod body
373 findMain (_:decls) = findMain decls
374 findMain [] = False
376 innerMainMethod = (either error id $ mangle (sUN "main"))
377 findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_)
378 | name == mangle' (sUN "main") = True
379 findMainMethod (_:decls) = findMainMethod decls
380 findMainMethod [] = False
382mkMainMethod :: Decl
383mkMainMethod =
384 simpleMethod
385 [Public, Static]
386 Nothing
387 "main"
388 [FormalParam [] (array stringType) False (VarId $ Ident "args")]
389 $ Block [ BlockStmt . ExpStmt
390 $ call "idris_initArgs" [ (threadType ~> "currentThread") []
391 , jConst "args"
392 ]
393 , BlockStmt . ExpStmt $ call (mangle' (sMN 0 "runMain")) []
394 ]
396-----------------------------------------------------------------------
397-- Inner classes (idris namespaces)
399mergeInnerClasses :: [Decl] -> [Decl]
400mergeInnerClasses = foldl' mergeInner []
401 where
402 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)
403 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))
404 | name == name' =
405 (MemberDecl $ MemberClassDecl $
406 ClassDecl priv
407 name
408 targs
409 (mplus ext ext')
410 (imp ++ imp')
411 (ClassBody $ mergeInnerClasses (body ++ body')))
412 : decls
413 | otherwise = decl:(mergeInner decls decl')
414 mergeInner (decl:decls) decl' = decl:(mergeInner decls decl')
415 mergeInner [] decl' = [decl']
419mkDecl :: (Name, SDecl) -> CodeGeneration Decl
420mkDecl ((NS n (ns:nss)), decl) =
421 (\ name body ->
422 MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
423 <$> mangle (UN ns)
424 <*> mkClassBody [] [(NS n nss, decl)]
425mkDecl (_, SFun name params stackSize body) = do
426 (Ident methodName) <- mangle name
427 methodParams <- mapM mkFormalParam params
428 paramNames <- mapM mangle params
429 pushParams paramNames
430 methodBody <- mkExp addReturn body
431 popScope
432 return $
433 simpleMethod [Public, Static] (Just objectType) methodName methodParams
434 (Block methodBody)
436mkFormalParam :: Name -> CodeGeneration FormalParam
437mkFormalParam name =
438 (\ name -> FormalParam [Final] objectType False (VarId name))
439 <$> mangle name
441-----------------------------------------------------------------------
442-- Expressions
444-- | Compile a simple expression and use the given continuation to postprocess
445-- the resulting value.
446mkExp :: BlockPostprocessor -> SExp -> CodeGeneration [BlockStmt]
447-- Variables
448mkExp pp (SV var) =
449 (Nothing <>@! var) >>= ppExp pp
451-- Applications
452mkExp pp (SApp pushTail name args) =
453 mkApp pushTail name args >>= ppExp pp
455-- Bindings
456mkExp pp (SLet var newExp inExp) =
457 mkLet pp var newExp inExp
458mkExp pp (SUpdate var@(Loc i) newExp) = -- can only update locals
459 mkUpdate pp var newExp
460mkExp pp (SUpdate var newExp) =
461 mkExp pp newExp
463-- Objects
464mkExp pp (SCon conId _ args) =
465 mkIdrisObject conId args >>= ppExp pp
467-- Case expressions
468mkExp pp (SCase var alts) = mkCase pp True var alts
469mkExp pp (SChkCase var alts) = mkCase pp False var alts
471-- Projections
472mkExp pp (SProj var i) =
473 mkProjection var i >>= ppExp pp
475-- Constants
476mkExp pp (SConst c) =
477 ppExp pp $ mkConstant c
479-- Foreign function calls
480mkExp pp (SForeign lang resTy text params) =
481 mkForeign pp lang resTy text params
483-- Primitive functions
484mkExp pp (SOp LFork [arg]) =
485 (mkThread arg) >>= ppExp pp
486mkExp pp (SOp LPar [arg]) =
487 (Nothing <>@! arg) >>= ppExp pp
488mkExp pp (SOp LNoOp args) =
489 (Nothing <>@! (last args)) >>= ppExp pp
490mkExp pp (SOp LNullPtr args) =
491 ppExp pp $ Lit Null
492mkExp pp (SOp op args) =
493 (mkPrimitiveFunction op args) >>= ppExp pp
495-- Empty expressions
496mkExp pp (SNothing) = ppExp pp $ Lit Null
498-- Errors
499mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err)
501-----------------------------------------------------------------------
502-- Variable access
504(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp
505(<>@!) Nothing var =
506 either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var
507(<>@!) (Just castTo) var =
508 (castTo <>) <$> (Nothing <>@! var)
510-----------------------------------------------------------------------
511-- Application (wrap method calls in tail call closures)
513mkApp :: Bool -> Name -> [LVar] -> CodeGeneration Exp
514mkApp False name args =
515 (\ methodName params ->
516 (idrisClosureType ~> "unwrapTailCall") [call methodName params]
517 )
518 <$> mangleFull name
519 <*> mapM (Nothing <>@!) args
520mkApp True name args = mkMethodCallClosure name args
522mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp
523mkMethodCallClosure name args =
524 (\ name args -> closure (call name args))
525 <$> mangleFull name
526 <*> mapM (Nothing <>@!) args
528-----------------------------------------------------------------------
529-- Updates (change context array) and Let bindings (Update, execute)
531mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt]
532mkUpdate pp var exp =
533 mkExp
534 ( pp
535 { ppInnerBlock =
536 (\ blk rhs -> do
537 pos <- setVariable var
538 vExp <- Nothing <>@! var
539 ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp
540 )
541 }
542 ) exp
544mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt]
545mkLet pp var@(Loc pos) newExp inExp =
546 mkUpdate (pp { ppInnerBlock =
547 (\ blk _ -> do
548 inBlk <- mkExp pp inExp
549 return (blk ++ inBlk)
550 )
551 }
552 ) var newExp
553mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
555-----------------------------------------------------------------------
556-- Object creation
558mkIdrisObject :: Int -> [LVar] -> CodeGeneration Exp
559mkIdrisObject conId args =
560 (\ args ->
561 InstanceCreation [] (toClassType idrisObjectType) ((jInt conId):args) Nothing
562 )
563 <$> mapM (Nothing <>@!) args
565-----------------------------------------------------------------------
566-- Case expressions
568mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt]
569mkCase pp checked var cases
570 | isDefaultOnlyCase cases = mkDefaultMatch pp cases
571 | isConstCase cases = do
572 ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
573 ppOuterBlock pp [BlockStmt ifte]
574 | otherwise = do
575 switchExp <- mkGetConstructorId checked var
576 matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
577 ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks]
579isConstCase :: [SAlt] -> Bool
580isConstCase ((SConstCase _ _):_) = True
581isConstCase ((SDefaultCase _):cases) = isConstCase cases
582isConstCase _ = False
584isDefaultOnlyCase :: [SAlt] -> Bool
585isDefaultOnlyCase [SDefaultCase _] = True
586isDefaultOnlyCase [] = True
587isDefaultOnlyCase _ = False
589mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt]
590mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) =
591 do pushScope
592 stmt <- mkExp pp branchExpression
593 popScope
594 return stmt
595mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs
596mkDefaultMatch pp [] =
597 ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern")
599mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp
600mkMatchConstExp var c
601 | isPrimitive cty =
602 (\ var -> (primFnType ~> opName (LEq undefined)) [var, jc] ~==~ jInt 1)
603 <$> (Just cty <>@! var)
604 | isArray cty =
605 (\ var -> (arraysType ~> "equals") [var, jc])
606 <$> (Just cty <>@! var)
607 | isString cty =
608 (\ var -> ((primFnType ~> opName (LStrEq)) [var, jc] ~==~ jInt 1))
609 <$> (Just cty <>@! var)
610 | otherwise =
611 (\ var -> (var ~> "equals") [jc])
612 <$> (Just cty <>@! var)
613 where
614 cty = constType c
615 jc = mkConstant c
617mkConstMatch :: BlockPostprocessor ->
618 (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
619 LVar ->
620 [SAlt] ->
621 CodeGeneration Stmt
622mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do
623 matchExp <- mkMatchConstExp var constant
624 pushScope
625 branchBlock <- mkExp pp branchExpression
626 popScope
627 otherBranches <- mkConstMatch pp getDefaultStmts var cases
628 return
629 $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches
630mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases
631mkConstMatch pp getDefaultStmts _ [] = do
632 defaultBlock <- getDefaultStmts pp
633 return $ StmtBlock (Block defaultBlock)
635mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp
636mkGetConstructorId True var =
637 (\ var -> ((idrisObjectType <> var) ~> "getConstructorId") [])
638 <$> (Nothing <>@! var)
639mkGetConstructorId False var =
640 (\ var match ->
641 Cond (InstanceOf var (toRefType idrisObjectType)) match (jInt (-1))
642 )
643 <$> (Nothing <>@! var)
644 <*> mkGetConstructorId True var
646mkConsMatch :: BlockPostprocessor ->
647 (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
648 LVar ->
649 [SAlt] ->
650 CodeGeneration [SwitchBlock]
651mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do
652 pushScope
653 caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression
654 popScope
655 otherBranches <- mkConsMatch pp getDefaultStmts var cases
656 return $
657 (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches
658mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases
659mkConsMatch pp getDefaultStmts _ [] = do
660 defaultBlock <- getDefaultStmts pp
661 return $
662 [SwitchBlock Default defaultBlock]
664mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt]
665mkCaseBinding pp var stackStart params branchExpression =
666 mkExp pp (toLetIn var stackStart params branchExpression)
667 where
668 toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp
669 toLetIn var stackStart members start =
670 foldr
671 (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp)
672 start
673 [0.. (length members - 1)]
675-----------------------------------------------------------------------
676-- Projection (retrieve the n-th field of an object)
678mkProjection :: LVar -> Int -> CodeGeneration Exp
679mkProjection var memberNr =
680 (\ var -> ArrayAccess $ ((var ~> "getData") []) @! memberNr)
681 <$> (Just idrisObjectType <>@! var)
683-----------------------------------------------------------------------
684-- Constants
686mkConstantArray :: (V.Unbox a) => J.Type -> (a -> Const) -> V.Vector a -> Exp
687mkConstantArray cty elemToConst elems =
688 ArrayCreateInit
689 cty
690 0
691 (ArrayInit . map (InitExp . mkConstant . elemToConst) $ V.toList elems)
693mkConstant :: Const -> Exp
694mkConstant c@(I x) = constType c <> (Lit . Word $ toInteger x)
695mkConstant c@(BI x) = bigInteger (show x)
696mkConstant c@(Fl x) = constType c <> (Lit . Double $ x)
697mkConstant c@(Ch x) = constType c <> (Lit . Char $ x)
698mkConstant c@(Str x) = constType c <> (Lit . String $ x)
699mkConstant c@(B8 x) = constType c <> (Lit . Word $ toInteger x)
700mkConstant c@(B16 x) = constType c <> (Lit . Word $ toInteger x)
701mkConstant c@(B32 x) = constType c <> (Lit . Word $ toInteger x)
702mkConstant c@(B64 x) = (bigInteger (show c) ~> "longValue") []
703mkConstant c@(B8V x) = mkConstantArray (constType c) B8 x
704mkConstant c@(B16V x) = mkConstantArray (constType c) B16 x
705mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x
706mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x
707mkConstant c@(AType x) = ClassLit (Just $ box (constType c))
708mkConstant c@(StrType ) = ClassLit (Just $ stringType)
709mkConstant c@(PtrType ) = ClassLit (Just $ objectType)
710mkConstant c@(VoidType ) = ClassLit (Just $ voidType)
711mkConstant c@(Forgot ) = ClassLit (Just $ objectType)
713-----------------------------------------------------------------------
714-- Foreign function calls
716mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt]
717mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params
718mkForeign pp (LANG_JAVA callType) resTy text params
719 | callType <- FStatic = do
720 method <- liftParsed (parser name text)
721 args <- foreignVarAccess params
722 wrapReturn resTy (call method args)
723 | callType <- FObject = do
724 method <- liftParsed (parser ident text)
725 (tgt:args) <- foreignVarAccess params
726 wrapReturn resTy ((tgt ~> (show $ pretty method)) args)
727 | callType <- FConstructor = do
728 clsTy <- liftParsed (parser classType text)
729 args <- foreignVarAccess params
730 wrapReturn resTy (InstanceCreation [] clsTy args Nothing)
731 where
732 foreignVarAccess args =
733 mapM (\ (fty, var) -> (foreignType fty <>@! var)) args
735 pp' = rethrowAsRuntimeException pp
737 wrapReturn FUnit exp =
738 ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp'
739 wrapReturn _ exp =
740 ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp'
742-----------------------------------------------------------------------
743-- Primitive functions
745mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp
746mkPrimitiveFunction op args =
747 (\ args -> (primFnType ~> opName op) args)
748 <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op))
750mkThread :: LVar -> CodeGeneration Exp
751mkThread arg =
752 (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (sMN 0 "EVAL") [arg]