diff options
Diffstat (limited to 'codegen.hs')
| -rw-r--r-- | codegen.hs | 44 |
1 files changed, 31 insertions, 13 deletions
@@ -84,15 +84,28 @@ newBlockJump next = do changeBlock :: LLName -> CGMonad () changeBlock name = state $ \s -> ((), s {currentBlock = Just name}) +instrReturnsVoid :: A.Instruction -> Bool +instrReturnsVoid (A.Store {}) = True +instrReturnsVoid (A.Call _ _ _ (Right oper) _ _ _) = case oper of + (A.LocalReference (A.FunctionType A.VoidType _ _) _) -> True + (A.ConstantOperand (A.C.GlobalReference (A.FunctionType A.VoidType _ _) _)) -> True + _ -> False +instrReturnsVoid _ = False + addInstr :: A.Instruction -> CGMonad LLName -addInstr instr = do - name <- getNewName "t" - addNamedInstr $ A.Name name A.:= instr +addInstr instr + | instrReturnsVoid instr = addNamedInstr $ A.Do instr + | otherwise = do + name <- getNewName "t" + addNamedInstr $ A.Name name A.:= instr addNamedInstr :: A.Named A.Instruction -> CGMonad LLName addNamedInstr instr@(A.Name name A.:= _) = do let append (A.BasicBlock n il t) = A.BasicBlock n (il ++ [instr]) t state $ \s -> (name, s {allBlocks = Map.adjust append (fromJust (currentBlock s)) (allBlocks s)}) +addNamedInstr instr@(A.Do _) = do + let append (A.BasicBlock n il t) = A.BasicBlock n (il ++ [instr]) t + state $ \s -> ("", s {allBlocks = Map.adjust append (fromJust (currentBlock s)) (allBlocks s)}) addNamedInstr _ = undefined -- addNamedInstrList :: [A.Named A.Instruction] -> CGMonad LLName @@ -135,10 +148,11 @@ lookupGlobalVar name = liftM (fromJust . Map.lookup name . globalVariables) get lookupGlobalFunction :: Name -> CGMonad (Type, LLName) lookupGlobalFunction name = liftM (fromJust . Map.lookup name . globalFunctions) get -addStringLiteral :: String -> CGMonad LLName +addStringLiteral :: String -> CGMonad (A.Type, LLName) addStringLiteral str = do name <- getNewName "str" - state $ \s -> (name, s {stringLiterals = (name, str) : stringLiterals s}) + state $ \s -> ((A.ptr $ A.ArrayType (fromIntegral (length str + 1)) A.i8, name), + s {stringLiterals = (name, str) : stringLiterals s}) variableStoreOperand :: Name -> CGMonad A.Operand variableStoreOperand name = get >>= (maybe getGlobal getLocal . Map.lookup name . variables) @@ -241,7 +255,7 @@ genStringLiterals = liftM stringLiterals get >>= return . map gen A.G.name = A.Name name, A.G.linkage = A.L.Private, A.G.isConstant = True, - A.G.type' = A.ptr (A.i8), + A.G.type' = A.ArrayType (fromIntegral (length str + 1)) A.i8, A.G.initializer = Just $ A.C.Array A.i8 $ [A.C.Int 8 (fromIntegral (ord c)) | c <- str] ++ [A.C.Int 8 0] } @@ -256,7 +270,7 @@ genFunctions (Program decs) = liftM (mapMaybe id) $ mapM gen decs variables = Map.empty }) firstbb <- genFunctionBlock body (rettype, name) args - cleanupTrampolines + cleanupTrampolines firstbb blockmap <- liftM allBlocks get let bbs' = map snd $ filter (\x -> fst x /= firstbb) $ Map.toList blockmap bbs = fromJust (Map.lookup firstbb blockmap) : bbs' @@ -531,8 +545,12 @@ literalToOperand (LitVar n) t = do oper' <- castOperand oper t return oper' literalToOperand (LitString s) (TypePtr (TypeInt 8)) = do - name <- addStringLiteral s - return $ A.ConstantOperand $ A.C.GlobalReference (A.ptr A.i8) (A.Name name) + (ty, name) <- addStringLiteral s + label <- addInstr $ A.GetElementPtr True (A.ConstantOperand $ A.C.GlobalReference ty (A.Name name)) + [A.ConstantOperand $ A.C.Int 64 0, + A.ConstantOperand $ A.C.Int 32 0] + [] + return $ A.LocalReference (A.ptr A.i8) (A.Name label) literalToOperand (LitString _) _ = undefined literalToOperand (LitCall n args) _ = do ((TypeFunc rt ats), lname) <- lookupGlobalFunction n @@ -627,8 +645,8 @@ commonTypeM t1 t2 = maybe err return $ commonType t1 t2 where err = throwError $ "Cannot implicitly find common type of '" ++ pshow t1 ++ "' and '" ++ pshow t2 ++ "'" -cleanupTrampolines :: CGMonad () -cleanupTrampolines = do +cleanupTrampolines :: LLName -> CGMonad () +cleanupTrampolines toskip = do state $ \s -> ((), s {allBlocks = go (allBlocks s)}) where go :: Map.Map LLName A.BasicBlock -> Map.Map LLName A.BasicBlock @@ -638,8 +656,8 @@ cleanupTrampolines = do folder whole [] = whole folder whole ((name, (A.BasicBlock (A.Name name2) [] (A.Do (A.Br (A.Name dst) [])))) : _) | name /= name2 = error "INTERNAL ERROR: name /= name2" - | otherwise = let res = eliminate name dst $ Map.delete name whole - in folder res (Map.toList res) + | name /= toskip = let res = eliminate name dst $ Map.delete name whole + in folder res (Map.toList res) folder whole (_:rest) = folder whole rest eliminate :: LLName -> LLName -> Map.Map LLName A.BasicBlock -> Map.Map LLName A.BasicBlock |