git.iko.soy/Idris-dev
on fbd6471 help sign in
Idris-dev/src/IRTS/CodegenJava.hs
726 lines 27 kB history raw
1{-# LANGUAGE PatternGuards #-}
2module IRTS.CodegenJava (codegenJava) where
4import Core.TT hiding (mkApp)
5import IRTS.BCImp
6import IRTS.CodegenCommon
7import IRTS.Java.ASTBuilding
8import IRTS.Java.JTypes
9import IRTS.Java.Mangling
10import IRTS.Lang
11import IRTS.Simplified
12import Paths_idris
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.Int
22import Data.List (foldl', intercalate, isPrefixOf,
23 isSuffixOf)
24import Data.Maybe (fromJust)
25import qualified Data.Text as T
26import qualified Data.Text.IO as TIO
27import qualified Data.Vector.Unboxed as V
28import Language.Java.Parser
29import Language.Java.Pretty
30import Language.Java.Syntax hiding (Name)
31import qualified Language.Java.Syntax as J
32import System.Directory
33import System.Exit
34import System.FilePath
35import System.IO
36import System.Process
38-----------------------------------------------------------------------
39-- Main function
41codegenJava :: [(Name, SExp)] -> -- initialization of globals
42 [(Name, SDecl)] ->
43 FilePath -> -- output file name
44 [String] -> -- headers
45 [String] -> -- libs
46 OutputType ->
47 IO ()
48codegenJava globalInit defs out hdrs libs exec = do
49 withTempdir (takeBaseName out) $ \ tmpDir -> do
50 let srcdir = tmpDir </> "src" </> "main" </> "java"
51 createDirectoryIfMissing True srcdir
52 let (Ident clsName) = either error id (mkClassName out)
53 let outjava = srcdir </> clsName <.> "java"
54 let jout = either error
55 (prettyPrint)-- flatIndent . prettyPrint)
56 (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv)
57 writeFile outjava jout
58 if (exec == Raw)
59 then copyFile outjava (takeDirectory out </> clsName <.> "java")
60 else do
61 execPom <- getExecutablePom
62 execPomTemplate <- TIO.readFile execPom
63 let execPom = T.replace (T.pack "$MAIN-CLASS$")
64 (T.pack clsName)
65 (T.replace (T.pack "$ARTIFACT-NAME$")
66 (T.pack $ takeBaseName out)
67 (T.replace (T.pack "$DEPENDENCIES$")
68 (mkPomDependencies libs)
69 execPomTemplate
70 )
71 )
72 TIO.writeFile (tmpDir </> "pom.xml") execPom
73 mvnCmd <- getMvn
74 let args = ["-f", (tmpDir </> "pom.xml")]
75 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["compile"]) ""
76 when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " compile\n" ++ err ++ mvout)
77 if (exec == Object)
78 then do
79 classFiles <-
80 map (\ clsFile -> tmpDir </> "target" </> "classes" </> clsFile)
81 . filter ((".class" ==) . takeExtension)
82 <$> getDirectoryContents (tmpDir </> "target" </> "classes")
83 mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile))
84 classFiles
85 else do
86 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["package"]) ""
87 when (exit /= ExitSuccess) (error ("FAILURE: " ++ mvnCmd ++ " package\n" ++ err ++ mvout))
88 copyFile (tmpDir </> "target" </> (takeBaseName out) <.> "jar") out
89 handle <- openBinaryFile out ReadMode
90 contents <- TIO.hGetContents handle
91 hClose handle
92 handle <- openBinaryFile out WriteMode
93 TIO.hPutStr handle (T.append (T.pack jarHeader) contents)
94 hFlush handle
95 hClose handle
96 perms <- getPermissions out
97 setPermissions out (setOwnerExecutable True perms)
98 readProcess mvnCmd (args ++ ["clean"]) ""
99 removeFile (tmpDir </> "pom.xml")
101-----------------------------------------------------------------------
102-- Jar and Pom infrastructure
104jarHeader :: String
105jarHeader =
106 "#!/bin/sh\n"
107 ++ "MYSELF=`which \"$0\" 2>/dev/null`\n"
108 ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n"
109 ++ "java=java\n"
110 ++ "if test -n \"$JAVA_HOME\"; then\n"
111 ++ " java=\"$JAVA_HOME/bin/java\"\n"
112 ++ "fi\n"
113 ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\""
114 ++ "exit 1\n"
116mkPomDependencies :: [String] -> T.Text
117mkPomDependencies deps =
118 T.concat $ map (T.concat . map (T.append (T.pack " ")) . mkDependency . T.pack) deps
119 where
120 mkDependency s =
121 case T.splitOn (T.pack ":") s of
122 [g, a, v] ->
123 [ T.pack $ "<dependency>\n"
124 , T.append (T.pack " ") $ mkGroupId g
125 , T.append (T.pack " ") $ mkArtifactId a
126 , T.append (T.pack " ") $ mkVersion v
127 , T.pack $ "</dependency>\n"
128 ]
129 _ -> []
130 mkGroupId g = T.append (T.pack $ "<groupId>") (T.append g $ T.pack "</groupId>\n")
131 mkArtifactId a = T.append (T.pack $ "<artifactId>") (T.append a $ T.pack "</artifactId>\n")
132 mkVersion v = T.append (T.pack $ "<version>") (T.append v $ T.pack "</version>\n")
134-----------------------------------------------------------------------
135-- Code generation environment
137data CodeGenerationEnv
138 = CodeGenerationEnv
139 { globalVariables :: [(Name, ArrayIndex)]
140 , localVariables :: [[(Int, Ident)]]
141 , localVarCounter :: Int
142 }
144type CodeGeneration = StateT (CodeGenerationEnv) (Either String)
146mkCodeGenEnv :: CodeGenerationEnv
147mkCodeGenEnv = CodeGenerationEnv [] [] 0
149varPos :: LVar -> CodeGeneration (Either ArrayIndex Ident)
150varPos (Loc i) = do
151 vars <- (concat . localVariables) <$> get
152 case lookup i vars of
153 (Just varName) -> return (Right varName)
154 Nothing -> throwError $ "Invalid local variable id: " ++ show i
155varPos (Glob name) = do
156 vars <- globalVariables <$> get
157 case lookup name vars of
158 (Just varIdx) -> return (Left varIdx)
159 Nothing -> throwError $ "Invalid global variable id: " ++ show name
161pushScope :: CodeGeneration ()
162pushScope =
163 modify (\ env -> env { localVariables = []:(localVariables env) })
165popScope :: CodeGeneration ()
166popScope = do
167 env <- get
168 let lVars = tail $ localVariables env
169 let vC = if null lVars then 0 else localVarCounter env
170 put $ env { localVariables = tail (localVariables env)
171 , localVarCounter = vC }
173setVariable :: LVar -> CodeGeneration (Either ArrayIndex Ident)
174setVariable (Loc i) = do
175 env <- get
176 let lVars = localVariables env
177 let getter = localVar $ localVarCounter env
178 let lVars' = ((i, getter) : head lVars) : tail lVars
179 put $ env { localVariables = lVars'
180 , localVarCounter = 1 + localVarCounter env}
181 return (Right getter)
182setVariable (Glob n) = do
183 env <- get
184 let gVars = globalVariables env
185 let getter = globalContext @! length gVars
186 let gVars' = (n, getter):gVars
187 put (env { globalVariables = gVars' })
188 return (Left getter)
190pushParams :: [Ident] -> CodeGeneration ()
191pushParams paramNames =
192 let varMap = zipWith (flip (,)) paramNames [0..] in
193 modify (\ env -> env { localVariables = varMap:(localVariables env)
194 , localVarCounter = (length varMap) + (localVarCounter env) })
196flatIndent :: String -> String
197flatIndent (' ' : ' ' : xs) = flatIndent xs
198flatIndent (x:xs) = x:flatIndent xs
199flatIndent [] = []
201-----------------------------------------------------------------------
202-- Maintaining control structures over code blocks
204data BlockPostprocessor
205 = BlockPostprocessor
206 { ppInnerBlock :: [BlockStmt] -> Exp -> CodeGeneration [BlockStmt]
207 , ppOuterBlock :: [BlockStmt] -> CodeGeneration [BlockStmt]
208 }
210ppExp :: BlockPostprocessor -> Exp -> CodeGeneration [BlockStmt]
211ppExp pp exp = ((ppInnerBlock pp) [] exp) >>= ppOuterBlock pp
213addReturn :: BlockPostprocessor
214addReturn =
215 BlockPostprocessor
216 { ppInnerBlock = (\ block exp -> return $ block ++ [jReturn exp])
217 , ppOuterBlock = return
218 }
220ignoreResult :: BlockPostprocessor
221ignoreResult =
222 BlockPostprocessor
223 { ppInnerBlock = (\ block exp -> return block)
224 , ppOuterBlock = return
225 }
227ignoreOuter :: BlockPostprocessor -> BlockPostprocessor
228ignoreOuter pp = pp { ppOuterBlock = return }
230throwRuntimeException :: BlockPostprocessor -> BlockPostprocessor
231throwRuntimeException pp =
232 pp
233 { ppInnerBlock =
234 (\ blk exp -> return $
235 blk ++ [ BlockStmt $ Throw
236 ( InstanceCreation
237 []
238 (toClassType runtimeExceptionType)
239 [exp]
240 Nothing
241 )
242 ]
243 )
244 }
247rethrowAsRuntimeException :: BlockPostprocessor -> BlockPostprocessor
248rethrowAsRuntimeException pp =
249 pp
250 { ppOuterBlock =
251 (\ blk -> do
252 ex <- ppInnerBlock (throwRuntimeException pp) [] (ExpName $ J.Name [Ident "ex"])
253 ppOuterBlock pp
254 $ [ BlockStmt $ Try
255 (Block blk)
256 [Catch (FormalParam [] exceptionType False (VarId (Ident "ex"))) $
257 Block ex
258 ]
259 Nothing
260 ]
261 )
262 }
264-----------------------------------------------------------------------
265-- File structure
267mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit
268mkCompilationUnit globalInit defs hdrs out = do
269 clsName <- mkClassName out
270 CompilationUnit Nothing ( [ ImportDecl False idrisRts True
271 , ImportDecl True idrisForeign True
272 , ImportDecl False idrisForeignWrapper False
273 , ImportDecl False idrisPrimFn False
274 , ImportDecl False bigInteger False
275 , ImportDecl False stringBuffer False
276 , ImportDecl False runtimeException False
277 , ImportDecl False scanner False
278 , ImportDecl False arrays False
279 , ImportDecl False callable False
280 ] ++ otherHdrs
281 )
282 <$> mkTypeDecl clsName globalInit defs
283 where
284 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
285 idrisForeign = J.Name $ map Ident ["org", "idris", "rts", "ForeignPrimitives"]
286 idrisForeignWrapper = J.Name $ map Ident ["org", "idris", "rts", "ForeignWrapper"]
287 idrisPrimFn = J.Name $ map Ident ["org", "idris", "rts", "PrimFn"]
288 bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
289 stringBuffer = J.Name $ map Ident ["java", "lang", "StringBuffer"]
290 runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
291 scanner = J.Name $ map Ident ["java", "util", "Scanner"]
292 arrays = J.Name $ map Ident ["java", "util", "Arrays"]
293 callable = J.Name $ map Ident ["java", "util", "concurrent", "Callable"]
294 otherHdrs = map ( (\ name -> ImportDecl False name False)
295 . J.Name
296 . map (Ident . T.unpack)
297 . T.splitOn (T.pack ".")
298 . T.pack)
299 $ filter (not . isSuffixOf ".h") hdrs
301-----------------------------------------------------------------------
302-- Main class
304mkTypeDecl :: Ident -> [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration [TypeDecl]
305mkTypeDecl name globalInit defs =
306 (\ body -> [ClassTypeDecl $ ClassDecl [ Public
307 , Annotation $ SingleElementAnnotation
308 (jName "SuppressWarnings")
309 (EVVal . InitExp $ jString "unchecked")
310 ]
311 name
312 []
313 Nothing
314 []
315 body])
316 <$> mkClassBody globalInit (map (second (prefixCallNamespaces name)) defs)
318mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody
319mkClassBody globalInit defs =
320 (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)
321 <$> mkGlobalContext globalInit
322 <*> mapM mkDecl defs
324mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
325mkGlobalContext [] = return []
326mkGlobalContext initExps = do
327 pushScope
328 varInit <-
329 mapM (\ (name, exp) -> do
330 pos <- setVariable (Glob name)
331 mkUpdate ignoreResult (Glob name) exp
332 ) initExps
333 popScope
334 return [ MemberDecl $ FieldDecl [Private, Static, Final]
335 (array objectType)
336 [ VarDecl (VarId $ globalContextID). Just . InitExp
337 $ ArrayCreate objectType [jInt $ length initExps] 0
338 ]
339 , InitDecl True (Block $ concat varInit)
340 ]
342addMainMethod :: [Decl] -> [Decl]
343addMainMethod decls
344 | findMain decls = mkMainMethod : decls
345 | otherwise = decls
346 where
347 findMain ((MemberDecl (MemberClassDecl (ClassDecl _ name _ _ _ (ClassBody body)))):_)
348 | name == mangle' (UN "Main") = findMainMethod body
349 findMain (_:decls) = findMain decls
350 findMain [] = False
352 innerMainMethod = (either error id $ mangle (UN "main"))
353 findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_)
354 | name == mangle' (UN "main") = True
355 findMainMethod (_:decls) = findMainMethod decls
356 findMainMethod [] = False
358mkMainMethod :: Decl
359mkMainMethod =
360 simpleMethod
361 [Public, Static]
362 Nothing
363 "main"
364 [FormalParam [] (array stringType) False (VarId $ Ident "args")]
365 $ Block [ BlockStmt . ExpStmt
366 $ call "idris_initArgs" [ (threadType ~> "currentThread") []
367 , jConst "args"
368 ]
369 , BlockStmt . ExpStmt $ call (mangle' (MN 0 "runMain")) []
370 ]
372-----------------------------------------------------------------------
373-- Inner classes (idris namespaces)
375mergeInnerClasses :: [Decl] -> [Decl]
376mergeInnerClasses = foldl' mergeInner []
377 where
378 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)
379 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))
380 | name == name' =
381 (MemberDecl $ MemberClassDecl $
382 ClassDecl priv
383 name
384 targs
385 (mplus ext ext')
386 (imp ++ imp')
387 (ClassBody $ mergeInnerClasses (body ++ body')))
388 : decls
389 | otherwise = decl:(mergeInner decls decl')
390 mergeInner (decl:decls) decl' = decl:(mergeInner decls decl')
391 mergeInner [] decl' = [decl']
395mkDecl :: (Name, SDecl) -> CodeGeneration Decl
396mkDecl ((NS n (ns:nss)), decl) =
397 (\ name body ->
398 MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
399 <$> mangle (UN ns)
400 <*> mkClassBody [] [(NS n nss, decl)]
401mkDecl (_, SFun name params stackSize body) = do
402 (Ident methodName) <- mangle name
403 methodParams <- mapM mkFormalParam params
404 paramNames <- mapM mangle params
405 pushParams paramNames
406 methodBody <- mkExp addReturn body
407 popScope
408 return $
409 simpleMethod [Public, Static] (Just objectType) methodName methodParams
410 (Block methodBody)
412mkFormalParam :: Name -> CodeGeneration FormalParam
413mkFormalParam name =
414 (\ name -> FormalParam [Final] objectType False (VarId name))
415 <$> mangle name
417-----------------------------------------------------------------------
418-- Expressions
420-- | Compile a simple expression and use the given continuation to postprocess
421-- the resulting value.
422mkExp :: BlockPostprocessor -> SExp -> CodeGeneration [BlockStmt]
423-- Variables
424mkExp pp (SV var) =
425 (Nothing <>@! var) >>= ppExp pp
427-- Applications
428mkExp pp (SApp pushTail name args) =
429 mkApp pushTail name args >>= ppExp pp
431-- Bindings
432mkExp pp (SLet var newExp inExp) =
433 mkLet pp var newExp inExp
434mkExp pp (SUpdate var newExp) =
435 mkUpdate pp var newExp
437-- Objects
438mkExp pp (SCon conId _ args) =
439 mkIdrisObject conId args >>= ppExp pp
441-- Case expressions
442mkExp pp (SCase var alts) = mkCase pp True var alts
443mkExp pp (SChkCase var alts) = mkCase pp False var alts
445-- Projections
446mkExp pp (SProj var i) =
447 mkProjection var i >>= ppExp pp
449-- Constants
450mkExp pp (SConst c) =
451 ppExp pp $ mkConstant c
453-- Foreign function calls
454mkExp pp (SForeign lang resTy text params) =
455 mkForeign pp lang resTy text params
457-- Primitive functions
458mkExp pp (SOp LFork [arg]) =
459 (mkThread arg) >>= ppExp pp
460mkExp pp (SOp LPar [arg]) =
461 (Nothing <>@! arg) >>= ppExp pp
462mkExp pp (SOp LNoOp args) =
463 (Nothing <>@! (last args)) >>= ppExp pp
464mkExp pp (SOp op args) =
465 (mkPrimitiveFunction op args) >>= ppExp pp
467-- Empty expressions
468mkExp pp (SNothing) = ppExp pp $ Lit Null
470-- Errors
471mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err)
473-----------------------------------------------------------------------
474-- Variable access
476(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp
477(<>@!) Nothing var =
478 either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var
479(<>@!) (Just castTo) var =
480 (castTo <>) <$> (Nothing <>@! var)
482-----------------------------------------------------------------------
483-- Application (wrap method calls in tail call closures)
485mkApp :: Bool -> Name -> [LVar] -> CodeGeneration Exp
486mkApp False name args =
487 (\ methodName params ->
488 (idrisClosureType ~> "unwrapTailCall") [call methodName params]
489 )
490 <$> mangleFull name
491 <*> mapM (Nothing <>@!) args
492mkApp True name args = mkMethodCallClosure name args
494mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp
495mkMethodCallClosure name args =
496 (\ name args -> closure (call name args))
497 <$> mangleFull name
498 <*> mapM (Nothing <>@!) args
500-----------------------------------------------------------------------
501-- Updates (change context array) and Let bindings (Update, execute)
503mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt]
504mkUpdate pp var exp =
505 mkExp
506 ( pp
507 { ppInnerBlock =
508 (\ blk rhs -> do
509 pos <- setVariable var
510 vExp <- Nothing <>@! var
511 ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp
512 )
513 }
514 ) exp
516mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt]
517mkLet pp var@(Loc pos) newExp inExp =
518 mkUpdate (pp { ppInnerBlock =
519 (\ blk _ -> do
520 inBlk <- mkExp pp inExp
521 return (blk ++ inBlk)
522 )
523 }
524 ) var newExp
525mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
527-----------------------------------------------------------------------
528-- Object creation
530mkIdrisObject :: Int -> [LVar] -> CodeGeneration Exp
531mkIdrisObject conId args =
532 (\ args ->
533 InstanceCreation [] (toClassType idrisObjectType) ((jInt conId):args) Nothing
534 )
535 <$> mapM (Nothing <>@!) args
537-----------------------------------------------------------------------
538-- Case expressions
540mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt]
541mkCase pp checked var cases
542 | isDefaultOnlyCase cases = mkDefaultMatch pp cases
543 | isConstCase cases = do
544 ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
545 ppOuterBlock pp [BlockStmt ifte]
546 | otherwise = do
547 switchExp <- mkGetConstructorId checked var
548 matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
549 ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks]
551isConstCase :: [SAlt] -> Bool
552isConstCase ((SConstCase _ _):_) = True
553isConstCase ((SDefaultCase _):cases) = isConstCase cases
554isConstCase _ = False
556isDefaultOnlyCase :: [SAlt] -> Bool
557isDefaultOnlyCase [SDefaultCase _] = True
558isDefaultOnlyCase [] = True
559isDefaultOnlyCase _ = False
561mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt]
562mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) =
563 do pushScope
564 stmt <- mkExp pp branchExpression
565 popScope
566 return stmt
567mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs
568mkDefaultMatch pp [] =
569 ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern")
571mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp
572mkMatchConstExp var c
573 | isPrimitive cty =
574 (\ var -> (primFnType ~> opName (LEq undefined)) [var, jc] ~==~ jInt 1)
575 <$> (Just cty <>@! var)
576 | isArray cty =
577 (\ var -> (arraysType ~> "equals") [var, jc])
578 <$> (Just cty <>@! var)
579 | isString cty =
580 (\ var -> ((primFnType ~> opName (LStrEq)) [var, jc] ~==~ jInt 1))
581 <$> (Just cty <>@! var)
582 | otherwise =
583 (\ var -> (var ~> "equals") [jc])
584 <$> (Just cty <>@! var)
585 where
586 cty = constType c
587 jc = mkConstant c
589mkConstMatch :: BlockPostprocessor ->
590 (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
591 LVar ->
592 [SAlt] ->
593 CodeGeneration Stmt
594mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do
595 matchExp <- mkMatchConstExp var constant
596 pushScope
597 branchBlock <- mkExp pp branchExpression
598 popScope
599 otherBranches <- mkConstMatch pp getDefaultStmts var cases
600 return
601 $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches
602mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases
603mkConstMatch pp getDefaultStmts _ [] = do
604 defaultBlock <- getDefaultStmts pp
605 return $ StmtBlock (Block defaultBlock)
607mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp
608mkGetConstructorId True var =
609 (\ var -> ((idrisObjectType <> var) ~> "getConstructorId") [])
610 <$> (Nothing <>@! var)
611mkGetConstructorId False var =
612 (\ var match ->
613 Cond (InstanceOf var (toRefType idrisObjectType)) match (jInt (-1))
614 )
615 <$> (Nothing <>@! var)
616 <*> mkGetConstructorId True var
618mkConsMatch :: BlockPostprocessor ->
619 (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
620 LVar ->
621 [SAlt] ->
622 CodeGeneration [SwitchBlock]
623mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do
624 pushScope
625 caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression
626 popScope
627 otherBranches <- mkConsMatch pp getDefaultStmts var cases
628 return $
629 (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches
630mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases
631mkConsMatch pp getDefaultStmts _ [] = do
632 defaultBlock <- getDefaultStmts pp
633 return $
634 [SwitchBlock Default defaultBlock]
636mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt]
637mkCaseBinding pp var stackStart params branchExpression =
638 mkExp pp (toLetIn var stackStart params branchExpression)
639 where
640 toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp
641 toLetIn var stackStart members start =
642 foldr
643 (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp)
644 start
645 [0.. (length members - 1)]
647-----------------------------------------------------------------------
648-- Projection (retrieve the n-th field of an object)
650mkProjection :: LVar -> Int -> CodeGeneration Exp
651mkProjection var memberNr =
652 (\ var -> ArrayAccess $ ((var ~> "getData") []) @! memberNr)
653 <$> (Just idrisObjectType <>@! var)
655-----------------------------------------------------------------------
656-- Constants
658mkConstantArray :: (V.Unbox a) => J.Type -> (a -> Const) -> V.Vector a -> Exp
659mkConstantArray cty elemToConst elems =
660 ArrayCreateInit
661 cty
662 0
663 (ArrayInit . map (InitExp . mkConstant . elemToConst) $ V.toList elems)
665mkConstant :: Const -> Exp
666mkConstant c@(I x) = constType c <> (Lit . Word $ toInteger x)
667mkConstant c@(BI x) = bigInteger (show x)
668mkConstant c@(Fl x) = constType c <> (Lit . Double $ x)
669mkConstant c@(Ch x) = constType c <> (Lit . Char $ x)
670mkConstant c@(Str x) = constType c <> (Lit . String $ x)
671mkConstant c@(B8 x) = constType c <> (Lit . Word $ toInteger x)
672mkConstant c@(B16 x) = constType c <> (Lit . Word $ toInteger x)
673mkConstant c@(B32 x) = constType c <> (Lit . Word $ toInteger x)
674mkConstant c@(B64 x) = (bigInteger (show c) ~> "longValue") []
675mkConstant c@(B8V x) = mkConstantArray (constType c) B8 x
676mkConstant c@(B16V x) = mkConstantArray (constType c) B16 x
677mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x
678mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x
679mkConstant c@(AType x) = ClassLit (Just $ box (constType c))
680mkConstant c@(StrType ) = ClassLit (Just $ stringType)
681mkConstant c@(PtrType ) = ClassLit (Just $ objectType)
682mkConstant c@(VoidType ) = ClassLit (Just $ voidType)
683mkConstant c@(Forgot ) = ClassLit (Just $ objectType)
685-----------------------------------------------------------------------
686-- Foreign function calls
688mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt]
689mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params
690mkForeign pp (LANG_JAVA callType) resTy text params
691 | callType <- FStatic = do
692 method <- liftParsed (parser name text)
693 args <- foreignVarAccess params
694 wrapReturn resTy (call method args)
695 | callType <- FObject = do
696 method <- liftParsed (parser ident text)
697 (tgt:args) <- foreignVarAccess params
698 wrapReturn resTy ((tgt ~> (show $ pretty method)) args)
699 | callType <- FConstructor = do
700 clsTy <- liftParsed (parser classType text)
701 args <- foreignVarAccess params
702 wrapReturn resTy (InstanceCreation [] clsTy args Nothing)
703 where
704 foreignVarAccess args =
705 mapM (\ (fty, var) -> (foreignType fty <>@! var)) args
707 pp' = rethrowAsRuntimeException pp
709 wrapReturn FUnit exp =
710 ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp'
711 wrapReturn _ exp =
712 ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp'
714-----------------------------------------------------------------------
715-- Primitive functions
717mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp
718mkPrimitiveFunction op args =
719 (\ args -> (primFnType ~> opName op) args)
720 <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op))
722mkThread :: LVar -> CodeGeneration Exp
723mkThread arg =
724 (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (MN 0 "EVAL") [arg]