{-# LANGUAGE PatternGuards #-} module IRTS.CodegenJava (codegenJava) where import Idris.Core.TT hiding (mkApp) import IRTS.CodegenCommon import IRTS.Java.ASTBuilding import IRTS.Java.JTypes import IRTS.Java.Mangling import IRTS.Java.Pom (pomString) import IRTS.Lang import IRTS.Simplified import IRTS.System import Util.System import Control.Applicative hiding (Const) import Control.Arrow import Control.Monad import Control.Monad.Error import qualified Control.Monad.Trans as T import Control.Monad.Trans.State import Data.List (foldl', isSuffixOf) import qualified Data.Text as T import qualified Data.Text.IO as TIO import qualified Data.Vector.Unboxed as V import Language.Java.Parser import Language.Java.Pretty import Language.Java.Syntax hiding (Name) import qualified Language.Java.Syntax as J import System.Directory import System.Exit import System.FilePath import System.IO import System.Process ----------------------------------------------------------------------- -- Main function codegenJava :: CodeGenerator codegenJava cg = codegenJava' [] (simpleDecls cg) (outputFile cg) (includes cg) (compileLibs cg) (outputType cg) codegenJava' :: [(Name, SExp)] -> -- initialization of globals [(Name, SDecl)] -> -- decls FilePath -> -- output file name [String] -> -- headers [String] -> -- libs OutputType -> IO () codegenJava' globalInit defs out hdrs libs exec = withTgtDir exec out (codegenJava' exec) where codegenJava' :: OutputType -> FilePath -> IO () codegenJava' Raw tgtDir = do srcDir <- prepareSrcDir exec tgtDir generateJavaFile globalInit defs hdrs srcDir out codegenJava' MavenProject tgtDir = do codegenJava' Raw tgtDir generatePom tgtDir out libs codegenJava' Object tgtDir = do codegenJava' MavenProject tgtDir invokeMvn tgtDir "compile" copyClassFiles tgtDir out cleanUpTmp tgtDir codegenJava' _ tgtDir = do codegenJava' MavenProject tgtDir invokeMvn tgtDir "package"; copyJar tgtDir out makeJarExecutable out cleanUpTmp tgtDir ----------------------------------------------------------------------- -- Compiler IO withTgtDir :: OutputType -> FilePath -> (FilePath -> IO ()) -> IO () withTgtDir Raw out action = action (dropFileName out) withTgtDir MavenProject out action = createDirectoryIfMissing False out >> action out withTgtDir _ out action = withTempdir (takeBaseName out) action prepareSrcDir :: OutputType -> FilePath -> IO FilePath prepareSrcDir Raw tgtDir = return tgtDir prepareSrcDir _ tgtDir = do let srcDir = (tgtDir "src" "main" "java") createDirectoryIfMissing True srcDir return srcDir javaFileName :: FilePath -> FilePath -> FilePath javaFileName srcDir out = either error (\ (Ident clsName) -> srcDir clsName <.> "java") (mkClassName out) generateJavaFile :: [(Name, SExp)] -> -- initialization of globals [(Name, SDecl)] -> -- definitions [String] -> -- headers FilePath -> -- Source dir FilePath -> -- output target IO () generateJavaFile globalInit defs hdrs srcDir out = do let code = either error (prettyPrint)-- flatIndent . prettyPrint) (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv) writeFile (javaFileName srcDir out) code pomFileName :: FilePath -> FilePath pomFileName tgtDir = tgtDir "pom.xml" generatePom :: FilePath -> -- tgt dir FilePath -> -- output target [String] -> -- libs IO () generatePom tgtDir out libs = writeFile (pomFileName tgtDir) execPom where (Ident clsName) = either error id (mkClassName out) execPom = pomString clsName (takeBaseName out) libs invokeMvn :: FilePath -> String -> IO () invokeMvn tgtDir command = do mvnCmd <- getMvn let args = ["-f", pomFileName tgtDir] (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ [command]) "" when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " " ++ command ++ "\n" ++ err ++ mvout) classFileDir :: FilePath -> FilePath classFileDir tgtDir = tgtDir "target" "classes" copyClassFiles :: FilePath -> FilePath -> IO () copyClassFiles tgtDir out = do classFiles <- map (\ clsFile -> classFileDir tgtDir clsFile) . filter ((".class" ==) . takeExtension) <$> getDirectoryContents (classFileDir tgtDir) mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out takeFileName clsFile)) classFiles jarFileName :: FilePath -> FilePath -> FilePath jarFileName tgtDir out = tgtDir "target" (takeBaseName out) <.> "jar" copyJar :: FilePath -> FilePath -> IO () copyJar tgtDir out = copyFile (jarFileName tgtDir out) out makeJarExecutable :: FilePath -> IO () makeJarExecutable out = do handle <- openBinaryFile out ReadMode contents <- TIO.hGetContents handle hClose handle handle <- openBinaryFile out WriteMode TIO.hPutStr handle (T.append (T.pack jarHeader) contents) hFlush handle hClose handle perms <- getPermissions out setPermissions out (setOwnerExecutable True perms) removePom :: FilePath -> IO () removePom tgtDir = removeFile (pomFileName tgtDir) cleanUpTmp :: FilePath -> IO () cleanUpTmp tgtDir = do invokeMvn tgtDir "clean" removePom tgtDir ----------------------------------------------------------------------- -- Jar and Pom infrastructure jarHeader :: String jarHeader = "#!/usr/bin/env sh\n" ++ "MYSELF=`which \"$0\" 2>/dev/null`\n" ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n" ++ "java=java\n" ++ "if test -n \"$JAVA_HOME\"; then\n" ++ " java=\"$JAVA_HOME/bin/java\"\n" ++ "fi\n" ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\"" ++ "exit 1\n" ----------------------------------------------------------------------- -- Code generation environment data CodeGenerationEnv = CodeGenerationEnv { globalVariables :: [(Name, ArrayIndex)] , localVariables :: [[(Int, Ident)]] , localVarCounter :: Int } type CodeGeneration = StateT (CodeGenerationEnv) (Either String) mkCodeGenEnv :: CodeGenerationEnv mkCodeGenEnv = CodeGenerationEnv [] [] 0 varPos :: LVar -> CodeGeneration (Either ArrayIndex Ident) varPos (Loc i) = do vars <- (concat . localVariables) <$> get case lookup i vars of (Just varName) -> return (Right varName) Nothing -> throwError $ "Invalid local variable id: " ++ show i varPos (Glob name) = do vars <- globalVariables <$> get case lookup name vars of (Just varIdx) -> return (Left varIdx) Nothing -> throwError $ "Invalid global variable id: " ++ show name pushScope :: CodeGeneration () pushScope = modify (\ env -> env { localVariables = []:(localVariables env) }) popScope :: CodeGeneration () popScope = do env <- get let lVars = tail $ localVariables env let vC = if null lVars then 0 else localVarCounter env put $ env { localVariables = tail (localVariables env) , localVarCounter = vC } setVariable :: LVar -> CodeGeneration (Either ArrayIndex Ident) setVariable (Loc i) = do env <- get let lVars = localVariables env let getter = localVar $ localVarCounter env let lVars' = ((i, getter) : head lVars) : tail lVars put $ env { localVariables = lVars' , localVarCounter = 1 + localVarCounter env} return (Right getter) setVariable (Glob n) = do env <- get let gVars = globalVariables env let getter = globalContext @! length gVars let gVars' = (n, getter):gVars put (env { globalVariables = gVars' }) return (Left getter) pushParams :: [Ident] -> CodeGeneration () pushParams paramNames = let varMap = zipWith (flip (,)) paramNames [0..] in modify (\ env -> env { localVariables = varMap:(localVariables env) , localVarCounter = (length varMap) + (localVarCounter env) }) flatIndent :: String -> String flatIndent (' ' : ' ' : xs) = flatIndent xs flatIndent (x:xs) = x:flatIndent xs flatIndent [] = [] ----------------------------------------------------------------------- -- Maintaining control structures over code blocks data BlockPostprocessor = BlockPostprocessor { ppInnerBlock :: [BlockStmt] -> Exp -> CodeGeneration [BlockStmt] , ppOuterBlock :: [BlockStmt] -> CodeGeneration [BlockStmt] } ppExp :: BlockPostprocessor -> Exp -> CodeGeneration [BlockStmt] ppExp pp exp = ((ppInnerBlock pp) [] exp) >>= ppOuterBlock pp addReturn :: BlockPostprocessor addReturn = BlockPostprocessor { ppInnerBlock = (\ block exp -> return $ block ++ [jReturn exp]) , ppOuterBlock = return } ignoreResult :: BlockPostprocessor ignoreResult = BlockPostprocessor { ppInnerBlock = (\ block exp -> return block) , ppOuterBlock = return } ignoreOuter :: BlockPostprocessor -> BlockPostprocessor ignoreOuter pp = pp { ppOuterBlock = return } throwRuntimeException :: BlockPostprocessor -> BlockPostprocessor throwRuntimeException pp = pp { ppInnerBlock = (\ blk exp -> return $ blk ++ [ BlockStmt $ Throw ( InstanceCreation [] (toClassType runtimeExceptionType) [exp] Nothing ) ] ) } rethrowAsRuntimeException :: BlockPostprocessor -> BlockPostprocessor rethrowAsRuntimeException pp = pp { ppOuterBlock = (\ blk -> do ex <- ppInnerBlock (throwRuntimeException pp) [] (ExpName $ J.Name [Ident "ex"]) ppOuterBlock pp $ [ BlockStmt $ Try (Block blk) [Catch (FormalParam [] exceptionType False (VarId (Ident "ex"))) $ Block ex ] Nothing ] ) } ----------------------------------------------------------------------- -- File structure mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit mkCompilationUnit globalInit defs hdrs out = do clsName <- mkClassName out CompilationUnit Nothing ( [ ImportDecl False idrisRts True , ImportDecl True idrisPrelude True , ImportDecl False bigInteger False , ImportDecl False runtimeException False ] ++ otherHdrs ) <$> mkTypeDecl clsName globalInit defs where idrisRts = J.Name $ map Ident ["org", "idris", "rts"] idrisPrelude = J.Name $ map Ident ["org", "idris", "rts", "Prelude"] bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"] runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"] otherHdrs = map ( (\ name -> ImportDecl False name False) . J.Name . map (Ident . T.unpack) . T.splitOn (T.pack ".") . T.pack) $ filter (not . isSuffixOf ".h") hdrs ----------------------------------------------------------------------- -- Main class mkTypeDecl :: Ident -> [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration [TypeDecl] mkTypeDecl name globalInit defs = (\ body -> [ClassTypeDecl $ ClassDecl [ Public , Annotation $ SingleElementAnnotation (jName "SuppressWarnings") (EVVal . InitExp $ jString "unchecked") ] name [] Nothing [] body]) <$> mkClassBody globalInit (map (second (prefixCallNamespaces name)) defs) mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody mkClassBody globalInit defs = (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs) <$> mkGlobalContext globalInit <*> mapM mkDecl defs mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl] mkGlobalContext [] = return [] mkGlobalContext initExps = do pushScope varInit <- mapM (\ (name, exp) -> do pos <- setVariable (Glob name) mkUpdate ignoreResult (Glob name) exp ) initExps popScope return [ MemberDecl $ FieldDecl [Private, Static, Final] (array objectType) [ VarDecl (VarId $ globalContextID). Just . InitExp $ ArrayCreate objectType [jInt $ length initExps] 0 ] , InitDecl True (Block $ concat varInit) ] addMainMethod :: [Decl] -> [Decl] addMainMethod decls | findMainMethod decls = mkMainMethod : decls | otherwise = decls where findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_) | name == mangle' (sMN 0 "runMain") = True findMainMethod (_:decls) = findMainMethod decls findMainMethod [] = False mkMainMethod :: Decl mkMainMethod = simpleMethod [Public, Static] Nothing "main" [FormalParam [] (array stringType) False (VarId $ Ident "args")] $ Block [ BlockStmt . ExpStmt $ call "idris_initArgs" [ (threadType ~> "currentThread") [] , jConst "args" ] , BlockStmt . ExpStmt $ call (mangle' (sMN 0 "runMain")) [] ] ----------------------------------------------------------------------- -- Inner classes (idris namespaces) mergeInnerClasses :: [Decl] -> [Decl] mergeInnerClasses = foldl' mergeInner [] where mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls) decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body')))) | name == name' = (MemberDecl $ MemberClassDecl $ ClassDecl priv name targs (mplus ext ext') (imp ++ imp') (ClassBody $ mergeInnerClasses (body ++ body'))) : decls | otherwise = decl:(mergeInner decls decl') mergeInner (decl:decls) decl' = decl:(mergeInner decls decl') mergeInner [] decl' = [decl'] mkDecl :: (Name, SDecl) -> CodeGeneration Decl mkDecl ((NS n (ns:nss)), decl) = (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body) <$> mangle (UN ns) <*> mkClassBody [] [(NS n nss, decl)] mkDecl (_, SFun name params stackSize body) = do (Ident methodName) <- mangle name methodParams <- mapM mkFormalParam params paramNames <- mapM mangle params pushParams paramNames methodBody <- mkExp addReturn body popScope return $ simpleMethod [Public, Static] (Just objectType) methodName methodParams (Block methodBody) mkFormalParam :: Name -> CodeGeneration FormalParam mkFormalParam name = (\ name -> FormalParam [Final] objectType False (VarId name)) <$> mangle name ----------------------------------------------------------------------- -- Expressions -- | Compile a simple expression and use the given continuation to postprocess -- the resulting value. mkExp :: BlockPostprocessor -> SExp -> CodeGeneration [BlockStmt] -- Variables mkExp pp (SV var) = (Nothing <>@! var) >>= ppExp pp -- Applications mkExp pp (SApp pushTail name args) = mkApp pushTail name args >>= ppExp pp -- Bindings mkExp pp (SLet var newExp inExp) = mkLet pp var newExp inExp mkExp pp (SUpdate var@(Loc i) newExp) = -- can only update locals mkUpdate pp var newExp mkExp pp (SUpdate var newExp) = mkExp pp newExp -- Objects mkExp pp (SCon conId _ args) = mkIdrisObject conId args >>= ppExp pp -- Case expressions mkExp pp (SCase var alts) = mkCase pp True var alts mkExp pp (SChkCase var alts) = mkCase pp False var alts -- Projections mkExp pp (SProj var i) = mkProjection var i >>= ppExp pp -- Constants mkExp pp (SConst c) = ppExp pp $ mkConstant c -- Foreign function calls mkExp pp (SForeign lang resTy text params) = mkForeign pp lang resTy text params -- Primitive functions mkExp pp (SOp LFork [arg]) = (mkThread arg) >>= ppExp pp mkExp pp (SOp LPar [arg]) = (Nothing <>@! arg) >>= ppExp pp mkExp pp (SOp LNoOp args) = (Nothing <>@! (last args)) >>= ppExp pp mkExp pp (SOp LNullPtr args) = ppExp pp $ Lit Null mkExp pp (SOp op args) = (mkPrimitiveFunction op args) >>= ppExp pp -- Empty expressions mkExp pp (SNothing) = ppExp pp $ Lit Null -- Errors mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err) ----------------------------------------------------------------------- -- Variable access (<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp (<>@!) Nothing var = either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var (<>@!) (Just castTo) var = (castTo <>) <$> (Nothing <>@! var) ----------------------------------------------------------------------- -- Application (wrap method calls in tail call closures) mkApp :: Bool -> Name -> [LVar] -> CodeGeneration Exp mkApp False name args = (\ methodName params -> (idrisClosureType ~> "unwrapTailCall") [call methodName params] ) <$> mangleFull name <*> mapM (Nothing <>@!) args mkApp True name args = mkMethodCallClosure name args mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp mkMethodCallClosure name args = (\ name args -> closure (call name args)) <$> mangleFull name <*> mapM (Nothing <>@!) args ----------------------------------------------------------------------- -- Updates (change context array) and Let bindings (Update, execute) mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt] mkUpdate pp var exp = mkExp ( pp { ppInnerBlock = (\ blk rhs -> do pos <- setVariable var vExp <- Nothing <>@! var ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp ) } ) exp mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt] mkLet pp var@(Loc pos) newExp inExp = mkUpdate (pp { ppInnerBlock = (\ blk _ -> do inBlk <- mkExp pp inExp return (blk ++ inBlk) ) } ) var newExp mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable" ----------------------------------------------------------------------- -- Object creation mkIdrisObject :: Int -> [LVar] -> CodeGeneration Exp mkIdrisObject conId args = (\ args -> InstanceCreation [] (toClassType idrisObjectType) ((jInt conId):args) Nothing ) <$> mapM (Nothing <>@!) args ----------------------------------------------------------------------- -- Case expressions mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt] mkCase pp checked var cases | isDefaultOnlyCase cases = mkDefaultMatch pp cases | isConstCase cases = do ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases ppOuterBlock pp [BlockStmt ifte] | otherwise = do switchExp <- mkGetConstructorId checked var matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks] isConstCase :: [SAlt] -> Bool isConstCase ((SConstCase _ _):_) = True isConstCase ((SDefaultCase _):cases) = isConstCase cases isConstCase _ = False isDefaultOnlyCase :: [SAlt] -> Bool isDefaultOnlyCase [SDefaultCase _] = True isDefaultOnlyCase [] = True isDefaultOnlyCase _ = False mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt] mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) = do pushScope stmt <- mkExp pp branchExpression popScope return stmt mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs mkDefaultMatch pp [] = ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern") mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp mkMatchConstExp var c | isPrimitive cty = (\ var -> (primFnType ~> opName (LEq undefined)) [var, jc] ~==~ jInt 1) <$> (Just cty <>@! var) | isArray cty = (\ var -> (arraysType ~> "equals") [var, jc]) <$> (Just cty <>@! var) | isString cty = (\ var -> ((primFnType ~> opName (LStrEq)) [var, jc] ~==~ jInt 1)) <$> (Just cty <>@! var) | otherwise = (\ var -> (var ~> "equals") [jc]) <$> (Just cty <>@! var) where cty = constType c jc = mkConstant c mkConstMatch :: BlockPostprocessor -> (BlockPostprocessor -> CodeGeneration [BlockStmt]) -> LVar -> [SAlt] -> CodeGeneration Stmt mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do matchExp <- mkMatchConstExp var constant pushScope branchBlock <- mkExp pp branchExpression popScope otherBranches <- mkConstMatch pp getDefaultStmts var cases return $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases mkConstMatch pp getDefaultStmts _ [] = do defaultBlock <- getDefaultStmts pp return $ StmtBlock (Block defaultBlock) mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp mkGetConstructorId True var = (\ var -> ((idrisObjectType <> var) ~> "getConstructorId") []) <$> (Nothing <>@! var) mkGetConstructorId False var = (\ var match -> Cond (InstanceOf var (toRefType idrisObjectType)) match (jInt (-1)) ) <$> (Nothing <>@! var) <*> mkGetConstructorId True var mkConsMatch :: BlockPostprocessor -> (BlockPostprocessor -> CodeGeneration [BlockStmt]) -> LVar -> [SAlt] -> CodeGeneration [SwitchBlock] mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do pushScope caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression popScope otherBranches <- mkConsMatch pp getDefaultStmts var cases return $ (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases mkConsMatch pp getDefaultStmts _ [] = do defaultBlock <- getDefaultStmts pp return $ [SwitchBlock Default defaultBlock] mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt] mkCaseBinding pp var stackStart params branchExpression = mkExp pp (toLetIn var stackStart params branchExpression) where toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp toLetIn var stackStart members start = foldr (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp) start [0.. (length members - 1)] ----------------------------------------------------------------------- -- Projection (retrieve the n-th field of an object) mkProjection :: LVar -> Int -> CodeGeneration Exp mkProjection var memberNr = (\ var -> ArrayAccess $ ((var ~> "getData") []) @! memberNr) <$> (Just idrisObjectType <>@! var) ----------------------------------------------------------------------- -- Constants mkConstantArray :: (V.Unbox a) => J.Type -> (a -> Const) -> V.Vector a -> Exp mkConstantArray cty elemToConst elems = ArrayCreateInit cty 0 (ArrayInit . map (InitExp . mkConstant . elemToConst) $ V.toList elems) mkConstant :: Const -> Exp mkConstant c@(I x) = constType c <> (Lit . Word $ toInteger x) mkConstant c@(BI x) = bigInteger (show x) mkConstant c@(Fl x) = constType c <> (Lit . Double $ x) mkConstant c@(Ch x) = constType c <> (Lit . Char $ x) mkConstant c@(Str x) = constType c <> (Lit . String $ x) mkConstant c@(B8 x) = constType c <> (Lit . Word $ toInteger x) mkConstant c@(B16 x) = constType c <> (Lit . Word $ toInteger x) mkConstant c@(B32 x) = constType c <> (Lit . Word $ toInteger x) mkConstant c@(B64 x) = (bigInteger (show c) ~> "longValue") [] mkConstant c@(B8V x) = mkConstantArray (constType c) B8 x mkConstant c@(B16V x) = mkConstantArray (constType c) B16 x mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x mkConstant c@(AType x) = ClassLit (Just $ box (constType c)) mkConstant c@(StrType ) = ClassLit (Just $ stringType) mkConstant c@(PtrType ) = ClassLit (Just $ objectType) mkConstant c@(ManagedPtrType) = ClassLit (Just $ objectType) mkConstant c@(VoidType ) = ClassLit (Just $ voidType) mkConstant c@(Forgot ) = ClassLit (Just $ objectType) ----------------------------------------------------------------------- -- Foreign function calls mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt] mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params mkForeign pp (LANG_JAVA callType) resTy text params | callType <- FStatic = do method <- liftParsed (parser name text) args <- foreignVarAccess params wrapReturn resTy (call method args) | callType <- FObject = do method <- liftParsed (parser ident text) (tgt:args) <- foreignVarAccess params wrapReturn resTy ((tgt ~> (show $ pretty method)) args) | callType <- FConstructor = do clsTy <- liftParsed (parser classType text) args <- foreignVarAccess params wrapReturn resTy (InstanceCreation [] clsTy args Nothing) where foreignVarAccess args = mapM (\ (fty, var) -> (foreignType fty <>@! var)) args pp' = rethrowAsRuntimeException pp wrapReturn FUnit exp = ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp' wrapReturn _ exp = ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp' ----------------------------------------------------------------------- -- Primitive functions mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp mkPrimitiveFunction op args = (\ args -> (primFnType ~> opName op) args) <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op)) mkThread :: LVar -> CodeGeneration Exp mkThread arg = (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (sMN 0 "EVAL") [arg]