Compare commits
8 Commits
initial-re
...
d5c7e2826f
| Author | SHA1 | Date | |
|---|---|---|---|
|
d5c7e2826f
|
|||
|
cf7d0320af
|
|||
|
1be6175120
|
|||
|
78bfec0953
|
|||
|
bd4a6f5092
|
|||
|
b95b095dc8
|
|||
|
f82d5fbff7
|
|||
|
1d91d7a39d
|
@@ -1,6 +1,9 @@
|
||||
# Windows12
|
||||
A C-like compiled programming language implemented in Haskell.
|
||||
|
||||
## Examples
|
||||
Example programs can be found in the `test` directory.
|
||||
|
||||
## Usage
|
||||
Note: You must have version 9.0 of the Haskell compiler GHC installed. Otherwise
|
||||
Cabal will not be able to obtain the necessary dependencies.
|
||||
|
||||
61
flake.lock
generated
Normal file
61
flake.lock
generated
Normal file
@@ -0,0 +1,61 @@
|
||||
{
|
||||
"nodes": {
|
||||
"flake-utils": {
|
||||
"inputs": {
|
||||
"systems": "systems"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1731533236,
|
||||
"narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"nixpkgs": {
|
||||
"locked": {
|
||||
"lastModified": 1756469547,
|
||||
"narHash": "sha256-YvtD2E7MYsQ3r7K9K2G7nCslCKMPShoSEAtbjHLtH0k=",
|
||||
"owner": "nixos",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "41d292bfc37309790f70f4c120b79280ce40af16",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "nixos",
|
||||
"ref": "nixos-25.05",
|
||||
"repo": "nixpkgs",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"root": {
|
||||
"inputs": {
|
||||
"flake-utils": "flake-utils",
|
||||
"nixpkgs": "nixpkgs"
|
||||
}
|
||||
},
|
||||
"systems": {
|
||||
"locked": {
|
||||
"lastModified": 1681028828,
|
||||
"narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
|
||||
"owner": "nix-systems",
|
||||
"repo": "default",
|
||||
"rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "nix-systems",
|
||||
"repo": "default",
|
||||
"type": "github"
|
||||
}
|
||||
}
|
||||
},
|
||||
"root": "root",
|
||||
"version": 7
|
||||
}
|
||||
24
flake.nix
Normal file
24
flake.nix
Normal file
@@ -0,0 +1,24 @@
|
||||
{
|
||||
inputs = {
|
||||
nixpkgs.url = "github:nixos/nixpkgs/nixos-25.05";
|
||||
flake-utils.url = "github:numtide/flake-utils";
|
||||
};
|
||||
|
||||
outputs = { self, nixpkgs, flake-utils, ... }@inputs:
|
||||
flake-utils.lib.eachDefaultSystem (system:
|
||||
let
|
||||
pkgs = import nixpkgs {
|
||||
inherit system;
|
||||
};
|
||||
in
|
||||
{
|
||||
devShells.default = pkgs.mkShell {
|
||||
buildInputs = with pkgs; [
|
||||
haskell.compiler.ghc90
|
||||
cabal-install
|
||||
llvm_18
|
||||
];
|
||||
};
|
||||
}
|
||||
);
|
||||
}
|
||||
10
shell.nix
10
shell.nix
@@ -1,10 +0,0 @@
|
||||
let
|
||||
pkgs = import <nixpkgs> {};
|
||||
in
|
||||
pkgs.mkShell {
|
||||
buildInputs = [
|
||||
pkgs.haskell.compiler.ghc90
|
||||
pkgs.cabal-install
|
||||
pkgs.llvm_18
|
||||
];
|
||||
}
|
||||
@@ -12,7 +12,6 @@ import Windows12.Parser (programP)
|
||||
import System.Environment (getArgs)
|
||||
import LLVM.Pretty
|
||||
import Windows12.Ast
|
||||
import Windows12.Semant (convert)
|
||||
import Windows12.CodeGen (codegen)
|
||||
|
||||
|
||||
@@ -27,7 +26,4 @@ main = do
|
||||
test <- T.readFile inputFile
|
||||
case parse programP inputFile test of
|
||||
Left err -> print err
|
||||
Right ast ->
|
||||
case convert ast of
|
||||
Left err -> putStrLn err
|
||||
Right ast -> TL.writeFile outputFile (ppllvm (codegen (cs inputFile) ast))
|
||||
|
||||
@@ -4,5 +4,3 @@ import Windows12.Ast
|
||||
import Windows12.Lexer
|
||||
import Windows12.Parser
|
||||
import Windows12.CodeGen
|
||||
import Windows12.TAst
|
||||
import Windows12.Semant
|
||||
|
||||
@@ -163,7 +163,7 @@ instance Pretty Expr where
|
||||
pretty (Index arr idx) = parens (pretty arr) <> brackets (pretty idx)
|
||||
pretty (Member e m) = pretty e <> "." <> pretty m
|
||||
pretty (Cast t e) = parens (pretty t) <> parens (pretty e)
|
||||
pretty (Sizeof t) = "sizeof" <> parens (pretty t)
|
||||
pretty (Sizeof t) = "sizeof " <> pretty t
|
||||
pretty (StructInit s fields) = pretty s <+> lbrace <> line <> indent 4 (vsep (punctuate comma (map (\(n, e) -> pretty n <+> "=" <+> pretty e) fields))) <> line <> rbrace
|
||||
|
||||
instance Pretty Stmt where
|
||||
@@ -183,7 +183,7 @@ instance Pretty Type where
|
||||
pretty BoolType = "bool"
|
||||
pretty CharType = "char"
|
||||
pretty (PtrType t) = pretty t <> "*"
|
||||
pretty (ArrayType t) = pretty t <> "[]"
|
||||
pretty (ArrayType t) = "[" <> pretty t <> "]"
|
||||
pretty (StructType s) = pretty s
|
||||
pretty (EnumType e) = pretty e
|
||||
pretty VoidType = "void"
|
||||
|
||||
@@ -6,9 +6,7 @@
|
||||
|
||||
module Windows12.CodeGen where
|
||||
|
||||
import Windows12.Ast (BinOp(..), UnOp(..), AssignOp(..), Type(..),
|
||||
Bind(..), TLStruct(..), TLEnum(..))
|
||||
import Windows12.TAst
|
||||
import Windows12.Ast;
|
||||
|
||||
import LLVM.AST hiding (ArrayType, VoidType, Call, function)
|
||||
import LLVM.AST.Type (i32, i1, i8, double, ptr, void)
|
||||
@@ -27,7 +25,7 @@ import Data.String.Conversions
|
||||
import Data.String
|
||||
|
||||
-- Global program context, used to keep track of operands
|
||||
data Ctx = Ctx { operands :: [(Text, Operand)],
|
||||
data Ctx = Ctx { operands :: [(Text, (Maybe Windows12.Ast.Type, Operand))],
|
||||
structs :: [TLStruct],
|
||||
enums :: [TLEnum],
|
||||
strings :: [(Text, Operand)] }
|
||||
@@ -41,19 +39,19 @@ instance ConvertibleStrings Text ShortByteString where
|
||||
convertString = Data.String.fromString . Data.Text.unpack
|
||||
|
||||
-- Put an operand into the context with a name
|
||||
createOperand :: MonadState Ctx m => Text -> Operand -> m ()
|
||||
createOperand name op = do
|
||||
createOperand :: MonadState Ctx m => Text -> Maybe Windows12.Ast.Type -> Operand -> m ()
|
||||
createOperand name op_type op = do
|
||||
ctx <- get
|
||||
put $ ctx { operands = (name, op) : operands ctx }
|
||||
put $ ctx { operands = (name, (op_type, op)) : operands ctx }
|
||||
|
||||
-- Take in a source file name, the AST, and return the LLVM IR module
|
||||
codegen :: Text -> TProgram -> Module
|
||||
codegen filename (TProgram structs enums funcs) =
|
||||
codegen :: Text -> Program -> Module
|
||||
codegen filename (Program structs enums funcs) =
|
||||
flip evalState (Ctx [] [] [] [])
|
||||
$ buildModuleT (cs filename)
|
||||
$ do
|
||||
printf <- externVarArgs (mkName "printf") [ptr i8] i32
|
||||
createOperand "printf" printf
|
||||
createOperand "printf" Nothing printf
|
||||
mapM_ emitTypeDef structs
|
||||
mapM_ codegenFunc funcs
|
||||
|
||||
@@ -91,7 +89,7 @@ size FloatType = return 8
|
||||
size StrType = size (PtrType CharType)
|
||||
size BoolType = return 1
|
||||
size CharType = return 1
|
||||
size (PtrType _) = return 4
|
||||
size (PtrType _) = return 8
|
||||
size (ArrayType t) = size (PtrType t)
|
||||
size (StructType name) = do
|
||||
fields <- getStructFields name
|
||||
@@ -100,27 +98,26 @@ size (StructType name) = do
|
||||
size (EnumType _) = return 8
|
||||
size VoidType = return 0
|
||||
|
||||
|
||||
-- CodeGen for LValues
|
||||
codegenLVal :: TLVal -> IRBuilder Operand
|
||||
codegenLVal (t, (TId name)) = do
|
||||
codegenLVal :: Expr -> IRBuilder Operand
|
||||
codegenLVal (Id name) = do
|
||||
ctx <- get
|
||||
case lookup name (operands ctx) of
|
||||
Just op -> return op
|
||||
Just (_type, op) -> return op
|
||||
Nothing -> error $ "Variable " ++ show name ++ " not found"
|
||||
|
||||
-- TODO support members of members
|
||||
codegenLVal ((StructType t), (LTMember ((_, TId sName)) field)) = do
|
||||
codegenLVal (Member (Id sName) (Id field)) = do
|
||||
ctx <- get
|
||||
case lookup sName (operands ctx) of
|
||||
Just struct -> do
|
||||
fields <- getStructFields t
|
||||
Just ((Just (StructType op_type)), struct) -> do
|
||||
fields <- getStructFields op_type
|
||||
offset <- structFieldOffset (Struct sName fields) field
|
||||
gep struct [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 (fromIntegral offset))]
|
||||
Nothing -> error $ "Struct " ++ show sName ++ " not found"
|
||||
|
||||
codeGenLVal (t, (TDeref e)) = codegenExpr e
|
||||
|
||||
codeGenLVal (t, _) = error "Unimplemented or invalid LValue"
|
||||
codeGenLVal _ = error "Unimplemented or invalid LValue"
|
||||
|
||||
-- Given a struct and a field name, return the offset of the field in the struct.
|
||||
-- In LLVM each field is actually size 1
|
||||
@@ -129,12 +126,12 @@ structFieldOffset (Struct name fields) field = do
|
||||
return $ length $ takeWhile (\(Bind n _) -> n /= field) fields
|
||||
|
||||
-- CodeGen for expressions
|
||||
codegenExpr :: TExpr -> IRBuilder Operand
|
||||
codegenExpr (t, (TVar name)) = flip load 0 =<< codegenLVal (t, (TId name))
|
||||
codegenExpr (t, (TIntLit i)) = return $ ConstantOperand (C.Int 32 (fromIntegral i))
|
||||
codegenExpr (t, (TUIntLit i)) = return $ ConstantOperand (C.Int 32 (fromIntegral i))
|
||||
codegenExpr (t, (TFloatLit f)) = undefined -- TODO floats
|
||||
codegenExpr (t, (TStrLit s)) = do
|
||||
codegenExpr :: Expr -> IRBuilder Operand
|
||||
codegenExpr (Id name) = flip load 0 =<< codegenLVal (Id name)
|
||||
codegenExpr (IntLit i) = return $ ConstantOperand (C.Int 32 (fromIntegral i))
|
||||
codegenExpr (UIntLit i) = return $ ConstantOperand (C.Int 32 (fromIntegral i))
|
||||
codegenExpr (FloatLit f) = undefined -- TODO floats
|
||||
codegenExpr (StrLit s) = do
|
||||
strs <- gets strings
|
||||
case lookup s strs of
|
||||
-- If the string is already in the context, return it
|
||||
@@ -145,10 +142,11 @@ codegenExpr (t, (TStrLit s)) = do
|
||||
op <- globalStringPtr (cs s) str_name
|
||||
modify $ \ctx -> ctx { strings = (s, (ConstantOperand op)) : strs }
|
||||
return (ConstantOperand op)
|
||||
codegenExpr (t, (TBoolLit b)) = return $ ConstantOperand (C.Int 1 (if b then 1 else 0))
|
||||
codegenExpr (t, (TCharLit c)) = return $ ConstantOperand (C.Int 8 (fromIntegral (fromEnum c)))
|
||||
|
||||
codegenExpr (t, (TBinOp op lhs rhs)) = do
|
||||
codegenExpr (BoolLit b) = return $ ConstantOperand (C.Int 1 (if b then 1 else 0))
|
||||
codegenExpr (CharLit c) = return $ ConstantOperand (C.Int 8 (fromIntegral (fromEnum c)))
|
||||
|
||||
codegenExpr (BinOp op lhs rhs) = do
|
||||
lhs' <- codegenExpr lhs
|
||||
rhs' <- codegenExpr rhs
|
||||
|
||||
@@ -190,33 +188,33 @@ codegenExpr (t, (TBinOp op lhs rhs)) = do
|
||||
|
||||
other -> error $ "Operator " ++ show other ++ " not implemented"
|
||||
|
||||
codegenExpr (t, (TUnOp op e)) = undefined -- TODO handle unary operators
|
||||
codegenExpr (UnOp op e) = undefined -- TODO handle unary operators
|
||||
|
||||
-- Function calls: look up the function in operands, then call it with the args
|
||||
codegenExpr (t, (TCall f args)) = do
|
||||
codegenExpr (Call (Id f) args) = do
|
||||
ctx <- get
|
||||
f <- case lookup f (operands ctx) of
|
||||
Just f -> return f
|
||||
Just (_type, f) -> return f
|
||||
Nothing -> error $ "Function " ++ show f ++ " not found"
|
||||
args <- mapM (fmap (, []) . codegenExpr) args
|
||||
call f args
|
||||
|
||||
codegenExpr (t, (TIndex arr idx)) = undefined -- TODO arrays
|
||||
codegenExpr (Index arr idx) = undefined -- TODO arrays
|
||||
|
||||
-- Get the address of the struct field and load it
|
||||
codegenExpr (t, (TMember ((StructType sName), (TVar sVarName)) m)) = do
|
||||
codegenExpr (Member (Id sVarName) (Id field)) = do
|
||||
ctx <- get
|
||||
case lookup sVarName (operands ctx) of
|
||||
Just struct -> do
|
||||
fields <- getStructFields sName
|
||||
offset <- structFieldOffset (Struct sVarName fields) m
|
||||
Just ((Just (StructType op_type)), struct) -> do
|
||||
fields <- getStructFields op_type
|
||||
offset <- structFieldOffset (Struct op_type fields) field
|
||||
addr <- gep struct [ConstantOperand (C.Int 32 0), ConstantOperand (C.Int 32 (fromIntegral offset))]
|
||||
load addr 0
|
||||
Nothing -> error $ "Struct operand " ++ show sVarName ++ " not found"
|
||||
|
||||
codegenExpr (_, (TCast t e)) = undefined -- TODO casts
|
||||
codegenExpr (Cast t e) = undefined -- TODO casts
|
||||
|
||||
codegenExpr (_, (TSizeof t)) = ConstantOperand . C.Int 32 . fromIntegral <$> size t
|
||||
codegenExpr (Sizeof t) = ConstantOperand . C.Int 32 . fromIntegral <$> size t
|
||||
|
||||
mkTerminator :: IRBuilder () -> IRBuilder ()
|
||||
mkTerminator instr = do
|
||||
@@ -224,81 +222,81 @@ mkTerminator instr = do
|
||||
unless check instr
|
||||
|
||||
-- Codegen for statements
|
||||
codegenStmt :: TStmt -> IRBuilder ()
|
||||
codegenStmt :: Stmt -> IRBuilder ()
|
||||
|
||||
-- For expression statements, just evaluate the expression and discard the result
|
||||
codegenStmt (TExprStmt e) = do
|
||||
codegenStmt (Expr e) = do
|
||||
_expr <- codegenExpr e
|
||||
return ()
|
||||
|
||||
codegenStmt (TReturn e) = ret =<< codegenExpr e
|
||||
codegenStmt (Return e) = ret =<< codegenExpr e
|
||||
|
||||
-- Generate if statements, with a merge block at the end
|
||||
codegenStmt (TIf cond t f) = mdo
|
||||
codegenStmt (If cond t f) = mdo
|
||||
cond' <- codegenExpr cond
|
||||
condBr cond' then' else'
|
||||
|
||||
then' <- block `named` "then"
|
||||
codegenStmt (TBlock t)
|
||||
codegenStmt (Block t)
|
||||
mkTerminator $ br merge
|
||||
|
||||
else' <- block `named` "else"
|
||||
codegenStmt (case f of
|
||||
Just f' -> TBlock f'
|
||||
Nothing -> TBlock [])
|
||||
Just f' -> Block f'
|
||||
Nothing -> Block [])
|
||||
mkTerminator $ br merge
|
||||
|
||||
merge <- block `named` "merge"
|
||||
return ()
|
||||
|
||||
-- Generate while loops, with a merge block at the end
|
||||
codegenStmt (TWhile cond body) = mdo
|
||||
codegenStmt (While cond body) = mdo
|
||||
br condBlock
|
||||
condBlock <- block `named` "cond"
|
||||
cond' <- codegenExpr cond
|
||||
condBr cond' loop end
|
||||
|
||||
loop <- block `named` "loop"
|
||||
codegenStmt (TBlock body)
|
||||
codegenStmt (Block body)
|
||||
mkTerminator $ br condBlock
|
||||
|
||||
end <- block `named` "end"
|
||||
return ()
|
||||
|
||||
codegenStmt (TAssign BaseAssign l e) = do
|
||||
codegenStmt (Assign BaseAssign l e) = do
|
||||
op <- codegenExpr e
|
||||
var <- codegenLVal l
|
||||
store var 0 op
|
||||
|
||||
codegenStmt (TAssign AddAssign l e) = do
|
||||
codegenStmt (Assign AddAssign l e) = do
|
||||
op <- codegenExpr e
|
||||
var <- codegenLVal l
|
||||
val <- load var 0
|
||||
store var 0 =<< add val op
|
||||
|
||||
codegenStmt (TAssign SubAssign l e) = do
|
||||
codegenStmt (Assign SubAssign l e) = do
|
||||
op <- codegenExpr e
|
||||
var <- codegenLVal l
|
||||
val <- load var 0
|
||||
store var 0 =<< sub val op
|
||||
|
||||
-- A block is just a list of statements
|
||||
codegenStmt (TBlock stmts) = mapM_ codegenStmt stmts
|
||||
codegenStmt (Block stmts) = mapM_ codegenStmt stmts
|
||||
|
||||
-- Since the vars are already allocated by genBody, we just need to assign the value
|
||||
codegenStmt (TDeclVar name t (Just e)) = codegenStmt (TAssign BaseAssign (t, (TId name)) e)
|
||||
codegenStmt (Var name t (Just e)) = codegenStmt (Assign BaseAssign (Id name) e)
|
||||
|
||||
-- Do nothing with variable declaration if no expression is given
|
||||
-- This is because allocation is done already
|
||||
codegenStmt (TDeclVar name _ Nothing) = return ()
|
||||
codegenStmt (Var name _ Nothing) = return ()
|
||||
|
||||
codegenStmt s = error $ "Unimplemented or invalid statement " ++ show s
|
||||
|
||||
-- Generate code for a function
|
||||
-- First create the function, then allocate space for the arguments and locals
|
||||
codegenFunc :: TTLFunc -> ModuleBuilder ()
|
||||
codegenFunc func@(TTLFunc name args retType body) = mdo
|
||||
createOperand name f
|
||||
codegenFunc :: TLFunc -> ModuleBuilder ()
|
||||
codegenFunc func@(Func name args retType body) = mdo
|
||||
createOperand name Nothing f
|
||||
(f, strs) <- do
|
||||
params' <- mapM mkParam args
|
||||
retType' <- convertType retType
|
||||
@@ -311,31 +309,32 @@ codegenFunc func@(TTLFunc name args retType body) = mdo
|
||||
|
||||
genBody :: [Operand] -> IRBuilder ()
|
||||
genBody ops = do
|
||||
forM_ (zip ops args) $ \(op, (Bind name t)) -> do
|
||||
forM_ (zip ops args) $ \(op, Bind name t) -> do
|
||||
addr <- alloca (typeOf op) Nothing 0
|
||||
store addr 0 op
|
||||
createOperand name addr
|
||||
createOperand name (Just t) addr
|
||||
|
||||
forM_ (getLocals func) $ \(Bind name t) -> do
|
||||
ltype <- convertType t
|
||||
addr <- alloca ltype Nothing 0
|
||||
createOperand name addr
|
||||
createOperand name (Just t) addr
|
||||
|
||||
codegenStmt (TBlock body)
|
||||
codegenStmt (Block body)
|
||||
|
||||
-- Given a function, get all the local variables
|
||||
-- Used so allocation can be done before the function body
|
||||
getLocals :: TTLFunc -> [Bind]
|
||||
getLocals (TTLFunc _ args _ body) = blockGetLocals body
|
||||
getLocals :: TLFunc -> [Bind]
|
||||
getLocals (Func _ args _ body) = blockGetLocals body
|
||||
|
||||
blockGetLocals :: [TStmt] -> [Bind]
|
||||
blockGetLocals :: [Stmt] -> [Bind]
|
||||
blockGetLocals = concatMap stmtGetLocals
|
||||
|
||||
stmtGetLocals :: TStmt -> [Bind]
|
||||
stmtGetLocals (TDeclVar n t _) = [Bind n t]
|
||||
stmtGetLocals (TBlock stmts) = blockGetLocals stmts
|
||||
stmtGetLocals (TIf _ t f) = blockGetLocals t ++ maybe [] blockGetLocals f
|
||||
stmtGetLocals (TWhile _ body) = blockGetLocals body
|
||||
stmtGetLocals :: Stmt -> [Bind]
|
||||
stmtGetLocals (Var n (Just t) _) = [Bind n t]
|
||||
stmtGetLocals (Var n Nothing _) = error $ "Explicit typing required (var " ++ show n ++ ")"
|
||||
stmtGetLocals (Block stmts) = blockGetLocals stmts
|
||||
stmtGetLocals (If _ t f) = blockGetLocals t ++ maybe [] blockGetLocals f
|
||||
stmtGetLocals (While _ body) = blockGetLocals body
|
||||
stmtGetLocals _ = []
|
||||
|
||||
-- Create structs
|
||||
|
||||
@@ -148,7 +148,7 @@ memberFuncP = do
|
||||
args <- parens (sepBy (Bind <$> identifier <* symbol ":" <*> typeP) (symbol ","))
|
||||
retType <- (symbol "->" *> typeP) <|> pure VoidType
|
||||
body <- braces (many stmtP)
|
||||
return $ Func name (Bind "self" self : args) retType body
|
||||
return $ Func name (Bind "self" (PtrType self) : args) retType body
|
||||
|
||||
organize :: [TL] -> Program
|
||||
organize tls = Program structs enums funcs
|
||||
|
||||
@@ -1,263 +0,0 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Windows12.Semant where
|
||||
|
||||
import Data.Text (Text)
|
||||
|
||||
import Control.Monad.State
|
||||
|
||||
import Data.List (find)
|
||||
|
||||
import Windows12.Ast as Ast
|
||||
import Windows12.TAst as TAst
|
||||
|
||||
suppliedFuncs :: [Text]
|
||||
suppliedFuncs = ["printf"]
|
||||
|
||||
-- Convert an Ast to a TAst
|
||||
-- Performs type inference and type checking
|
||||
|
||||
data Ctx = Ctx { structs :: [TLStruct],
|
||||
enums :: [TLEnum],
|
||||
funcs :: [TTLFunc],
|
||||
vars :: [(Text, Type)] }
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- Main conversion function. May return an error message if the program
|
||||
-- is not well-typed.
|
||||
convert :: Ast.Program -> Either String TAst.TProgram
|
||||
convert (Ast.Program structs enums funcs) = do
|
||||
let ctx = Ctx structs enums [] []
|
||||
let (funcs', _) = runState (mapM convertFunc funcs) ctx
|
||||
return $ TAst.TProgram structs enums funcs'
|
||||
|
||||
-- Convert a TLFunc (Top Level Function) to a TTLFunc (Typed Top Level Function)
|
||||
-- Note that the function must be added to the context before converting statements
|
||||
-- of the function. This is because the function may call itself recursively.
|
||||
-- After converting the function, the function's statements are converted
|
||||
-- and added to the context.
|
||||
convertFunc :: MonadState Ctx m => Ast.TLFunc -> m TAst.TTLFunc
|
||||
convertFunc (Ast.Func name args retType body) = do
|
||||
args' <- mapM (\(Bind name t) -> return (name, t)) args
|
||||
oldFuncs <- gets funcs
|
||||
modify (\ctx -> ctx { funcs = funcs ctx ++ [TTLFunc name args retType []], vars = args' })
|
||||
body' <- mapM convertStmt body
|
||||
ctx <- get
|
||||
let func = (last $ funcs ctx) { TAst.funcBody = body' }
|
||||
put $ ctx { funcs = oldFuncs ++ [func] }
|
||||
return func
|
||||
|
||||
-- Convert a statement
|
||||
convertStmt :: MonadState Ctx m => Ast.Stmt -> m TAst.TStmt
|
||||
|
||||
convertStmt (Ast.Expr expr) = do
|
||||
expr' <- convertExpr expr
|
||||
return $ TAst.TExprStmt expr'
|
||||
|
||||
convertStmt (Ast.Return expr) = do
|
||||
expr' <- convertExpr expr
|
||||
return $ TAst.TReturn expr'
|
||||
|
||||
convertStmt (Ast.If cond thenStmts elseStmts) = do
|
||||
thenStmts' <- mapM convertStmt thenStmts
|
||||
elseStmts' <- mapM convertStmt $ maybe [] id elseStmts
|
||||
cond' <- convertExpr cond
|
||||
return $ TAst.TIf cond' thenStmts' (Just elseStmts')
|
||||
|
||||
convertStmt (Ast.While cond stmts) = do
|
||||
stmts' <- mapM convertStmt stmts
|
||||
cond' <- convertExpr cond
|
||||
return $ TAst.TWhile cond' stmts'
|
||||
|
||||
convertStmt (Ast.Assign op lval expr) = do
|
||||
lval' <- convertLVal lval
|
||||
expr' <- convertExpr expr
|
||||
return $ TAst.TAssign op lval' expr'
|
||||
|
||||
convertStmt (Ast.Block stmts) = do
|
||||
stmts' <- mapM convertStmt stmts
|
||||
return $ TAst.TBlock stmts'
|
||||
|
||||
convertStmt (Ast.Var name (Just t) maybeExpr) = do
|
||||
expr' <- maybe (return Nothing) (fmap Just . convertExpr) maybeExpr
|
||||
modify (\ctx -> ctx { vars = (name, t) : vars ctx })
|
||||
return $ TAst.TDeclVar name t expr'
|
||||
|
||||
-- TODO
|
||||
convertStmt (Ast.Var name Nothing maybeExpr) = error "Type inference not implemented"
|
||||
|
||||
-- Convert an expression to an LValue
|
||||
-- Only certain expressions are allowed as LValues
|
||||
convertLVal :: MonadState Ctx m => Ast.Expr -> m TAst.TLVal
|
||||
convertLVal (Ast.Id name) = do
|
||||
ctx <- get
|
||||
case lookup name (vars ctx) of
|
||||
Just t -> return (t, TAst.TId name)
|
||||
Nothing -> error $ "Variable " ++ show name ++ " not in scope"
|
||||
|
||||
convertLVal (Ast.Index arr idx) = do
|
||||
arr' <- convertLVal arr
|
||||
idx' <- convertExpr idx
|
||||
return (fst arr', TAst.LTIndex arr' idx')
|
||||
|
||||
convertLVal (Ast.Member e (Id m)) = do
|
||||
e' <- convertLVal e
|
||||
return (fst e', TAst.LTMember e' m)
|
||||
|
||||
convertLVal (Ast.Member e m) = do error $ "Invalid member access " ++ show m ++ " on " ++ show e
|
||||
|
||||
convertLVal (Ast.UnOp Ast.Deref e) = error "Dereferencing not implemented"
|
||||
|
||||
convertLVal e = do error $ "Invalid or unimplemented LValue " ++ show e
|
||||
|
||||
-- Convert an expression
|
||||
convertExpr :: MonadState Ctx m => Ast.Expr -> m TAst.TExpr
|
||||
convertExpr (Ast.Id name) = do
|
||||
ctx <- get
|
||||
case lookup name (vars ctx) of
|
||||
Just t -> return (t, TAst.TVar name)
|
||||
Nothing -> error $ "Variable " ++ show name ++ " not in scope"
|
||||
|
||||
convertExpr (Ast.IntLit x) = return (IntType, TAst.TIntLit x)
|
||||
convertExpr (Ast.UIntLit x) = return (UIntType, TAst.TUIntLit x)
|
||||
convertExpr (Ast.FloatLit x) = return (FloatType, TAst.TFloatLit x)
|
||||
convertExpr (Ast.StrLit x) = return (StrType, TAst.TStrLit x)
|
||||
convertExpr (Ast.BoolLit x) = return (BoolType, TAst.TBoolLit x)
|
||||
convertExpr (Ast.CharLit x) = return (CharType, TAst.TCharLit x)
|
||||
|
||||
convertExpr (Ast.BinOp Add l r) = arithOp Add l r
|
||||
convertExpr (Ast.BinOp Sub l r) = arithOp Sub l r
|
||||
convertExpr (Ast.BinOp Mul l r) = arithOp Mul l r
|
||||
convertExpr (Ast.BinOp Div l r) = arithOp Div l r
|
||||
convertExpr (Ast.BinOp Mod l r) = arithOp Mod l r
|
||||
|
||||
convertExpr (Ast.BinOp Eq l r) = compOp Eq l r
|
||||
convertExpr (Ast.BinOp Ne l r) = compOp Ne l r
|
||||
convertExpr (Ast.BinOp Lt l r) = compOp Lt l r
|
||||
convertExpr (Ast.BinOp Gt l r) = compOp Gt l r
|
||||
convertExpr (Ast.BinOp Le l r) = compOp Le l r
|
||||
convertExpr (Ast.BinOp Ge l r) = compOp Ge l r
|
||||
|
||||
convertExpr (Ast.BinOp And l r) = boolOp And l r
|
||||
convertExpr (Ast.BinOp Or l r) = boolOp Or l r
|
||||
|
||||
convertExpr (Ast.BinOp BitAnd l r) = bitOp BitAnd l r
|
||||
convertExpr (Ast.BinOp BitOr l r) = bitOp BitOr l r
|
||||
convertExpr (Ast.BinOp BitXor l r) = bitOp BitXor l r
|
||||
|
||||
convertExpr (Ast.BinOp ShiftL l r) = shiftOp ShiftL l r
|
||||
convertExpr (Ast.BinOp ShiftR l r) = shiftOp ShiftR l r
|
||||
|
||||
convertExpr (Ast.UnOp Neg e) = do
|
||||
e' <- convertExpr e
|
||||
if fst e' `elem` [IntType, UIntType, FloatType]
|
||||
then return (fst e', TAst.TUnOp Neg e')
|
||||
else error $ "Type mismatch: " ++ show e
|
||||
|
||||
convertExpr (Ast.UnOp Not e) = do
|
||||
e' <- convertExpr e
|
||||
if fst e' == BoolType
|
||||
then return (BoolType, TAst.TUnOp Not e')
|
||||
else error $ "Type mismatch: " ++ show e
|
||||
|
||||
convertExpr (Ast.UnOp BitNot e) = undefined
|
||||
convertExpr (Ast.UnOp Deref e) = undefined
|
||||
convertExpr (Ast.UnOp AddrOf e) = undefined
|
||||
|
||||
-- TODO type check function return
|
||||
-- TODO ensure returns on all paths
|
||||
-- Lower priority since LLVM checks this also
|
||||
convertExpr (Ast.Call (Id f) args) = do
|
||||
ctx <- get
|
||||
if f == "printf"
|
||||
then do
|
||||
args' <- mapM convertExpr args
|
||||
return (IntType, TAst.TCall "printf" args')
|
||||
else case find (\(TTLFunc n a r _) -> n == f) (funcs ctx) of
|
||||
Just t -> do
|
||||
args' <- mapM convertExpr args
|
||||
if length args' == length (TAst.funcArgs t) && all (\(t1, t2) -> t1 == t2) (zip (map fst args') (map bindType (TAst.funcArgs t)))
|
||||
then return (TAst.funcRetType t, TAst.TCall f args')
|
||||
else error $ "Type mismatch in call to " ++ show f
|
||||
Nothing -> error $ "Function " ++ show f ++ " not in scope. Available functions: " ++ show (map TAst.funcName (funcs ctx))
|
||||
|
||||
convertExpr (Ast.Index arr idx) = do
|
||||
arr' <- convertExpr arr
|
||||
idx' <- convertExpr idx
|
||||
case fst arr' of
|
||||
ArrayType t -> if fst idx' == IntType
|
||||
then return (t, TAst.TIndex arr' idx')
|
||||
else error $ "Index must be an integer: " ++ show idx
|
||||
_ -> error $ "Indexing non-array: " ++ show arr
|
||||
|
||||
convertExpr (Ast.Cast t e) = do
|
||||
e' <- convertExpr e
|
||||
return (t, TAst.TCast t e')
|
||||
|
||||
convertExpr (Ast.Sizeof t) = return (IntType, TAst.TSizeof t)
|
||||
|
||||
convertExpr (Ast.Member e (Id m)) = do
|
||||
e' <- convertExpr e
|
||||
case fst e' of
|
||||
StructType name -> do
|
||||
ctx <- get
|
||||
case find (\(Struct n _) -> n == name) (structs ctx) of
|
||||
Just (Struct _ binds) -> case find (\(Bind n t) -> n == m) binds of
|
||||
Just (Bind _ t) -> return (t, TAst.TMember e' m)
|
||||
Nothing -> error $ "Field " ++ show m ++ " not in struct " ++ show name
|
||||
Nothing -> error $ "Struct " ++ show name ++ " not in scope"
|
||||
_ -> error $ "Member access on non-struct " ++ show e
|
||||
|
||||
convertExpr (Ast.StructInit name fields) = do
|
||||
ctx <- get
|
||||
case find (\(Struct n _) -> n == name) (structs ctx) of
|
||||
Just (Struct _ binds) -> do
|
||||
fields' <- mapM (\(n, e) -> do
|
||||
e' <- convertExpr e
|
||||
case find (\(Bind n' t) -> n == n') binds of
|
||||
Just (Bind _ t) -> if fst e' == t
|
||||
then return (n, e')
|
||||
else error $ "Type mismatch in struct initialization: " ++ show e
|
||||
Nothing -> error $ "Field " ++ show n ++ " not in struct " ++ show name) fields
|
||||
|
||||
return (StructType name, TAst.TStructInit name fields')
|
||||
Nothing -> error $ "Struct " ++ show name ++ " not in scope"
|
||||
|
||||
convertExpr e = error $ "Invalid or Unimplemented conversion for expression " ++ show e
|
||||
|
||||
-- Ensure that the types of the left and right expressions are the same
|
||||
-- and return the type of the result
|
||||
arithOp :: MonadState Ctx m => Ast.BinOp -> Ast.Expr -> Ast.Expr -> m TAst.TExpr
|
||||
arithOp o l r = do
|
||||
l' <- convertExpr l
|
||||
r' <- convertExpr r
|
||||
if fst l' == fst r'
|
||||
then return (fst l', TAst.TBinOp o l' r')
|
||||
else error $ "Type mismatch: " ++ show l ++ " and " ++ show r
|
||||
|
||||
-- Ensure that the types of the left and right expressions are the same
|
||||
-- and return a boolean type
|
||||
compOp :: MonadState Ctx m => Ast.BinOp -> Ast.Expr -> Ast.Expr -> m TAst.TExpr
|
||||
compOp o l r = do
|
||||
l' <- convertExpr l
|
||||
r' <- convertExpr r
|
||||
if fst l' == fst r'
|
||||
then return (BoolType, TAst.TBinOp o l' r')
|
||||
else error $ "Type mismatch: " ++ show l ++ " and " ++ show r
|
||||
|
||||
-- Ensure that the types of both expressions are boolean
|
||||
-- and return a boolean type
|
||||
boolOp :: MonadState Ctx m => Ast.BinOp -> Ast.Expr -> Ast.Expr -> m TAst.TExpr
|
||||
boolOp o l r = do
|
||||
l' <- convertExpr l
|
||||
r' <- convertExpr r
|
||||
if fst l' == fst r' && fst l' == BoolType
|
||||
then return (BoolType, TAst.TBinOp o l' r')
|
||||
else error $ "Type mismatch: " ++ show l ++ " and " ++ show r
|
||||
|
||||
bitOp :: MonadState Ctx m => Ast.BinOp -> Ast.Expr -> Ast.Expr -> m TAst.TExpr
|
||||
bitOp o l r = do error $ "Bit operations not implemented"
|
||||
|
||||
shiftOp :: MonadState Ctx m => Ast.BinOp -> Ast.Expr -> Ast.Expr -> m TAst.TExpr
|
||||
shiftOp o l r = do error $ "Shift operations not implemented"
|
||||
@@ -1,54 +0,0 @@
|
||||
module Windows12.TAst where
|
||||
|
||||
import Data.Text (Text)
|
||||
|
||||
import Windows12.Ast as Ast
|
||||
|
||||
-- "Typed AST". A second AST that contains more type information
|
||||
-- Makes verification easier, and is needed to determine type
|
||||
-- of structs when accessing members in CodeGen
|
||||
|
||||
type TExpr = (Type, TExpr')
|
||||
|
||||
data TExpr'
|
||||
= TVar Text
|
||||
| TIntLit Int
|
||||
| TUIntLit Word
|
||||
| TFloatLit Double
|
||||
| TStrLit Text
|
||||
| TBoolLit Bool
|
||||
| TCharLit Char
|
||||
| TBinOp BinOp TExpr TExpr
|
||||
| TUnOp UnOp TExpr
|
||||
| TCall Text [TExpr]
|
||||
| TIndex TExpr TExpr
|
||||
| TMember TExpr Text
|
||||
| TCast Type TExpr
|
||||
| TSizeof Type
|
||||
| TStructInit Text [(Text, TExpr)]
|
||||
deriving (Show, Eq)
|
||||
|
||||
type TLVal = (Type, TLVal')
|
||||
|
||||
data TLVal'
|
||||
= TDeref TExpr
|
||||
| TId Text
|
||||
| LTIndex TLVal TExpr
|
||||
| LTMember TLVal Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
data TStmt
|
||||
= TExprStmt TExpr
|
||||
| TReturn TExpr
|
||||
| TIf TExpr [TStmt] (Maybe [TStmt])
|
||||
| TWhile TExpr [TStmt]
|
||||
| TAssign AssignOp TLVal TExpr
|
||||
| TBlock [TStmt]
|
||||
| TDeclVar Text Type (Maybe TExpr)
|
||||
deriving (Show, Eq)
|
||||
|
||||
data TTLFunc = TTLFunc {funcName :: Text, funcArgs :: [Bind], funcRetType :: Type, funcBody :: [TStmt]}
|
||||
deriving (Show, Eq)
|
||||
|
||||
data TProgram = TProgram [TLStruct] [TLEnum] [TTLFunc]
|
||||
deriving (Show, Eq)
|
||||
33
test/sizeof.w12
Normal file
33
test/sizeof.w12
Normal file
@@ -0,0 +1,33 @@
|
||||
struct BigStruct {
|
||||
name: [char],
|
||||
number: int,
|
||||
number2: int,
|
||||
}
|
||||
|
||||
struct BiggerStruct {
|
||||
character: char,
|
||||
big: BigStruct,
|
||||
}
|
||||
|
||||
struct SmallStruct {
|
||||
value: int,
|
||||
}
|
||||
|
||||
|
||||
fn main() -> int {
|
||||
printf("Size of int: %u\n", sizeof int);
|
||||
printf("Size of uint: %u\n", sizeof uint);
|
||||
printf("Size of float: %u\n", sizeof float);
|
||||
printf("Size of [char]: %u\n", sizeof [char]);
|
||||
printf("Size of [int]: %u\n", sizeof [int]);
|
||||
printf("Size of bool: %u\n", sizeof bool);
|
||||
printf("Size of int*: %u\n", sizeof int*);
|
||||
printf("Size of bool*: %u\n", sizeof bool*);
|
||||
printf("Size of BigStruct*: %u\n", sizeof BigStruct*);
|
||||
printf("Size of SmallStruct*: %u\n", sizeof SmallStruct*);
|
||||
printf("Size of BigStruct: %u\n", sizeof BigStruct);
|
||||
printf("Size of BiggerStruct: %u\n", sizeof BiggerStruct);
|
||||
printf("Size of SmallStruct: %u\n", sizeof SmallStruct);
|
||||
|
||||
return 0;
|
||||
}
|
||||
@@ -69,8 +69,6 @@ executable windows12
|
||||
Windows12.Lexer
|
||||
Windows12.Parser
|
||||
Windows12.CodeGen
|
||||
Windows12.TAst
|
||||
Windows12.Semant
|
||||
|
||||
-- LANGUAGE extensions used by modules in this package.
|
||||
-- other-extensions:
|
||||
|
||||
Reference in New Issue
Block a user