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