%if false  
  Copyright (c) 2009, ETH Zurich.
  All rights reserved.
  
  This file is distributed under the terms in the attached LICENSE file.
  If you do not find this file, copies can be found by writing to:
  ETH Zurich D-INFK, Universitaetstrasse 6, CH-8092 Zurich. Attn: Systems Group.
%endif

%include polycode.fmt

%if false

> module IL.Paka.Compile where
> import Prelude hiding ((<>))
> import Text.PrettyPrint.HughesPJ as Pprinter 
> import qualified Data.Map as Map
> import Data.List

> import PureExpressions

> import IL.Paka.Syntax

%endif

\section{Translating @IL.Paka@ to @C@}
\label{sec:il_paka_compile}

This file could as well be called @./IL/C/C.lhs@ but I felt guilty of
introducing yet another confusing IL. So, it is here but feel free to
move it around.

\subsection{Printing types and expressions}

Because we are good kids, we create a type-class called
|Compileable|. A data-type satisfying |Compileable| can be
pretty-printed to something vaguely looking like a bunch of C code.

> class Compileable a where
>     toC :: a -> Doc

Part of the |Compileable| class are FoF's types |TypeExpr| and FoF's
pure expressions |PureExpr|.

There is nothing but boiler plate code to get the job done for pure
expressions:

> instance Compileable PureExpr where
>     toC (Quote s) = doubleQuotes $ text s 
>     toC Void = empty
>     toC (CLInteger _ _ x) = integer x
>     toC (CLFloat x) = Pprinter.float x
>
>     toC (CLRef origin (TPointer _ Avail) loc) = toC loc
>     toC (CLRef origin (TPointer _ Read) loc) = char '*' <> toC loc
>     toC (CLRef origin _ loc) = toC loc
>
>     toC (Unary op x) = parens $ toC op <+> toC x 
>     toC (Binary op x y) = parens $ toC x <+> toC op <+> toC y
>     toC (Sizeof t) = text "sizeof" <> (parens $ toC t)
>     toC (Test t1 t2 t3) = parens $ 
>                           parens (toC t1) <+> char '?' <+> 
>                           parens (toC t2) <+> char ':' <+>
>                           parens (toC t3)
>     toC (Cast t e) = parens $ parens (toC t) <+> toC e
>
> instance Compileable UnaryOp where
>     toC Minus = char '-'
>     toC Complement = char '~'
>     toC Negation = char '!'     
>
> instance Compileable BinaryOp where
>     toC Plus = text "+"
>     toC Sub = text "-"
>     toC Mul = text "*"
>     toC Div = text "/"
>     toC Mod = text "%"
>     toC Shl = text "<<"
>     toC Shr = text ">>"
>     toC AndBit = text "&"
>     toC OrBit = text "|"
>     toC XorBit = text "^"
>     toC Le = text "<"
>     toC Leq = text "<="
>     toC Ge = text ">"
>     toC Geq = text ">="
>     toC Eq = text "=="
>     toC Neq = text "!="

And similarly for types:

> instance Compileable TypeExpr where
>     toC (TInt Signed TInt8) = text "int8_t"
>     toC (TInt Signed TInt16) = text "int16_t"
>     toC (TInt Signed TInt32) = text "int32_t"
>     toC (TInt Signed TInt64) = text "int64_t"
>     toC (TInt Unsigned TInt8) = text "uint8_t"
>     toC (TInt Unsigned TInt16) = text "uint16_t"
>     toC (TInt Unsigned TInt32) = text "uint32_t"
>     toC (TInt Unsigned TInt64) = text "uint64_t"
>     toC TFloat = text "float"
>     toC TVoid = text "void"
>     toC TChar = text "char"                
>     toC (TArray DynamicArray typ) = toC typ <> char '*'
>     toC (TArray (StaticArray size) typ) = toC typ <> char '*'
>     toC (TPointer x _) = toC x <> char '*'
>     toC (TStruct DynamicStruct name fields) = text "struct " <+> text name <+> char '*'
>     toC (TStruct StaticStruct name fields) = text "struct " <+> text name
>     toC (TUnion DynamicUnion name fields) = text "union " <+> text name <+> char '*'
>     toC (TUnion StaticUnion name fields) = text "union " <+> text name 
>     toC (TCompPointer name) = text "uintptr_t"
>     toC (TTypedef typ name) = text name
>     toC (TEnum name _) = text "enum" <+> text name                    

The picky reader will have noticed the absence of printer for function
types. This is hardly a problem at the moment because we do not
support function pointers, so we are not going to declare function
types anytime soon. Note that this argument might well be circular: if
we do not support function pointers, it is because it is a pain to
write their type, among other things (if I remember correctly). Oh
well.

Printing variable names is dead easy:

> instance Compileable VarName where
>     toC x = text $ mkPakaVarName x

\subsection{Names, everywhere}

I am not very proud of that section, and of the way I abused these
functions in @IL/Paka/Paka.lhs@. I beg your pardon for that. There
\emph{must} some abstraction to bust here but I was not able to catch
it.

Provided a @FoF@ |VarName|, we turn it into a string with a bit of
Hungarianism, but very little. Why this function is called
|mkPakaVarName| when it does not deal with |PakaVarName|? I have no
clue. 

> mkPakaVarName :: VarName -> String
> mkPakaVarName (Generated x) = "_" ++ x
> mkPakaVarName (Provided x) = x
> mkPakaVarName (Inherited y x) = mkPakaVarName x ++ "__" ++ show y

Then, we have to functions turning a |PureExpr| into a
|PakaVarName|. |PakaValName| provides you with the value described by
the |PureExpr|. On the other hand, |PakaVarName| works one level below
and gives you the value contained in the |PureExpr|. 

I have to admit that I am not myself convinced by this
explanation. Basically, I would have to look at the former code, the
|typeOf|, |deref|, |readOf| functions, and the new code. Then, I might
be able to make more sense of that. However, intrinsically, references
are a non-sense.

> pakaValName :: PureExpr -> PakaVarName
> pakaValName (CLRef origin (TPointer _ Avail) loc) = Var $! mkPakaVarName loc
> pakaValName (CLRef origin (TPointer _ Read) loc) = Ptr $! Var $ mkPakaVarName loc
> pakaValName (CLRef _ _ loc) = Var $! mkPakaVarName loc
> pakaValName x = K x
>
> pakaVarName :: PureExpr -> PakaVarName
> pakaVarName (CLRef origin (TPointer _ Avail) loc) = Deref (Var $ mkPakaVarName loc)
> pakaVarName (CLRef origin (TPointer _ Read) loc) = Var $ mkPakaVarName loc
> pakaVarName (CLRef _ _ loc) = Var $ mkPakaVarName loc
> pakaVarName x = K x

Finally, we need to be able to print these |PakaVarName| into meaning
C code. Here you go.

> instance Compileable PakaVarName where
>     toC (Deref x) = char '&' <> toC x
>     toC (Var x) = text x
>     toC (Ptr x) = char '*' <> toC x
>     toC (Complex _) = error "Cannot convert a Complex var name to C"
>     toC (K x) = toC x


\subsection{Generating C}

The following is a small addendum to the pretty-printer library. We
don't know why it is not defined there. 

> vcat' :: [Doc] -> Doc
> vcat' [] = empty 
> vcat' (x:xs) = l `seq` r `seq` r
>     where l = vcat' xs
>           r = x $+$ l

For once, I will do a bottom-up presentation. So, I will describe the
implementation of pretty-printers from |Paka| code to C.

The first step consists in printing closing terms:

> pprintClosing :: PakaClosing -> Doc
> pprintClosing (PReturn e) = text "return" <+> parens (toC e) <> semi
> pprintClosing PBreak = text "break"
> pprintClosing PContinue = text "continue"

Then, we print statements. As you remember, we need to build the final
code by applying the variables to the term:

> pprintStmt :: PakaStatement -> Doc
> pprintStmt (PAssign dst x srcs) = x (toC dst : map toC srcs)
> pprintStmt (PInstruction x srcs) = x (map toC srcs)

The next step consists in compiling intra-procedural code. This is
rather simple and quite directly follows from the |Paka| definitions:

> pprintPaka :: ILPaka -> Doc
> pprintPaka PVoid = empty
> pprintPaka (PClosing c) = pprintClosing c
> pprintPaka (PStatement stmt k) = 
>     pprintStmt stmt $+$ 
>     pprintPaka k
> pprintPaka (PIf cond test ifTrue ifFalse k) =
>     pprintPaka cond $+$ 
>     text "if" <+> parens (toC test) <> lbrace $+$
>         (nest 4 $! pprintPaka ifTrue) $+$
>     rbrace <+> text "else" <+> lbrace $+$
>         (nest 4 $! pprintPaka ifFalse) $+$
>     rbrace $+$ 
>     pprintPaka k
> pprintPaka (PWhile cond test loop k) =
>     pprintPaka cond $+$
>     text "while" <> parens (toC test) <> lbrace $+$
>         (nest 4 $! pprintPaka loop) $+$
>     rbrace $+$
>     pprintPaka k
> pprintPaka (PDoWhile loop cond test k) =
>     text "do" <+> lbrace $+$
>          (nest 4 $! pprintPaka loop) $+$
>     rbrace <+> text "while" <+> parens (toC test) <> semi $+$
>     pprintPaka k
> pprintPaka (PSwitch test cases defaultCase k) =
>     text "switch" <+> parens (toC test) <+> lbrace $+$
>          (nest 4 $ vcat' $ map compileCase cases) $+$
>          (nest 4 (text "default:" <+> lbrace $+$
>                        (nest 4 $! pprintPaka defaultCase) $+$
>                        rbrace)) $+$
>     rbrace $+$
>     pprintPaka k
>         where compileCase (i, code) =
>                   text "case" <+> toC i <> colon <+> lbrace $+$
>                        (nest 4 $! (pprintPaka code $+$
>                                   text "break" <> semi)) $+$
>                   rbrace

Finally, we can pretty-print a complete |PakaCode| by iterating other
each section, and, in each section, pretty-printing each element.

> pprint :: PakaCode -> Doc
> pprint code = 
>     text "/* Includes: */" $+$
>     space $+$
>     text "#include <stdint.h>" $+$
>     vcat' (extractM $ includes code) $+$
>     space $+$
>     (case Map.null $ types code of 
>        True -> empty
>        _ -> text "/* Type Declarations: */" $+$ 
>             space $+$
>             vcat' (extractM $ types code) $+$
>             vcat' (extractL $ declarations code) $+$
>             space) $+$
>     (case null $ globalVars code of
>        True -> empty
>        _ ->  text "/* Global Variables: */" $+$ 
>              space $+$
>              vcat' (map (\y -> text "static" <+> y) $
>                     extractL $ 
>                     globalVars code) $+$
>              space) $+$
>     (case Map.null $ prototypes code of
>        True -> empty
>        _ ->  text "/* Prototypes: */" $+$ 
>              space $+$
>              vcat' (extractM $ prototypes code) $+$
>              space) $+$
>     (case Map.null $ functions code of
>        True -> empty
>        _ ->  text "/* Function Definitions: */" $+$ 
>              space $+$
>              vcat' (map (\(returnT, attrs, name, args, lEnv, body) -> 
>                           returnT <+> attrs <+> text name <> parens args <+> lbrace $+$
>                           (nest 4 $ vcat' $ extractM $ localVars lEnv) $+$
>                           space $+$
>                           (nest 4 $ pprintPaka body) $+$
>                           rbrace $+$
>                           space)
>                    $ extractM
>                    $ functions code) $+$
>              space)
>     $+$ space 

We note the use of two extraction functions: these functions remove
the keys from the associative structure in use, and simply return the
content. When an order was maintained, ie. an associative list was
used, the definition order is carefully restored by reversing the
list.

> extractL :: Eq a => [(a, b)] -> [b]
> extractL = (map snd) .
>           reverse
>
> extractM :: Map.Map a b -> [b]
> extractM = Map.elems


Because we have worked very hard, we are rewarded by the right to
instantiate these |PakaCode| in the |Show|.

> instance Show PakaCode where
>     show = render . pprint