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