diff options
Diffstat (limited to 'BuildIR.hs')
| -rw-r--r-- | BuildIR.hs | 367 |
1 files changed, 367 insertions, 0 deletions
diff --git a/BuildIR.hs b/BuildIR.hs new file mode 100644 index 0000000..28cbf5e --- /dev/null +++ b/BuildIR.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-} + +module BuildIR(buildIR) where + +import Control.Monad.Except +import Control.Monad.State.Strict +import Data.Char +import Data.List +import qualified Data.Map.Strict as Map +import Data.Maybe + +import AST +import Defs +import Intermediate +import Pretty +import TypeRules + + +type Scope = Map.Map Name (Ref, Type) + +data BuildState = BuildState + { nextId :: Id, + scopeStack :: [Scope], + currentBlock :: Id, + blockMap :: Map.Map Id BB } + +initBuildState :: BuildState +initBuildState = BuildState + { nextId = 0, + scopeStack = [], + currentBlock = undefined, + blockMap = Map.empty } + +newtype BuildM a = BuildM {unBuildM :: StateT BuildState (Except String) a} + deriving (Functor, Applicative, Monad, MonadState BuildState, MonadError String) + +genId :: BuildM Id +genId = state $ \s -> (nextId s, s {nextId = nextId s + 1}) + +genTemp :: Size -> BuildM Ref +genTemp sz = liftM (Temp sz) genId + +newBlock :: BuildM Id +newBlock = do + i <- genId + let block = BB i [] ITermNone + modify $ \s -> s {currentBlock = i, blockMap = Map.insert i block (blockMap s)} + return i + +newBlockNoSwitch :: BuildM Id +newBlockNoSwitch = do + i <- genId + let block = BB i [] ITermNone + modify $ \s -> s {blockMap = Map.insert i block (blockMap s)} + return i + +addIns :: IRIns -> BuildM () +addIns ins = + modify $ \s -> s { + blockMap = Map.adjust bbAddIns (currentBlock s) (blockMap s)} + where + bbAddIns :: BB -> BB + bbAddIns (BB bid inss term) = BB bid (inss ++ [ins]) term + +setTerm :: IRTerm -> BuildM () +setTerm term = + modify $ \s -> s { + blockMap = Map.adjust bbSetTerm (currentBlock s) (blockMap s)} + where + bbSetTerm :: BB -> BB + bbSetTerm (BB bid inss oldterm) = case oldterm of + ITermNone -> BB bid inss term + _ -> error "setTerm: oldterm /= ITermNone" + +clearBlockMap :: BuildM () +clearBlockMap = modify $ \s -> s {currentBlock = undefined, blockMap = Map.empty} + +getAllBlocks :: BuildM [BB] +getAllBlocks = liftM Map.elems (gets blockMap) + +switchBlock :: Id -> BuildM () +switchBlock bid = modify $ \s -> s {currentBlock = bid} + +withScope :: BuildM a -> BuildM a +withScope act = do + modify $ \s -> s {scopeStack = Map.empty : scopeStack s} + res <- act + modify $ \s -> s {scopeStack = tail (scopeStack s)} + return res + +modifyScope :: (Scope -> Scope) -> BuildM () +modifyScope f = + modify $ \s -> s {scopeStack = f (head (scopeStack s)) : tail (scopeStack s)} + +scopeInsert :: Name -> Ref -> Type -> BuildM () +scopeInsert n ref t = modifyScope $ Map.insert n (ref, t) + +findVar :: Name -> BuildM (Maybe (Int, (Ref, Type))) +findVar n = do + stk <- gets scopeStack + let results = map (Map.lookup n) stk + return $ fmap (\idx -> (idx, fromJust (results !! idx))) $ + findIndex isJust results + + +buildIR :: Program -> Error IRProgram +buildIR (Program vars funcs) = + runExcept $ evalStateT (unBuildM result) initBuildState + where + goDFunc :: DFunc -> BuildM IRFunc + goDFunc (DFunc rt n al bl) = do + clearBlockMap + firstid <- newBlock + lastid <- newBlockNoSwitch + withScope $ do + forM_ al $ \(at, an) -> scopeInsert an (Argument (sizeof at) an) at + convertBlock bl lastid + switchBlock lastid + setTerm IRet + bblist <- getAllBlocks + return $ IRFunc rt n al bblist firstid + + result :: BuildM IRProgram + result = do + withScope $ do + mapM_ (\(DVar t n _) -> scopeInsert n (Global (sizeof t) n) t) vars + IRProgram vars <$> mapM goDFunc funcs + +convertBlock :: Block -> Id -> BuildM () +convertBlock (Block sts) nextnext = do + withScope $ forM_ sts $ \st -> do + endid <- newBlockNoSwitch + convertStatement st endid + switchBlock endid + setTerm $ IJmp nextnext + +convertStatement :: Statement -> Id -> BuildM () +convertStatement (SDecl t n e) nextnext = do + endid <- newBlockNoSwitch + ref <- convertExpression e endid + varref <- genTemp (sizeof t) + scopeInsert n varref t + switchBlock endid + addIns $ IMov varref ref + setTerm $ IJmp nextnext +convertStatement (SAs ae e) nextnext = do + bl2 <- newBlockNoSwitch + eref <- convertExpression e bl2 + switchBlock bl2 + convertAsExpression ae eref nextnext +convertStatement (SIf c b1 b2) nextnext = do + cend <- newBlockNoSwitch + blThen <- newBlockNoSwitch + blElse <- newBlockNoSwitch + + cref <- convertExpression c cend + switchBlock cend + setTerm $ IJcc CNeq cref (Constant (refSize cref) 0) blThen blElse + switchBlock blThen + convertBlock b1 nextnext + switchBlock blElse + convertBlock b2 nextnext +convertStatement (SWhile c b) nextnext = do + cond <- newBlockNoSwitch + setTerm $ IJmp cond + cend <- newBlockNoSwitch + body <- newBlockNoSwitch + bodyend <- newBlockNoSwitch + + switchBlock cond + cref <- convertExpression c cend + switchBlock cend + setTerm $ IJcc CNeq cref (Constant (refSize cref) 0) body nextnext + switchBlock body + convertBlock b bodyend + switchBlock bodyend + setTerm $ IJmp cond +convertStatement (SReturn Nothing) _ = do + setTerm IRet +convertStatement (SReturn (Just e)) _ = do + bl <- newBlockNoSwitch + ref <- convertExpression e bl + switchBlock bl + setTerm $ IRetr ref +convertStatement (SExpr e) nextnext = do + void $ convertExpression e nextnext + +convertExpression :: Expression -> Id -> BuildM Ref +convertExpression (ELit (LInt n) _) nextnext = do + ref <- genTemp (sizeof TInt) + addIns $ IMov ref (Constant (sizeof TInt) (fromInteger n)) + setTerm $ IJmp nextnext + return ref +convertExpression (ELit (LChar c) _) nextnext = do + ref <- genTemp (sizeof TChar) + addIns $ IMov ref (Constant (sizeof TChar) (fromIntegral $ ord c)) + setTerm $ IJmp nextnext + return ref +convertExpression (ELit (LVar n) _) nextnext = do + mres <- findVar n + case mres of + Just (_, (r, t)) -> do + ref <- genTemp (sizeof t) + addIns $ IMov ref r + setTerm $ IJmp nextnext + return ref + Nothing -> throwError $ "Undefined variable '" ++ n ++ "' referenced" +convertExpression (ELit (LCall n al) mrt) nextnext = do + refs <- withScope $ forM al $ \arg -> do + endid <- newBlockNoSwitch + r <- convertExpression arg endid + switchBlock endid + return r + destref <- case mrt of + Nothing -> do + addIns $ ICall n refs + return $ Temp 0 (-1) + Just typ -> do + r <- genTemp (sizeof typ) + addIns $ ICallr r n refs + return r + setTerm $ IJmp nextnext + return destref +convertExpression (EBin BOAnd e1 e2 _) nextnext = do + destref <- genTemp (sizeof TInt) + bl2 <- newBlockNoSwitch + blTryR <- newBlockNoSwitch + bl3 <- newBlockNoSwitch + blNope <- newBlockNoSwitch + blYes <- newBlockNoSwitch + + ref1 <- convertExpression e1 bl2 + + switchBlock bl2 + setTerm $ IJcc CNeq ref1 (Constant (refSize ref1) 0) blTryR blNope + + switchBlock blTryR + ref2 <- convertExpression e2 bl3 + + switchBlock bl3 + setTerm $ IJcc CNeq ref2 (Constant (refSize ref2) 0) blYes blNope + + switchBlock blYes + addIns $ IMov destref (Constant (refSize destref) 1) + setTerm $ IJmp nextnext + + switchBlock blNope + addIns $ IMov destref (Constant (refSize destref) 0) + setTerm $ IJmp nextnext + + return destref +convertExpression (EBin bo e1 e2 _) nextnext = do + bl2 <- newBlockNoSwitch + ref1 <- convertExpression e1 bl2 + switchBlock bl2 + bl3 <- newBlockNoSwitch + ref2 <- convertExpression e2 bl3 + switchBlock bl3 + ref <- genTemp (sizeof $ fromJust $ retTypeBO bo (fromJust $ typeof e1) (fromJust $ typeof e2)) + case bo of + BOAdd -> addIns $ IAri AAdd ref1 ref2 + BOSub -> addIns $ IAri ASub ref1 ref2 + BOMul -> addIns $ IAri AMul ref1 ref2 + BODiv -> addIns $ IAri ADiv ref1 ref2 + BOMod -> addIns $ IAri AMod ref1 ref2 + BOEq -> addIns $ IAri AEq ref1 ref2 + BONeq -> addIns $ IAri ANeq ref1 ref2 + BOGt -> addIns $ IAri AGt ref1 ref2 + BOLt -> addIns $ IAri ALt ref1 ref2 + BOGeq -> addIns $ IAri AGeq ref1 ref2 + BOLeq -> addIns $ IAri ALeq ref1 ref2 + BOPow -> error $ "Pow operator not implemented" + BOAnd -> undefined + BOOr -> undefined + addIns $ IMov ref ref1 + setTerm $ IJmp nextnext + return ref +convertExpression (EUn UONot e mt) nextnext = + convertExpression (EBin BOEq e (ELit (LInt 0) (typeof e)) mt) nextnext +convertExpression (EUn UONeg e mt) nextnext = + convertExpression (EBin BOSub (ELit (LInt 0) (typeof e)) e mt) nextnext +convertExpression (ESubscript arr sub t) nextnext = do + let elemsz = sizeof $ fromJust t + bl2 <- newBlockNoSwitch + arrref <- convertExpression arr bl2 + switchBlock bl2 + bl3 <- newBlockNoSwitch + subref <- convertExpression sub bl3 + switchBlock bl3 + addIns $ IAri AMul subref (Constant (refSize subref) (fromIntegral elemsz)) + addIns $ IAri AAdd subref (Constant (refSize subref) (fromIntegral $ sizeof TInt)) + addIns $ IAri AAdd arrref subref + ref <- genTemp elemsz + addIns $ ILoad ref arrref + setTerm $ IJmp nextnext + return ref +convertExpression (ECast dt e) nextnext = do + let typ = case typeof e of + Nothing -> error $ "Cast subject " ++ show e ++ " has Nothing type" + Just t -> t + when (not $ isIntegralType typ && isIntegralType dt) $ + error $ "convertExpression: unimplemented cast from " ++ pretty typ ++ " to " ++ pretty dt + ref <- genTemp (sizeof dt) + bl <- newBlockNoSwitch + eref <- convertExpression e bl + switchBlock bl + addIns $ IResize ref eref + setTerm $ IJmp nextnext + return ref +convertExpression (ENew t sze) nextnext = do + when (not $ isBasicType t) $ + throwError $ "Array element type in 'new' expression is not a basic type (" ++ pretty t ++ ")" + bl2 <- newBlockNoSwitch + szref <- convertExpression sze bl2 + switchBlock bl2 + ref <- genTemp (sizeof $ TArr t Nothing) + addIns $ IAri AMul szref (Constant (sizeof TInt) (fromIntegral $ sizeof t)) + addIns $ IAri AAdd szref (Constant (sizeof TInt) (fromIntegral $ sizeof TInt)) + addIns $ ICallr ref "_builtin_malloc" [szref] + setTerm $ IJmp nextnext + return ref + +convertAsExpression :: AsExpression -> Ref -> Id -> BuildM () +convertAsExpression (AEVar n _) valueref nextnext = do + mres <- findVar n + vref <- case mres of + Just (_, (r, _)) -> return r + Nothing -> throwError $ "Undefined variable '" ++ n ++ "'" ++ + " used in assignment expression" + addIns $ IMov vref valueref + setTerm $ IJmp nextnext +convertAsExpression (AESubscript ae2 expr mrt) valueref nextnext = do + let elemsz = sizeof $ fromJust mrt + ae2ref <- goLoad ae2 + bl2 <- newBlockNoSwitch + offref <- convertExpression expr bl2 + switchBlock bl2 + -- TODO: do bounds checking + addIns $ IAri AMul offref (Constant (sizeof TInt) (fromIntegral elemsz)) + addIns $ IAri AAdd offref (Constant (sizeof TInt) (fromIntegral $ sizeof TInt)) + addIns $ IAri AAdd ae2ref offref + addIns $ IStore ae2ref valueref + setTerm $ IJmp nextnext + where + goLoad :: AsExpression -> BuildM Ref + goLoad (AEVar n _) = do + mres <- findVar n + (vref, t) <- case mres of + Just (_, (r, t)) -> return (r, t) + Nothing -> throwError $ "Undefined variable '" ++ n ++ "'" ++ + " used in assignment expression" + ref <- genTemp (sizeof t) + addIns $ IMov ref vref + return ref + goLoad (AESubscript ae expr' _) = do + let elemsz = sizeof $ fromJust $ typeof ae + ref <- goLoad ae + bl2 <- newBlockNoSwitch + eref <- convertExpression expr' bl2 + switchBlock bl2 + -- TODO: do bounds checking + addIns $ IAri AMul eref (Constant (sizeof TInt) (fromIntegral elemsz)) + addIns $ IAri AAdd eref (Constant (sizeof TInt) (fromIntegral $ sizeof TInt)) + addIns $ IAri AAdd ref eref + dstref <- genTemp elemsz + addIns $ ILoad dstref ref + return dstref |