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