843c652f by Ulrich Schoepp

tree2c

1 parent b36b8d86
{-
- Translation of tree programs to C.
-}
module Cmm(
cmmDoc
) where
import Prelude hiding (EQ,GT,LT)
import qualified Data.Set as Set
import Text.PrettyPrint
import Names
import Tree
tempsExp :: Exp -> Set.Set Temp
tempsExp (CONST _) = Set.empty
tempsExp (NAME _) = Set.empty
tempsExp (TEMP t) = Set.singleton t
tempsExp (PARAM _) = Set.empty
tempsExp (BINOP _ e1 e2) = (tempsExp e1) `Set.union` (tempsExp e2)
tempsExp (MEM e) = tempsExp e
tempsExp (CALL f as) = (tempsExp f) `Set.union` Set.unions (map tempsExp as)
tempsExp (ESEQ s e) = tempsStm s `Set.union` (tempsExp e)
tempsStm :: Stm -> Set.Set Temp
tempsStm (MOVE d s) = (tempsExp d) `Set.union` (tempsExp s)
tempsStm (JUMP e _) = tempsExp e
tempsStm (CJUMP _ e1 e2 _ _) = (tempsExp e1) `Set.union` (tempsExp e2)
tempsStm (SEQ ss) = Set.unions (map tempsStm ss)
tempsStm (LABEL _) = Set.empty
cmmBinOp :: BinOp -> String
cmmBinOp PLUS = "+"
cmmBinOp MINUS = "-"
cmmBinOp MUL = "*"
cmmBinOp DIV = "/"
cmmBinOp AND = "&"
cmmBinOp OR = "|"
cmmBinOp LSHIFT = "<<"
cmmBinOp RSHIFT = ">>"
cmmBinOp ARSHIFT = error "ARSHIFT unsupported"
cmmBinOp XOR = "^"
cmmRelOp :: RelOp -> String
cmmRelOp EQ = "=="
cmmRelOp NE = "!="
cmmRelOp LT = "<"
cmmRelOp GT = ">"
cmmRelOp LE = "<="
cmmRelOp GE = ">="
cmmRelOp ULT = error "ULT unsupported"
cmmRelOp ULE = error "ULE unsupported"
cmmRelOp UGT = error "UGT unsupported"
cmmRelOp UGE = error "UGE unsupported"
declVar :: Temp -> Doc -> Doc
declVar t e = text "int32_t" <+> text (show t) <+> equals <+> e <> semi
param :: Integer -> Temp
param i = mkNamedTemp $ "p" ++ show i
-- returns (s,e), where
-- s is a C statement and e is a pure C-expression
cmmExp :: MonadNameGen m => Exp -> m (Doc, Doc)
cmmExp (CONST i) = return (empty, integer (fromIntegral i))
cmmExp (NAME l) = return (empty, text "(int32_t)" <> text l)
cmmExp (TEMP t) = return (empty, text (show t))
cmmExp (PARAM i) = return (empty, text $ show $ param i)
cmmExp (BINOP o e1 e2) =
do (s, [ce1, ce2]) <- cmmExpSeq [e1, e2]
return (s, parens (ce1 <+> text (cmmBinOp o) <+> ce2))
cmmExp (MEM e) =
do (s, ce) <- cmmExp e
return (s, text "MEM" <> parens ce)
cmmExp (CALL (NAME l) as) =
do (sl, cel) <- cmmExpSeq as
t <- nextTemp
return (sl $$ declVar t (text l <> (parens $ hsep $ punctuate comma cel)),
text $ show t)
cmmExp (CALL _ _) = error "CALL only implemented for named functions"
cmmExp (ESEQ s e) =
do cs <- cmmStm s
(cse, ce) <- cmmExp e
return (cs $$ cse, ce)
cmmExpSeq :: MonadNameGen m => [Exp] -> m (Doc, [Doc])
cmmExpSeq [] = return (empty, [])
cmmExpSeq (e:es) =
do (cs, ce) <- cmmExp e
(css, ces) <- cmmExpSeq es
if isEmpty css then
return (cs $$ css, ce:ces)
else
do t <- nextTemp
return (vcat [cs, declVar t ce, css]
, text (show t) : ces)
cmmStmWithComments :: MonadNameGen m => Stm -> m Doc
cmmStmWithComments (SEQ ss) =
do css <- mapM cmmStmWithComments ss
return $ vcat css
cmmStmWithComments s =
do cs <- cmmStm s
return $ text ("/* " ++ show s ++ " */") $$ cs
cmmStm :: MonadNameGen m => Stm -> m Doc
cmmStm (MOVE (TEMP t) s) =
do (ss, cs) <- cmmExp s
return $ ss $$ (text (show t) <+> equals <+> cs <> semi)
cmmStm (MOVE (PARAM i) s) =
do (ss, cs) <- cmmExp s
return $ ss $$ (text (show (param i)) <+> equals <+> cs <> semi)
cmmStm (MOVE (MEM d) s) =
do (sd, cd) <- cmmExp d
t <- nextTemp
(ss, cs) <- cmmExp s
return $ vcat [ sd, declVar t cd, ss
, text "MEM" <> parens (text $ show t) <+> equals <+> cs <> semi]
cmmStm (MOVE (ESEQ ds d) s) = cmmStm (SEQ [ds, MOVE d s])
cmmStm e@(MOVE _ _) = error $ "Left-hand side of MOVE must be TEMP, MEM or ESEQ: " ++ show e
cmmStm (JUMP (NAME l) _) = return $ text "goto" <+> text l <> semi
cmmStm (JUMP _ _) = error "JUMP only implemented for named locations"
cmmStm (CJUMP r e1 e2 lt lf) =
do (s, [ce1, ce2]) <- cmmExpSeq [e1, e2]
return $ s $$
(text "if"
<+> parens (ce1 <+> text (cmmRelOp r) <+> ce2)
<+> text "goto" <+> text lt <> semi
<+> text "else"
<+> text "goto" <+> text lf <> semi)
cmmStm (SEQ ss) =
do css <- mapM cmmStm ss
return $ vcat css
cmmStm (LABEL l) = return $ text l <> colon <+> semi
cmmMethod :: Method -> Doc
cmmMethod m =
runNameGen $
let params = map param [0 .. nparams m - 1]
paramdecls = parens $ hsep $ punctuate comma
$ map (\p -> text "int32_t" <+> text (show p)) params
headtext = text "int32_t" <+> text (methodname m) <+> paramdecls
temps = tempsStm (SEQ $ body m) `Set.union` Set.singleton (returnTemp m)
locvars = Set.toList temps
locvardecls =
if null locvars then empty
else text "int32_t" <+> hsep (punctuate comma (map (text.show) locvars))
<> semi
in do avoid (Set.toList temps ++ params)
bodytext <- cmmStmWithComments (SEQ $ body m)
return $ vcat [ headtext <+> lbrace
, locvardecls
, bodytext
, text ("return " ++ show (returnTemp m)) <> semi
, rbrace
, text ""
]
cmmDecl :: Method -> Doc
cmmDecl m =
let params = map param [0 .. nparams m - 1]
paramdecls = parens $ hsep $ punctuate comma
$ map (\p -> text "int32_t" <+> text (show p)) params
in (text "int32_t" <+> text (methodname m) <+> paramdecls <+> semi) $$ text ""
cmmDoc :: Prg -> Doc
cmmDoc prg =
vcat $ [ text "#include <stdint.h>"
, text "#define MEM(x) *((int32_t*)(x))"
, text ""
, text "int32_t L_halloc(int32_t size);"
, text "int32_t L_println_int(int32_t n);"
, text "int32_t L_write(int32_t n);"
, text "int32_t L_read();"
, text "int32_t L_raise(int32_t rc);"
]
++ map cmmDecl (methods prg)
++ map cmmMethod (methods prg)
Lmain(2) {
MOVE(TEMP(t2), CALL(NAME(L_println_int), CALL(NAME(LAA$run), ESEQ(SEQ(SEQ(MOVE(TEMP(t3), CALL(NAME(L_halloc), CONST(4))), SEQ() ) , MOVE(MEM(TEMP(t3)), CONST(0))) , TEMP(t3)))))
JUMP(NAME(L$$0), L$$0)
SEQ(LABEL(L$$1), MOVE(TEMP(t1), CALL(NAME(L_raise), CONST(-17))), JUMP(NAME(L$$1), L$$1))
LABEL(L$$0)
MOVE(TEMP(t0), CONST(0))
return t0
}
LAA$run(1) {
SEQ(SEQ(MOVE(TEMP(t6), ESEQ(SEQ(MOVE(TEMP(t8), CONST(2)), MOVE(TEMP(t7), CALL(NAME(L_halloc), BINOP(MUL, BINOP(PLUS, TEMP(t8), CONST(1)), CONST(4)))), MOVE(MEM(TEMP(t7)), TEMP(t8))) , TEMP(t7))), SEQ(SEQ(MOVE(TEMP(t9), TEMP(t6)), CJUMP(GE, CONST(0), MEM(TEMP(t9)), L$$3, L$$4), LABEL(L$$4)) , MOVE(MEM(BINOP(PLUS, TEMP(t9), CONST(4))), CONST(5))) ) , SEQ(SEQ(MOVE(TEMP(t10), TEMP(t6)), CJUMP(GE, CONST(1), MEM(TEMP(t10)), L$$3, L$$5), LABEL(L$$5)) , MOVE(MEM(BINOP(PLUS, TEMP(t10), CONST(8))), CONST(10))) )
JUMP(NAME(L$$2), L$$2)
SEQ(LABEL(L$$3), MOVE(TEMP(t5), CALL(NAME(L_raise), CONST(-17))), JUMP(NAME(L$$3), L$$3))
LABEL(L$$2)
MOVE(TEMP(t4), ESEQ(SEQ(MOVE(TEMP(t11), TEMP(t6)), CJUMP(GE, CONST(0), MEM(TEMP(t11)), L$$3, L$$6), LABEL(L$$6)) , MEM(BINOP(PLUS, TEMP(t11), CONST(4)))))
return t4
}
LAA$run(1){
LABEL(t22)
MOVE(TEMP(t2), CONST(2))
MOVE(TEMP(t3), CALL(NAME(L_halloc), BINOP(MUL, BINOP(PLUS, TEMP(t2), CONST(1)), CONST(4))))
MOVE(MEM(TEMP(t3)), TEMP(t2))
MOVE(TEMP(arr), TEMP(t3))
MOVE(TEMP(t6), TEMP(arr))
CJUMP(GE, CONST(0), MEM(TEMP(t6)), LAA$run$raise, t5)
LABEL(t5)
MOVE(MEM(BINOP(PLUS, TEMP(t6), CONST(4))), CONST(5))
MOVE(TEMP(t8), TEMP(arr))
CJUMP(GE, CONST(1), MEM(TEMP(t8)), LAA$run$raise, t7)
LABEL(t7)
MOVE(MEM(BINOP(PLUS, TEMP(t8), CONST(8))), CONST(10))
JUMP(NAME(t10), t10)
LABEL(t10)
MOVE(TEMP(t13), TEMP(arr))
CJUMP(GE, CONST(0), MEM(TEMP(t13)), LAA$run$raise, t12)
LABEL(t12)
MOVE(TEMP(t14), MEM(BINOP(PLUS, TEMP(t13), CONST(4))))
JUMP(NAME(t21), t21)
LABEL(LAA$run$raise)
MOVE(TEMP(t11), CALL(NAME(L_raise), CONST(-1)))
JUMP(NAME(t10), t10)
LABEL(t21)
return t14
}
Lmain(1){
LABEL(t24)
MOVE(TEMP(t19), CALL(NAME(L_halloc), CONST(4)))
MOVE(TEMP(t20), CALL(NAME(LAA$run), TEMP(t19)))
MOVE(TEMP(t17), CALL(NAME(L_println_int), TEMP(t20)))
MOVE(TEMP(t18), CONST(0))
JUMP(NAME(t23), t23)
LABEL(t23)
return t18
}
// Benutzung:
//
// ./tree2c fact.tree > fact.c
// gcc -m32 -o fact fact.c runtime.c
// ./fact
// Methodenname(Anzahl der Parameter)
Lmain(1) {
// Hier eine Liste von Stms, einfach hintereinander geschrieben
MOVE(TEMP(t0), CALL(NAME(L_println_int),
CALL(NAME(LFac$ComputeFac),
CALL(NAME(L_halloc), CONST(4)), CONST(10))
))
MOVE(TEMP(t1),
ESEQ(MOVE(TEMP(t42), CONST(1)),
MOVE(TEMP(t2), BINOP(MINUS, CONST(1), TEMP(t42))),
TEMP(t2)))
// Rueckgabe muss ein Temporary sein
return t1
}
LFac$ComputeFac(2) {
CJUMP(LT, PARAM(1), CONST(1), L$0, L$1)
LABEL(L$1)
MOVE(TEMP(t5), BINOP(MUL, PARAM(1),
CALL(NAME(LFac$ComputeFac), PARAM(0), BINOP(MINUS, PARAM(1), CONST(1)))))
JUMP(NAME(L$2), L$2)
LABEL(L$0)
MOVE(TEMP(t5), CONST(1))
LABEL(L$2)
MOVE(TEMP(t4), TEMP(t5))
return t4
}
LFibClass$nfib(2){
LABEL(t20)
CJUMP(GE, PARAM(1), CONST(2), t0, t1)
LABEL(t1)
MOVE(TEMP(res), CONST(1))
JUMP(NAME(t4), t4)
LABEL(t4)
JUMP(NAME(t7), t7)
LABEL(t7)
MOVE(TEMP(t9), TEMP(res))
JUMP(NAME(t19), t19)
LABEL(t0)
MOVE(TEMP(t14), CALL(NAME(LFibClass$nfib), PARAM(0), BINOP(MINUS, PARAM(1), CONST(1))))
MOVE(TEMP(t16), TEMP(t14))
MOVE(TEMP(t15), CALL(NAME(LFibClass$nfib), PARAM(0), BINOP(MINUS, PARAM(1), CONST(2))))
MOVE(TEMP(res), BINOP(PLUS, BINOP(PLUS, TEMP(t16), TEMP(t15)), CONST(1)))
JUMP(NAME(t4), t4)
LABEL(t19)
return t9
}
Lmain(1){
LABEL(t22)
MOVE(TEMP(t17), CALL(NAME(L_halloc), CONST(4)))
MOVE(TEMP(t18), CALL(NAME(LFibClass$nfib), TEMP(t17), CONST(20)))
MOVE(TEMP(t12), CALL(NAME(L_println_int), TEMP(t18)))
MOVE(TEMP(t13), CONST(0))
JUMP(NAME(t21), t21)
LABEL(t21)
return t13
}
{
module Lex where
import Tokens
}
%wrapper "posn"
$digit = 0-9 -- digits
$alpha = [a-zA-Z] -- alphabetic characters
$letter = $alpha
tokens :-
$white+;
"//".* ;
" { mkToken Quote }
"(" { mkToken LPar }
")" { mkToken RPar }
"{" { mkToken LBrace }
"}" { mkToken RBrace }
"," { mkToken Comma }
"-" { mkToken Minus }
MOVE { mkToken KwMOVE }
NAME { mkToken KwNAME }
LABEL { mkToken KwLABEL }
TEMP { mkToken KwTEMP }
PARAM { mkToken KwPARAM }
CONST { mkToken KwCONST }
ESEQ { mkToken KwESEQ }
MEM { mkToken KwMEM }
BINOP { mkToken KwBINOP }
SEQ { mkToken KwSEQ }
CALL { mkToken KwCALL }
JUMP { mkToken KwJUMP }
CJUMP { mkToken KwCJUMP }
MUL { mkToken KwMUL }
PLUS { mkToken KwPLUS }
MINUS { mkToken KwMINUS }
DIV { mkToken KwDIV }
AND { mkToken KwAND }
OR { mkToken KwOR }
XOR { mkToken KwXOR }
LSHIFT { mkToken KwLSHIFT }
RSHIFT { mkToken KwRSHIFT }
ARSHIFT { mkToken KwARSHIFT }
EQ { mkToken KwEQ }
NE { mkToken KwNE }
LT { mkToken KwLT }
GT { mkToken KwGT }
LE { mkToken KwLE }
GE { mkToken KwGE }
ULT { mkToken KwULT }
UGT { mkToken KwUGT }
ULE { mkToken KwULE }
UGE { mkToken KwUGE }
return { mkToken KwReturn }
$digit+ { \p s -> mkToken (Const (read s)) p s }
$letter [$letter $digit \_ \' \$]*
{ \p s -> mkToken (Id s) p s }
module Main where
import System.Environment
import System.Console.GetOpt
import Text.PrettyPrint
import Lex
import Parse
-- import Names
-- import Tree
import Cmm
usage :: [String] -> IO a
usage _ = ioError (userError header)
where header = "Usage: tree2c <file>"
readFileFromCmdLine :: [String] -> IO String
readFileFromCmdLine argv = do
let (_, ns, _) = getOpt Permute [] argv
case ns of
[] -> getContents
[prgFile] -> readFile prgFile
_ -> usage [""]
main :: IO ()
main = do
cmdLine <- getArgs
input <- readFileFromCmdLine cmdLine
let defs = parse (alexScanTokens input)
let cmm = cmmDoc defs
putStrLn $ render cmm
TARGET = tree2c
GHC = ghc
GHC_OPTS =
$(TARGET) : Tree.hs Cmm.hs Lex.hs Main.hs Names.hs Parse.hs Tokens.hs
$(GHC) $(GHC_OPTS) -o $@ --make Main.hs
all: $(TARGET)
lexer: $(filter-out Main%,$(filter-out Pars%,$(OBJS)))
$(GHC) $(GHC_OPTS) -o $@ $^
%.hs: %.y
happy -iGRM.LOG $<
%.hs: %.x
alex $<
%.o: %.hs
$(GHC) $(GHC_OPTS) -c -o $@ $<
clean:
@rm -f *.o *.hi Lex.hs Parse.hs GRM.LOG $(TARGET)
# EOF
{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances, TypeSynonymInstances, FlexibleInstances #-}
{-
- Representation of names of temps and labels
-}
module Names(
Temp, Label, mkLabel, mkNamedTemp,
MonadNameGen(..),
NameGen, runNameGen,
NameGenT, runNameGenT
) where
import Control.Monad.State
import Control.Monad.Identity
-- | A type to represent temporaries.
--
-- The constructors are private. The usual way of obtaining a
-- temporary is to generate it freshly using 'nextTemp' from the name
-- generation monad 'MonadNameGen'.
data Temp = NamedTemp String
| Temp Int deriving (Eq, Ord)
instance Show Temp where
show (Temp i) = "t" ++ show i
show (NamedTemp s) = s
-- | Generates a temporary with a fixed name 's'. This function must
-- be used with care, to avoid name clashes. The function 'nextTemp'
-- guarantees freshness only relative to the names it has generated
-- itself.
mkNamedTemp :: String -> Temp
mkNamedTemp = NamedTemp
-- | A type of symbolic labels.
type Label = String
-- | Constructs a label with a fixed name. Names containing the
-- character '$' are reserved for internal use.
mkLabel :: String -> Label
mkLabel l | '$' `elem` l =
error $ "Label \"" ++ l ++ "\" contains reserver character '$'."
| otherwise = 'L':l
-- | Name generation monad
class Monad m => MonadNameGen m where
-- | Generates a fresh temporary. The returned temporary is
-- guaranteed to be different from all the ones returned previously
-- and the ones give to 'avoid'.
nextTemp :: m Temp
-- | Declare that a list of temps must be avoided by 'nextTemp'.
-- 'nextTemp' will not return a temp that was passed to 'avoid'.
avoid :: [Temp] -> m ()
-- | Generates a fresh label.
nextLabel :: m Label
-- | Name generation monad transformer.
newtype NameGenT m a = NameGenT (StateT ([Temp], [Label]) m a)
deriving (Functor, Applicative, Monad, MonadTrans)
-- | Name generation monad.
type NameGen a = NameGenT Identity a
runNameGen :: NameGen a -> a
runNameGen = runIdentity . runNameGenT
instance (Monad m) => MonadNameGen (NameGenT m) where
nextTemp = NameGenT $ do (t:ts, ls) <- get; put (ts, ls); return t
avoid av =
NameGenT $
do (ts, ls) <- get
put (filter (\t -> not (show t `elem` (map show av))) ts, ls)
return ()
nextLabel = NameGenT $ do (ts, l:ls) <- get; put (ts, ls); return l
runNameGenT :: (Monad m) => NameGenT m a -> m a
runNameGenT (NameGenT x) =
evalStateT x ([Temp i | i<-[0..]], ["L_" ++ (show i) | i <- [(0::Int)..]])
{
module Parse where
import Data.Int
import Lex
import qualified Tokens
import Names
import Tree
}
%tokentype { (Tokens.Token AlexPosn) }
%name parse
%token
'"' { Tokens.Token Tokens.Quote _ }
'(' { Tokens.Token Tokens.LPar _ }
')' { Tokens.Token Tokens.RPar _ }
'{' { Tokens.Token Tokens.LBrace _ }
'}' { Tokens.Token Tokens.RBrace _ }
',' { Tokens.Token Tokens.Comma _ }
'-' { Tokens.Token Tokens.Minus _ }
MOVE { Tokens.Token Tokens.KwMOVE _ }
NAME { Tokens.Token Tokens.KwNAME _ }
LABEL { Tokens.Token Tokens.KwLABEL _ }
CONST { Tokens.Token Tokens.KwCONST _ }
ESEQ { Tokens.Token Tokens.KwESEQ _ }
TEMP { Tokens.Token Tokens.KwTEMP _ }
PARAM { Tokens.Token Tokens.KwPARAM _ }
MEM { Tokens.Token Tokens.KwMEM _ }
BINOP { Tokens.Token Tokens.KwBINOP _ }
SEQ { Tokens.Token Tokens.KwSEQ _ }
CALL { Tokens.Token Tokens.KwCALL _ }
JUMP { Tokens.Token Tokens.KwJUMP _ }
CJUMP { Tokens.Token Tokens.KwCJUMP _ }
MUL { Tokens.Token Tokens.KwMUL _ }
PLUS { Tokens.Token Tokens.KwPLUS _ }
MINUS { Tokens.Token Tokens.KwMINUS _ }
DIV { Tokens.Token Tokens.KwDIV _ }
AND { Tokens.Token Tokens.KwAND _ }
OR { Tokens.Token Tokens.KwOR _ }
XOR { Tokens.Token Tokens.KwXOR _ }
LSHIFT { Tokens.Token Tokens.KwLSHIFT _ }
RSHIFT { Tokens.Token Tokens.KwRSHIFT _ }
ARSHIFT { Tokens.Token Tokens.KwARSHIFT _ }
EQ { Tokens.Token Tokens.KwEQ _ }
NE { Tokens.Token Tokens.KwNE _ }
LT { Tokens.Token Tokens.KwLT _ }
GT { Tokens.Token Tokens.KwGT _ }
LE { Tokens.Token Tokens.KwLE _ }
GE { Tokens.Token Tokens.KwGE _ }
ULT { Tokens.Token Tokens.KwULT _ }
UGT { Tokens.Token Tokens.KwUGT _ }
ULE { Tokens.Token Tokens.KwULE _ }
UGE { Tokens.Token Tokens.KwUGE _ }
return { Tokens.Token Tokens.KwReturn _ }
integer { Tokens.Token (Tokens.Const $$) _ }
identifier { Tokens.Token (Tokens.Id $$) _ }
%%
Prg :: { (Prg) }
Prg:
MethodList { Prg { methods = $1 } }
MethodList :: { [Method] }
MethodList:
{- empty -} {[]}
| Method MethodList { $1:$2 }
Method :: { Method }
Method:
identifier '(' integer ')' '{' Stms return identifier '}'
{ Method { methodname = $1, nparams = $3, body = $6, returnTemp = mkNamedTemp $8 } }
Stms :: { [Tree.Stm] }
Stms:
{ [] }
| Stm Stms { $1:$2 }
Stm :: { Tree.Stm }
Stm:
MOVE '(' Exp ',' Exp ')' { Tree.MOVE $3 $5 }
| JUMP '(' Exp ',' LabelList ')' { Tree.JUMP $3 $5 }
| CJUMP '(' Rel ',' Exp ',' Exp ',' identifier ',' identifier ')'
{ Tree.CJUMP $3 $5 $7 $9 $11 }
| SEQ '(' Seq ')' { Tree.SEQ $3 }
| LABEL '(' identifier ')' { Tree.LABEL $3 }
|'(' Stm ')' { $2 }
Exp :: { Tree.Exp }
Exp:
NAME '(' Label ')' { Tree.NAME $3 }
| TEMP '(' Temp ')' { Tree.TEMP (mkNamedTemp $3) }
| PARAM '(' integer ')' { Tree.PARAM $3 }
| CONST '(' Integer ')' { Tree.CONST (asInt32 $3) }
| BINOP '(' Op ',' Exp ',' Exp ')' { Tree.BINOP $3 $5 $7 }
| MEM '(' Exp ')' { Tree.MEM $3 }
| CALL '(' Exp ')' { Tree.CALL $3 [] }
| CALL '(' Exp ',' Exps ')' { Tree.CALL $3 $5 }
| ESEQ '(' ESeq ')' { let (s,e) = $3 in Tree.ESEQ (Tree.SEQ s) e }
| '(' Exp ')' { $2 }
Integer:
integer { $1 }
| '-' integer { 0-$2 }
| '(' Integer ')' { $2 }
Temp:
identifier { $1 }
| '(' Temp ')' { $2 }
Label:
identifier { $1 }
| '"' identifier '"' { $2 }
| '(' Label ')' { $2 }
ESeq:
Exp { ([], $1) }
| Stm ESeq1 { let (s,e)=$2 in ($1:s, e) }
ESeq1:
',' Exp { ([], $2)}
| ',' Stm ESeq1 { let (s,e)=$3 in ($2:s, e) }
Seq:
{ [] }
| Stm Seq1 { $1:$2 }
Seq1:
{ [] }
| ',' Stm Seq1 { $2:$3 }
Exps :: { [Tree.Exp] }
Exps: Exp { [$1] }
| Exp ',' Exps { $1:$3 }
LabelList :: { [Label] }
LabelList: { [] }
| identifier LabelList0 { $1:$2 }
| '(' LabelList ')' { $2 }
LabelList0 :: { [Label] }
LabelList0: { [] }
| ',' identifier LabelList0 { $2:$3 }
Op :: { Tree.BinOp }
Op:
MUL { Tree.MUL }
| PLUS { Tree.PLUS }
| MINUS { Tree.MINUS }
| DIV { Tree.DIV }
| AND { Tree.AND }
| OR { Tree.OR }
| XOR { Tree.XOR }
| LSHIFT { Tree.LSHIFT }
| RSHIFT { Tree.RSHIFT }
| ARSHIFT { Tree.ARSHIFT }
| '(' Op ')' { $2 }
Rel :: { Tree.RelOp }
Rel:
EQ { Tree.EQ }
| NE { Tree.NE }
| LT { Tree.LT }
| GT { Tree.GT }
| LE { Tree.LE }
| GE { Tree.GE }
| ULT { Tree.ULT }
| UGT { Tree.UGT }
| ULE { Tree.ULE }
| UGE { Tree.UGE }
| '(' Rel ')' { $2 }
{
asInt32 :: Integer -> Int32
asInt32 x = if x == fromIntegral y then y
else error $ "Parse error: constant " ++ show x
++ " does not fit in 32 bits."
where y = (fromIntegral x :: Int32)
happyError :: [Tokens.Token AlexPosn] -> a
happyError tks = error ("Parse error at " ++ lcn ++ "\n")
where
lcn = case tks of
[] -> "end of file"
(tk : _) -> "line " ++ show l ++ ", column " ++ show c
where AlexPn _ l c = Tokens.token_pos tk
}
# tree2c
`tree2c` übersetzt Programme der tree-Zwischensprache in C-Programme.
## Installation
Für die Installation wird GHC benötigt. Die nötigen Dateien kann man
einfach automatisch mit Stack (https://www.haskellstack.org/) installieren.
Dann kann `tree2c` einfach mit
```
stack install
```
installiert werden.
Installation mit Cabal ist auch möglich:
```
cabal install
```
## Verwendung
`tree2c` liest die Datei, die im ersten Argument angegeben ist,
übersetzt sie nach C und schreibt das Ergebnis nach stdout. Wenn
kein erstes Argument angegeben ist, wird die Eingable von stdin
gelesen. Das produzierte C-programm kann zusammen mit der Datei
`runtime.c` zu einer ausführbaren Datei übersetzt werden.
```
tree2c fact.tree > fact.c
gcc -m32 -o fact fact.c runtime.c
./fact
```
Das flag -m32 ist wichtig, da wir hier von einer 32-bit Architektur
ausgehen.
module Tokens where
data TokenKind = Quote
| LPar
| RPar
| LBrace
| RBrace
| Comma
| Minus
| KwMOVE
| KwNAME
| KwLABEL
| KwTEMP
| KwPARAM
| KwCONST
| KwESEQ
| KwMEM
| KwBINOP
| KwSEQ
| KwCALL
| KwJUMP
| KwCJUMP
| KwMUL
| KwDIV
| KwPLUS
| KwMINUS
| KwAND
| KwOR
| KwXOR
| KwLSHIFT
| KwRSHIFT
| KwARSHIFT
| KwEQ
| KwNE
| KwLT
| KwGT
| KwLE
| KwGE
| KwULT
| KwUGT
| KwULE
| KwUGE
| KwReturn
| Const Integer
| Label String
| Register String
| Id String
deriving (Eq, Read, Show)
data Token a = Token { kind :: TokenKind
, token_pos :: a
}
mkToken :: TokenKind -> a -> b -> Token a
mkToken k p _ = Token { kind = k, token_pos = p }
module Tree where
import Prelude hiding (EQ,GT,LT)
import Data.List
import Data.Int
import Names
data Prg = Prg { methods :: [Method] }
data Method = Method { methodname :: String
, nparams :: Integer
, body :: [Stm]
, returnTemp :: Temp
}
data Exp = CONST Int32
| NAME Label
| TEMP Temp
| PARAM Integer
| BINOP BinOp Exp Exp
| MEM Exp
| CALL Exp [Exp]
| ESEQ Stm Exp
deriving Eq
data Stm = MOVE Exp Exp
| JUMP Exp [Label]
| CJUMP RelOp Exp Exp Label Label
| SEQ [Stm]
| LABEL Label
deriving Eq
data BinOp = PLUS
| MINUS
| MUL
| DIV
| AND
| OR
| LSHIFT
| RSHIFT
| ARSHIFT
| XOR
deriving (Eq, Show)
data RelOp = EQ
| NE
| LT
| GT
| LE
| GE
| ULT
| ULE
| UGT
| UGE
deriving (Eq, Show)
-- The following Show instances shold produce tree programs
-- that are parseable using tree2c.
instance Show Prg where
show prg = intercalate "\n\n" $ map show (methods prg)
instance Show Method where
show m = methodname m ++ "(" ++ show (nparams m) ++ ") {\n "
++ intercalate "\n " (map show (body m))
++ "\n return " ++ show (returnTemp m)
++ "\n}"
instance Show Exp where
show (CONST i) = "CONST(" ++ show i ++ ")"
show (NAME l) = "NAME(" ++ l ++ ")"
show (TEMP t) = "TEMP(" ++ show t ++ ")"
show (PARAM i) = "PARAM(" ++ show i ++ ")"
show (BINOP o e1 e2) = "BINOP(" ++ show o ++ ", "
++ show e1 ++ ", " ++ show e2 ++ ")"
show (MEM e) = "MEM(" ++ show e ++ ")"
show (CALL e es) = "CALL(" ++ intercalate ", " (map show (e:es)) ++ ")"
show (ESEQ s e) = "ESEQ(" ++ show s ++ ", " ++ show e ++ ")"
instance Show Stm where
show (MOVE e1 e2) = "MOVE(" ++ show e1 ++ ", " ++ show e2 ++ ")"
show (JUMP e ls) = "JUMP(" ++ show e ++ ", " ++ intercalate ", " ls ++ ")"
show (CJUMP r e1 e2 l1 l2) = "CJUMP(" ++ show r ++ ", "
++ show e1 ++ ", " ++ show e2 ++ ", "
++ l1 ++ ", " ++ l2 ++ ")"
show (SEQ ss) = "SEQ(" ++ intercalate ", " (map show ss) ++ ")"
show (LABEL l1) = "LABEL(" ++ l1 ++ ")"
/*
Runtime library, for use in compiled MiniJava programs
*/
#include <inttypes.h>
#include <stdio.h>
#include <stdlib.h>
extern int32_t Lmain(int32_t);
// Allocate <size> bytes of memory space and initialise it with zeroes
int32_t L_halloc(int32_t size) { return (int32_t)calloc(size, 1); }
// Print an integer to the standard output
int32_t L_println_int(int32_t n) {
printf("%" PRId32 "\n", n);
return 0;
}
// Write character to standard output
int32_t L_write(int32_t n) {
putchar(n);
return 0;
}
// Read character from standard input