lhc-0.10: src/Grin/Stage2/Backend/C.hs
{-# LANGUAGE StandaloneDeriving, OverloadedStrings #-}
module Grin.Stage2.Backend.C
( compile
, compileFastCode
, grinToC
) where
import CompactString
import Grin.Stage2.Types
import qualified Grin.Stage2.Pretty as Grin (ppExpression)
import Text.PrettyPrint.ANSI.Leijen hiding ((</>))
import System.Process
import System.FilePath
import System.Directory
import Data.Char
import Text.Printf
import System.IO
import System.Exit
import Foreign.Storable
import qualified Data.Map as M
import Paths_lhc
compile :: Grin -> FilePath -> IO ()
compile = compile' ["--debug", "-ggdb"]
compileFastCode :: Grin -> FilePath -> IO ()
compileFastCode = compile' ["-O2"]
compile' :: [String] -> Grin -> FilePath -> IO ()
compile' gccArgs grin target
= do rts <- getDataFileName ("rts" </> "rts.c")
let cTarget = replaceExtension target "c"
copyFile rts cTarget
appendFile cTarget (show cCode)
dDir <- getDataDir
let ltmDir = dDir </> "rts/ltm/"
ltmFiles <- getDirectoryContents ltmDir
let ltmOptions = ["-I"++ltmDir, "-DXMALLOC=GC_malloc", "-DXFREE=GC_free", "-DXREALLOC=GC_realloc"] ++ map (ltmDir </>) [ file | file <- ltmFiles, takeExtension file == ".c" ]
pid <- runCommand (unwords $ cmdLine ++ ltmOptions)
ret <- waitForProcess pid
case ret of
ExitSuccess -> return ()
_ -> do hPutStrLn stderr "C code failed to compile."
exitWith ret
where cCode = grinToC grin
cFile = replaceExtension target "c"
cmdLine = ["gcc", "-w", "-lm", "-I/usr/include/gc/", "-lgc", cFile, "-o", target] ++ gccArgs
------------------------------------------------------
-- Grin -> C
grinToC :: Grin -> Doc
grinToC grin
= vsep [ comment "CAFs:"
, vsep (map ppCAF (grinCAFs grin))
, comment "Return arguments:"
, vsep (map ppCAF returnArguments)
, comment "Function prototypes:"
, vsep (map ppFuncDefProtoType (grinFunctions grin))
, comment "Functions:"
, vsep (map ppFuncDef (grinFunctions grin))
, comment "Main:"
, ppMain (grinCAFs grin) (grinEntryPoint grin)
, linebreak
]
returnArguments :: [CAF]
returnArguments = [ CAF{ cafName = Aliased n "lhc_return", cafValue = Lit (Lint 0)} | n <- [1..20] ]
unitSize = sizeOf (undefined :: Int)
ppMain :: [CAF] -> Renamed -> Doc
ppMain cafs entryPoint
= text "int" <+> text "main" <> parens (text "int argc" <> comma <+> text "char *argv[]") <+> char '{' <$$>
indent 2 ( text "global_argc = argc;" <$$>
text "global_argv = argv;" <$$>
text "GC_init();" <$$>
--text "GC_set_max_heap_size(1024*1024*1024);" <$$>
vsep [ vsep [ ppRenamed name <+> equals <+> alloc (int (4 * unitSize)) <> semi
, ppRenamed name <> brackets (int 0) <+> equals <+> int (uniqueId tag) <> semi]
| CAF{cafName = name, cafValue = Node tag _nt _missing} <- cafs ] <$$>
ppRenamed entryPoint <> parens empty <> semi <$$> {- ppFooter <$$> -} text "return 0" <> semi) <$$>
char '}'
ppFooter :: Doc
ppFooter = vsep [ text "printf(\"Collections: %d\\n\", GC_gc_no);"
, text "printf(\"Total allocations: %lu\\n\", GC_get_total_bytes());"
, text "printf(\"Heap size: %ld\\n\", GC_get_heap_size());"
]
ppBumpAlloc :: Doc
ppBumpAlloc
= text "void*" <+> text "alloc" <> parens (text "int" <+> text "size") <+> char '{' <$$>
indent 2 (vsep [ text "static void *p = NULL, *limit = NULL;"
, text "void* t;"
, text "int max;"
, text "if (p == NULL) { "
, text " p = GC_MALLOC(" <> int blockSize <> text " + 10*8);"
, text " limit = p + " <> int blockSize <> text ";"
, text "}"
, text "if (p+size > limit) {"
, text " max = " <> int blockSize <> text " > size ? " <> int blockSize <> text " : size;"
, text " p = GC_MALLOC(max + 10*8);"
, text " limit = p + max;"
, text "}"
, text "t = p;"
, text "p += size;"
, text "return t;"
]) <$$>
char '}'
where blockSize = 1024*4
ppCAF :: CAF -> Doc
ppCAF CAF{cafName = name, cafValue = Node tag _nt _missing}
= unitp <+> ppRenamed name <> semi
ppCAF CAF{cafName = name, cafValue = Lit (Lstring str)}
= comment str <$$>
unitp <+> ppRenamed name <+> equals <+> cunitp <+> escString (str++"\0") <> semi
ppCAF CAF{cafName = name, cafValue = Lit (Lint i)}
= unitp <+> ppRenamed name <+> equals <+> cunitp <+> int (fromIntegral i) <> semi
ppCAF caf = error $ "Grin.Stage2.Backend.ppCAF: Invalid CAF: " ++ show (cafName caf)
ppFuncDefProtoType :: FuncDef -> Doc
ppFuncDefProtoType func
= void <+> ppRenamed (funcDefName func) <> argList <> semi
where argList = parens (hsep $ punctuate comma $ [ unitp <+> ppRenamed arg | arg <- funcDefArgs func ])
ppFuncDef :: FuncDef -> Doc
ppFuncDef func
= void <+> ppRenamed (funcDefName func) <> argList <+> char '{' <$$>
indent 2 (body <$$> text "return" <> semi) <$$>
char '}'
where argList = parens (hsep $ punctuate comma $ [ unitp <+> ppRenamed arg | arg <- funcDefArgs func ])
body = ppExpression (map cafName (take (funcDefReturns func) returnArguments)) (funcDefBody func)
mkBind binds vals
= vsep [ bind =: val | (bind, val) <- zip binds (vals ++ repeat (int 0)) ]
ppExpression :: [Renamed] -> Expression -> Doc
ppExpression binds exp
= case exp of
Constant value -> out [valueToDoc value]
Application fn args ->
case fn of
Builtin prim -> ppBuiltin binds prim args
External ext tys-> ppExternal binds ext tys args
_other -> ppFunctionCall binds fn args
Fetch nth variable -> out [ ppRenamed variable <> brackets (int nth) ] -- out = var[nth];
Unit variables -> out (map ppRenamed variables)
StoreHole size -> out [ alloc (int $ max 4 size * unitSize) ]
Store variables -> out [ alloc (int $ max 4 (length variables) * unitSize) ] <$$>
vsep [ writeArray (head binds) n var | (n,var) <- zip [0..] variables ]
Case scrut alts -> ppCase binds scrut alts
a :>>= binds' :-> b -> vsep [ declareVars binds'
, ppExpression binds' a
, ppExpression binds b ]
where out = mkBind binds
ppBuiltin binds prim args
= case M.lookup prim builtins of
Nothing -> panic $ "unknown builtin: " ++ show prim
Just fn -> fn args
where builtins = M.fromList
[ "coerceDoubleToWord" ~> \[arg] -> out [ ppRenamed arg ]
, "noDuplicate#" ~> \[arg] -> out [ ppRenamed arg ]
, "chr#" ~> \[arg] -> out [ ppRenamed arg ]
, "ord#" ~> \[arg] -> out [ ppRenamed arg ]
, "byteArrayContents#" ~> \[arg] -> out [ ppRenamed arg ]
, "realWorld#" ~> \_ -> out [ int 0 ]
, "unreachable" ~> \_ -> panic "unreachable"
-- Word arithmetics
, "timesWord#" ~> binOp cunit "*"
, "plusWord#" ~> binOp cunit "+"
, "minusWord#" ~> binOp cunit "-"
, "quotWord#" ~> binOp cunit "/"
, "remWord#" ~> binOp cunit "%"
-- Int arithmetics
, "*#" ~> binOp csunit "*"
, "+#" ~> binOp csunit "+"
, "-#" ~> binOp csunit "-"
, "quotInt#" ~> binOp csunit "/"
, "remInt#" ~> binOp csunit "%"
, "negateInt#" ~> unOp csunit "-"
-- Comparing
, "==#" ~> cmpOp csunit "=="
, "/=#" ~> cmpOp csunit "!="
, ">#" ~> cmpOp csunit ">"
, ">=#" ~> cmpOp csunit ">="
, "<#" ~> cmpOp csunit "<"
, "<=#" ~> cmpOp csunit "<="
, "eqWord#" ~> cmpOp cunit "=="
, "neWord#" ~> cmpOp cunit "!="
, "gtWord#" ~> cmpOp cunit ">"
, "geWord#" ~> cmpOp cunit ">="
, "ltWord#" ~> cmpOp cunit "<"
, "leWord#" ~> cmpOp cunit "<="
-- Bit operations
, "and#" ~> binOp cunit "&"
, "or#" ~> binOp cunit "|"
, "xor#" ~> binOp cunit "^"
, "not#" ~> unOp cunit "~"
, "uncheckedShiftL#" ~> binOp' cunit cs32 "<<"
, "uncheckedShiftR#" ~> binOp' cunit cs32 ">>"
, "uncheckedIShiftL#" ~> binOp' csunit cs32 "<<"
, "uncheckedIShiftR#" ~> binOp' csunit cs32 ">>"
, "uncheckedIShiftRA#" ~> binOp' csunit cs32 ">>" -- FIXME
, "uncheckedIShiftRL#" ~> binOp' csunit cs32 ">>" -- FIXME
-- Narrowing
, "narrow8Word#" ~> unOp cu8 ""
, "narrow16Word#" ~> unOp cu16 ""
, "narrow32Word#" ~> unOp cu32 ""
, "narrow8Int#" ~> unOp cs8 ""
, "narrow16Int#" ~> unOp cs16 ""
, "narrow32Int#" ~> unOp cs32 ""
-- Mics IO
, "newPinnedByteArray#" ~> \[size, realWorld] -> out [ ppRenamed realWorld
, alloc (cunit <+> ppRenamed size) ]
, "newByteArray#" ~> \[size, realWorld] -> out [ ppRenamed realWorld
, alloc (cunit <+> ppRenamed size) ]
-- FIXME: Array not aligned.
, "newAlignedPinnedByteArray#" ~> \[size, alignment, realWorld]
-> out [ ppRenamed realWorld
, alloc (cunit <+> ppRenamed size) ]
, "unsafeFreezeByteArray#" ~> \[arr, realWorld] -> out [ ppRenamed realWorld, ppRenamed arr ]
, "unsafeFreezeArray#" ~> \[arr, realWorld] -> out [ ppRenamed realWorld, ppRenamed arr ]
, "updateMutVar" ~> \[ptr, val, realWorld] -> vsep [ writeArray ptr 0 val
, out [ ppRenamed realWorld ] ]
, "newMutVar" ~> \[val, realWorld] -> vsep [ out [ ppRenamed realWorld, alloc (int $ 4 * unitSize) ]
, writeArray (binds!!1) 0 val ]
, "readMutVar" ~> \[val, realWorld] -> out [ ppRenamed realWorld
, ppRenamed val <> brackets (int 0) ]
, "mkWeak#" ~> \[key, val, finalizer, realWorld]
-> out [ ppRenamed realWorld, int 0 ]
, "update" ~> \(ptr:values) -> vsep [ writeArray ptr n value | (n,value) <- zip [0..] values ]
, "touch#" ~> \[ptr, realWorld] -> out [ ppRenamed realWorld ]
, "newArray#" ~> \[size, elt, realWorld] -> out [ ppRenamed realWorld
, text "rts_newArray" <> parens (sep $ punctuate comma [alloc (cunit <> ppRenamed size <+> text "*" <+> int unitSize)
,cunit <+> ppRenamed elt
,cunit <> ppRenamed size])
]
, "writeArray#" ~> \[arr, idx, elt, realWorld] -> vsep [ writeAnyArray unit arr idx elt
, out [ ppRenamed realWorld ] ]
, "readArray#" ~> \[arr, idx, realWorld] -> out [ ppRenamed realWorld
, indexAnyArray cunitp arr idx ]
, "indexArray#" ~> \[arr, idx] -> out [ indexAnyArray cunitp arr idx ]
-- Arrays
, "writeCharArray#" ~> \[arr,idx,chr,realWorld] -> vsep [ writeAnyArray u8 arr idx chr
, out [ ppRenamed realWorld ] ]
, "writeWord8Array#" ~> \[arr,idx,chr,realWorld] -> vsep [ writeAnyArray u8 arr idx chr
, out [ ppRenamed realWorld ] ]
, "indexCharOffAddr#" ~> \[arr,idx] -> out [ indexAnyArray cu8p arr idx ]
, "readCharArray#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld
, indexAnyArray cu8p arr idx ]
, "readInt32OffAddr#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld
, indexAnyArray cs32p arr idx ]
, "readInt8OffAddr#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld
, indexAnyArray cs8p arr idx ]
, "readAddrOffAddr#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld
, indexAnyArray cunitp arr idx ]
, "readWord64OffAddr#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld
, indexAnyArray cu64p arr idx ]
, "readWord8OffAddr#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld
, indexAnyArray cu8p arr idx ]
, "readWideCharOffAddr#" ~> \[arr,idx,realWorld] -> out [ ppRenamed realWorld
, indexAnyArray cs32p arr idx ]
, "writeInt8OffAddr#" ~> \[arr,idx,word,realWorld] -> vsep [ writeAnyArray s8 arr idx word
, out [ ppRenamed realWorld] ]
, "writeWord64OffAddr#" ~> \[arr,idx,word,realWorld] -> vsep [ writeAnyArray u64 arr idx word
, out [ ppRenamed realWorld] ]
, "writeAddrOffAddr#" ~> \[arr,idx,ptr,realWorld] -> vsep [ writeAnyArray unit arr idx ptr
, out [ ppRenamed realWorld] ]
, "writeWideCharOffAddr#" ~> \[arr,idx,char,realWorld] -> vsep [ writeAnyArray s32 arr idx char
, out [ ppRenamed realWorld] ]
]
(~>) = (,)
out = mkBind binds
binOp ty fn [a,b] = out [ parens (ty <+> ppRenamed a <+> text fn <+> ty <+> ppRenamed b) ]
binOp' ty ty' fn [a,b] = out [ parens (ty <+> ppRenamed a <+> text fn <+> ty' <+> ppRenamed b) ]
unOp ty fn [a] = out [ parens (text fn <+> parens (ty <+> ppRenamed a)) ]
cmpOp ty fn [a,b] = ifStatement (ty <> ppRenamed a <+> text fn <+> ty <> ppRenamed b)
(out [ int 1 ])
(out [ int 0 ])
writeAnyArray ty arr idx elt
= parens (parens (ty <> char '*') <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx)
<+> equals <+>
parens ty <+> cunit <+> ppRenamed elt <> semi
indexAnyArray ty arr idx
= parens (ty <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx)
ppExternal binds "isDoubleNaN" tys [double, realWorld]
= mkBind binds [ ppRenamed realWorld
, text "isnan" <> parens (castToDouble double) ]
ppExternal binds "isDoubleInfinite" tys [double, realWorld]
= mkBind binds [ ppRenamed realWorld
, text "isinf" <> parens (castToDouble double) ]
ppExternal binds "isDoubleNegativeZero" tys [double, realWorld]
= mkBind binds [ ppRenamed realWorld
, int 0 ]
ppExternal binds "isFloatNaN" tys [double, realWorld]
= mkBind binds [ ppRenamed realWorld
, text "isnan" <> parens (castToDouble double) ]
ppExternal binds "isFloatInfinite" tys [double, realWorld]
= mkBind binds [ ppRenamed realWorld
, text "isinf" <> parens (castToDouble double) ]
ppExternal binds "isFloatNegativeZero" tys [double, realWorld]
= mkBind binds [ ppRenamed realWorld
, int 0 ]
ppExternal binds fn tys args
= if returnType == UnitType
then mkBind binds [ ppRenamed (last args) ] <$$>
text fn <> argList <> semi
else mkBind binds [ ppRenamed (last args)
, text fn <> argList ]
where argList = parens $ hsep $ punctuate comma $ map ppRenamed (init args)
returnType = last tys
ppFunctionCall binds fn args
= vsep $ [ ppRenamed fn <> argList <> semi ] ++
if isTailCall then [] else [ mkBind binds (map (ppRenamed.cafName) returnArguments) ]
where argList = parens $ hsep $ punctuate comma $ map ppRenamed args
isTailCall = and (zipWith (==) binds (map cafName returnArguments))
{-
-- More than one bind can occur in case expressions. Just take the first.
ppExpression (bind:_) (Constant (Lit (Lrational r)))
= bind =: castToWord (double (fromRational r)) <> semi
ppExpression (bind:_) (Constant value)
= bind =: valueToDoc value
ppExpression [bind] (Application (Builtin "realWorld#") [])
= bind =: int 0
ppExpression binds (Application fn args) | not (isBuiltin fn) && not (isExternal fn) && isTailCall
= ppRenamed fn <> argList <> semi
where argList = parens $ hsep $ punctuate comma $ map ppRenamed args
isTailCall = and (zipWith (==) binds (map cafName returnArguments))
ppExpression binds (Application fn args) | not (isBuiltin fn) && not (isExternal fn)
= ppRenamed fn <> argList <> semi <$$>
vsep (zipWith (=:) binds (map (ppRenamed.cafName) returnArguments))
where argList = parens $ hsep $ punctuate comma $ map ppRenamed args
ppExpression (bind:_) (Fetch nth variable)
= bind =: (ppRenamed variable <> brackets (int nth))
ppExpression binds (Unit variables)
= vsep (zipWith (=:) binds (map ppRenamed variables))
ppExpression [bind] (StoreHole size)
= vsep $ [ bind =: alloc (int $ max 4 size * 8)]
ppExpression (bind:_) (Store variables)
= vsep $ [ bind =: alloc (int $ (max 4 (length variables)) * 8)] ++
[ writeArray bind n var | (n,var) <- zip [0..] variables ]
ppExpression binds (Case scrut alts)
= ppCase binds scrut alts
ppExpression binds (a :>>= binds' :-> b)
= declareVars binds' <$$>
ppExpression binds' a <$$>
ppExpression binds b
ppExpression (bind:_) (Application (Builtin "coerceDoubleToWord") [arg])
= bind =: ppRenamed arg
ppExpression (bind:_) (Application (Builtin "coerceWordToDouble") [arg])
= bind =: ppRenamed arg
ppExpression (bind:_) (Application (Builtin "uncheckedShiftL#") [w,i])
= bind =: (parens (cu32 <> ppRenamed w <+> text "<<" <+> cs32 <> ppRenamed i))
ppExpression (bind:_) (Application (Builtin "uncheckedShiftRL#") [w,i])
= bind =: (parens (cu32 <> ppRenamed w <+> text ">>" <+> cs32 <> ppRenamed i))
ppExpression (bind:_) (Application (Builtin "noDuplicate#") [arg])
= bind =: ppRenamed arg
ppExpression (bind:_) (Application (Builtin "==#") [a,b])
= ifStatement (csunit <> ppRenamed a <+> text "==" <+> csunit <> ppRenamed b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin "gtWord#") [a,b])
= ifStatement (cunit <> ppRenamed a <+> text ">" <+> cunit <> ppRenamed b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin "geWord#") [a,b])
= ifStatement (cunit <> ppRenamed a <+> text ">=" <+> cunit <> ppRenamed b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin "eqWord#") [a,b])
= ifStatement (cunit <> ppRenamed a <+> text "==" <+> cunit <> ppRenamed b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin "neWord#") [a,b])
= ifStatement (cunit <> ppRenamed a <+> text "!=" <+> cunit <> ppRenamed b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin "leWord#") [a,b])
= ifStatement (cunit <> ppRenamed a <+> text "<=" <+> cunit <> ppRenamed b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin "ltWord#") [a,b])
= ifStatement (cunit <> ppRenamed a <+> text "<" <+> cunit <> ppRenamed b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin "/=#") [a,b])
= ifStatement (csunit <> ppRenamed a <+> text "!=" <+> csunit <> ppRenamed b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin ">#") [a,b])
= ifStatement (csunit <> ppRenamed a <+> text ">" <+> csunit <> ppRenamed b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin ">=#") [a,b])
= ifStatement (csunit <> ppRenamed a <+> text ">=" <+> csunit <> ppRenamed b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin "<=#") [a,b])
= ifStatement (csunit <> ppRenamed a <+> text "<=" <+> csunit <> ppRenamed b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin "<#") [a,b])
= ifStatement (csunit <> ppRenamed a <+> text "<" <+> csunit <> ppRenamed b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin "<##") [a,b])
= ifStatement (castToDouble a <+> text "<" <+> castToDouble b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin "<=##") [a,b])
= ifStatement (castToDouble a <+> text "<=" <+> castToDouble b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin ">=##") [a,b])
= ifStatement (castToDouble a <+> text ">=" <+> castToDouble b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin ">##") [a,b])
= ifStatement (castToDouble a <+> text ">" <+> castToDouble b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin "==##") [a,b])
= ifStatement (castToDouble a <+> text "==" <+> castToDouble b)
(bind =: int 1)
(bind =: int 0)
ppExpression (bind:_) (Application (Builtin "and#") [a,b])
= bind =: parens (parens (cunit <> ppRenamed a) <+> text "&" <+> parens (cunit <> ppRenamed b))
ppExpression (bind:_) (Application (Builtin "or#") [a,b])
= bind =: parens (parens (cunit <> ppRenamed a) <+> text "|" <+> parens (cunit <> ppRenamed b))
ppExpression (bind:_) (Application (Builtin "xor#") [a,b])
= bind =: parens (parens (cunit <> ppRenamed a) <+> text "^" <+> parens (cunit <> ppRenamed b))
ppExpression (bind:_) (Application (Builtin "not#") [a])
= bind =: parens (text "~" <> parens (cunit <> ppRenamed a))
ppExpression (bind:_) (Application (Builtin "ord#") [a])
= bind =: ppRenamed a
ppExpression (bind:_) (Application (Builtin "chr#") [a])
= bind =: ppRenamed a
ppExpression (bind:_) (Application (Builtin "negateInt#") [a])
= bind =: (text "-" <+> csunit <+> cunit <> ppRenamed a)
ppExpression (bind:_) (Application (Builtin "negateDouble#") [a])
= bind =: castToWord (text "-" <+> castToDouble a)
ppExpression (bind:_) (Application (Builtin "narrow8Word#") [a])
= bind =: (cunit <+> cu8 <+> cunit <+> ppRenamed a)
ppExpression (bind:_) (Application (Builtin "narrow16Word#") [a])
= bind =: (cunit <+> cu16 <+> cunit <+> ppRenamed a)
ppExpression (bind:_) (Application (Builtin "narrow32Word#") [a])
= bind =: (cunit <+> cu32 <+> cunit <+> ppRenamed a)
ppExpression (bind:_) (Application (Builtin "narrow8Int#") [a])
= bind =: (cunit <+> cs8 <+> cunit <+> ppRenamed a)
ppExpression (bind:_) (Application (Builtin "narrow16Int#") [a])
= bind =: (cunit <+> cs16 <+> cunit <+> ppRenamed a)
ppExpression (bind:_) (Application (Builtin "narrow32Int#") [val])
= bind =: (cunit <+> cs32 <+> cunit <+> ppRenamed val)
ppExpression (bind:_) (Application (Builtin "timesWord#") [a,b])
= bind =: parens (cunit <+> ppRenamed a <+> text "*" <+> cunit <+> ppRenamed b)
ppExpression (bind:_) (Application (Builtin "plusWord#") [a,b])
= bind =: parens (cunit <+> ppRenamed a <+> text "+" <+> cunit <+> ppRenamed b)
ppExpression (bind:_) (Application (Builtin "minusWord#") [a,b])
= bind =: parens (cunit <+> ppRenamed a <+> text "-" <+> cunit <+> ppRenamed b)
ppExpression (bind:_) (Application (Builtin "*#") [a,b])
= bind =: parens (csunit <+> ppRenamed a <+> text "*" <+> csunit <+> ppRenamed b)
ppExpression (bind:_) (Application (Builtin "*##") [a,b])
= bind =: castToWord (castToDouble a <+> text "*" <+> castToDouble b)
ppExpression (bind:_) (Application (Builtin "-##") [a,b])
= bind =: castToWord (castToDouble a <+> text "-" <+> castToDouble b)
ppExpression (bind:_) (Application (Builtin "+##") [a,b])
= bind =: castToWord (castToDouble a <+> text "+" <+> castToDouble b)
ppExpression (bind:_) (Application (Builtin "/##") [a,b])
= bind =: castToWord (castToDouble a <+> text "/" <+> castToDouble b)
ppExpression (bind:_) (Application (Builtin "**##") [a,b])
= bind =: castToWord (text "pow" <> parens (castToDouble a <+> text "," <+> castToDouble b))
ppExpression (bind:_) (Application (Builtin "sinDouble#") [a])
= bind =: castToWord (text "sin" <> parens (castToDouble a))
ppExpression (bind:_) (Application (Builtin "cosDouble#") [a])
= bind =: castToWord (text "cos" <> parens (castToDouble a))
ppExpression (bind:_) (Application (Builtin "sqrtDouble#") [a])
= bind =: castToWord (text "sqrt" <> parens (castToDouble a))
ppExpression (bind:_) (Application (Builtin "logDouble#") [a])
= bind =: castToWord (text "log" <> parens (castToDouble a))
ppExpression (bind:_) (Application (Builtin "expDouble#") [a])
= bind =: castToWord (text "exp" <> parens (castToDouble a))
ppExpression (bind:_) (Application (Builtin "int2Double#") [a])
= bind =: castToWord (parens (text "double") <> cunit <> ppRenamed a)
ppExpression (bind:_) (Application (Builtin "double2Int#") [a])
= bind =: (cunit <> castToDouble a)
ppExpression (bind:_) (Application (Builtin "+#") [a,b])
= bind =: parens (csunit <+> ppRenamed a <+> text "+" <+> csunit <+> ppRenamed b)
ppExpression (bind:_) (Application (Builtin "-#") [a,b])
= bind =: parens (csunit <+> ppRenamed a <+> text "-" <+> csunit <+> ppRenamed b)
ppExpression (bind:_) (Application (Builtin "quotInt#") [a,b])
= bind =: parens (csunit <+> ppRenamed a <+> text "/" <+> csunit <+> ppRenamed b)
ppExpression (bind:_) (Application (Builtin "quotWord#") [a,b])
= bind =: parens (cunit <+> ppRenamed a <+> text "/" <+> cunit <+> ppRenamed b)
ppExpression (bind:_) (Application (Builtin "remInt#") [a,b])
= bind =: parens (csunit <+> ppRenamed a <+> text "%" <+> csunit <+> ppRenamed b)
ppExpression (bind:_) (Application (Builtin "remWord#") [a,b])
= bind =: parens (cunit <+> ppRenamed a <+> text "%" <+> cunit <+> ppRenamed b)
ppExpression (bind:_) (Application (Builtin "indexCharOffAddr#") [addr,idx])
= bind =: (cunit <+> parens (cu8p <+> ppRenamed addr) <> brackets (cunit <+> ppRenamed idx))
ppExpression (st:bind:_) (Application (Builtin "readCharArray#") [arr,idx,realWorld])
= vsep [ bind =: (cunit <+> parens (cu8p <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx))
, st =: ppRenamed realWorld ]
ppExpression (st:_) (Application (Builtin "writeArray#") [arr, idx, elt, realWorld])
= vsep [ st =: ppRenamed realWorld
, ppRenamed arr <> brackets (cunit <> ppRenamed idx) <+> equals <+> cunit <> ppRenamed elt <> semi
]
ppExpression (st:bind:_) (Application (Builtin "readArray#") [arr, idx, realWorld])
= vsep [ st =: ppRenamed realWorld
, bind =: (ppRenamed arr <> brackets (cunit <+> ppRenamed idx))
]
ppExpression (bind:_) (Application (Builtin "indexArray#") [arr, idx])
= vsep [ bind =: (ppRenamed arr <> brackets (cunit <> ppRenamed idx)) ]
ppExpression (st:_) (Application (Builtin "writeCharArray#") [arr,idx,chr,realWorld])
= vsep [ parens (cu8p <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx) <+>
equals <+> cu8 <+> cunit <+> ppRenamed chr <> semi
, st =: ppRenamed realWorld ]
ppExpression (st:_) (Application (Builtin "writeWord8Array#") [arr,idx,word,realWorld])
= vsep [ parens (cu8p <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx) <+>
equals <+> cu8 <+> cunit <+> ppRenamed word <> semi
, st =: ppRenamed realWorld ]
ppExpression (st:_) (Application (Builtin "writeWord8OffAddr#") [arr,idx,word,realWorld])
= vsep [ parens (cu8p <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx) <+>
equals <+> cu8 <+> cunit <+> ppRenamed word <> semi
, st =: ppRenamed realWorld ]
ppExpression (st:_) (Application (Builtin "writeInt8OffAddr#") [arr,idx,word,realWorld])
= vsep [ parens (cs8p <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx) <+>
equals <+> cs8 <+> cunit <+> ppRenamed word <> semi
, st =: ppRenamed realWorld ]
ppExpression (st:_) (Application (Builtin "writeDoubleOffAddr#") [arr,idx,double,realWorld])
= vsep [ parens (cunitp <+> ppRenamed arr) <> brackets (cunit <+> ppRenamed idx) <+>
equals <+> cunit <+> ppRenamed double <> semi
, st =: ppRenamed realWorld ]
ppExpression (st:bind:_) (Application (Builtin "readAddrOffAddr#") [addr, idx, realworld])
= vsep [ bind =: (ppRenamed addr <> brackets (cunit <+> ppRenamed idx))
, st =: ppRenamed realworld ]
ppExpression (st:bind:_) (Application (Builtin "readDoubleOffAddr#") [addr, idx, realworld])
= vsep [ bind =: (ppRenamed addr <> brackets (cunit <+> ppRenamed idx))
, st =: ppRenamed realworld ]
ppExpression (st:bind:_) (Application (Builtin "readInt32OffAddr#") [addr,idx, realworld])
= vsep [ bind =: (cunit <+> parens (cs32p <+> ppRenamed addr) <> brackets (cunit <+> ppRenamed idx))
, st =: ppRenamed realworld
]
ppExpression (st:bind:_) (Application (Builtin "readWord8Array#") [addr,idx, realworld])
= vsep [ bind =: (cunit <+> parens (cu8p <+> ppRenamed addr) <> brackets (cunit <+> ppRenamed idx))
, st =: ppRenamed realworld
]
ppExpression (st:bind:_) (Application (Builtin "readInt8OffAddr#") [addr,idx, realworld])
= vsep [ bind =: (cunit <+> parens (cs8p <+> ppRenamed addr) <> brackets (cunit <+> ppRenamed idx))
, st =: ppRenamed realworld
]
ppExpression (st:bind:_) (Application (Builtin "unsafeFreezeByteArray#") [addr, realworld])
= vsep [ bind =: ppRenamed addr
, st =: ppRenamed realworld ]
ppExpression (st:bind:_) (Application (Builtin "unsafeFreezeArray#") [addr, realworld])
= vsep [ bind =: ppRenamed addr
, st =: ppRenamed realworld ]
ppExpression (bind:_) (Application (Builtin "byteArrayContents#") [addr])
= bind =: ppRenamed addr
ppExpression (st:_) (Application (Builtin "touch#") [ptr,realworld])
= st =: ppRenamed realworld
ppExpression (st:bind:_) (Application (Builtin "mkWeak#") [key, val, finalizer, realWorld])
= vsep [ bind =: int 0
, st =: ppRenamed realWorld ]
ppExpression (st:arr:_) (Application (Builtin "newArray#") [size, elt, realWorld])
= vsep [ st =: ppRenamed realWorld
, arr =: alloc (cunit <> ppRenamed size <+> text "* 8")
, text "int " <> i <+> equals <+> text "0;"
, text "for(;" <> i <> text "<" <> cunit <> ppRenamed size <> text ";" <> i <> text"++) {" <$$>
text " " <> ppRenamed arr <> brackets i <+> equals <+> ppRenamed elt <> semi <$$>
text "}"
]
where i = text "i_" <> ppRenamed arr
ppExpression (st:arr:_) (Application (Builtin "newByteArray#") [size,realWorld])
= vsep [ st =: ppRenamed realWorld
, arr =: alloc (cunit <+> ppRenamed size) ]
ppExpression (st:arr:_) (Application (Builtin "newPinnedByteArray#") [size,realWorld])
= vsep [ st =: ppRenamed realWorld
, arr =: alloc (cunit <+> ppRenamed size) ]
-- FIXME: The ByteArray isn't aligned.
ppExpression (st:arr:_) (Application (Builtin "newAlignedPinnedByteArray#") [size,alignment,realWorld])
= vsep [ st =: ppRenamed realWorld
, arr =: alloc (cunit <+> ppRenamed size) ]
ppExpression _ (Application (Builtin "update") (ptr:values))
= vsep [ writeArray ptr n value | (n,value) <- zip [0..] values ]
ppExpression (st:_) (Application (Builtin "updateMutVar") [ptr,val,realWorld])
= vsep [ writeArray ptr 0 val
, st =: ppRenamed realWorld ]
ppExpression (st:bind:_) (Application (External "fdReady") args)
= vsep [ bind =: int 1
, st =: ppRenamed (last args) ]
ppExpression (st:bind:_) (Application (External "isDoubleNegativeZero") [double,realworld])
= vsep [ bind =: int 0
, st =: ppRenamed realworld ]
ppExpression (st:bind:_) (Application (External "isFloatNegativeZero") [double,realworld])
= vsep [ bind =: int 0
, st =: ppRenamed realworld ]
ppExpression (st:bind:_) (Application (External "isDoubleNaN") [double,realworld])
= vsep [ bind =: (text "isnan" <> parens (castToDouble double))
, st =: ppRenamed realworld ]
ppExpression (st:bind:_) (Application (External "isDoubleInfinite") [double,realworld])
= vsep [ bind =: (text "isinf" <> parens (castToDouble double))
, st =: ppRenamed realworld ]
ppExpression (st:bind:_) (Application (External "isFloatNaN") [double,realworld])
= vsep [ bind =: (text "isnan" <> parens (castToDouble double))
, st =: ppRenamed realworld ]
ppExpression (st:bind:_) (Application (External "isFloatInfinite") [double,realworld])
= vsep [ bind =: (text "isinf" <> parens (castToDouble double))
, st =: ppRenamed realworld ]
ppExpression (st:_) (Application (External "getProgArgv") [argcPtr, argvPtr, realWorld])
= vsep [ parens (parens (text "int*") <>ppRenamed argcPtr) <> brackets (int 0) <+> equals <+> text "global_argc" <> semi
, ppRenamed argvPtr <> brackets (int 0) <+> equals <+> text "global_argv" <> semi
, st =: ppRenamed realWorld ]
ppExpression (st:bind:_) (Application (External "__hscore_get_errno") args)
= vsep [ bind =: (cunit <+> text "errno")
, st =: ppRenamed (last args) ]
ppExpression (st:bind:_) (Application (External "__hscore_PrelHandle_write") [fd,ptr,offset,size,realWorld])
= vsep [ bind =: (text "write" <> parens (hsep $ punctuate comma $ [ cunit <+> ppRenamed fd
, ppRenamed ptr <+> text "+" <+> cunit <+> ppRenamed offset
, ppRenamed size]))
, st =: ppRenamed realWorld ]
ppExpression (st:bind:_) (Application (External "__hscore_memcpy_dst_off") [dst, off, src, size, realWorld])
= vsep [ bind =: (text "memcpy" <> parens (hsep $ punctuate comma $ [ cunit <+> ppRenamed dst <+> text "+" <+> cunit <+> ppRenamed off
, ppRenamed src
, ppRenamed size ]))
, st =: ppRenamed realWorld ]
ppExpression (st:bind:_) (Application (External fn) args)
= vsep [bind =: (text fn <> argList)
,st =: ppRenamed (last args) ]
where argList = parens $ hsep $ punctuate comma $ map ppRenamed (init args)
ppExpression binds e = panic (show (Grin.ppExpression e))
-}
castToWord double
= text "doubleToWord" <> parens double
castToDouble ptr
= text "wordToDouble" <> parens (ppRenamed ptr)
ppCase binds scrut alts
= switch (cunit <+> ppRenamed scrut) $
vsep (map ppAlt alts) <$$> def (last alts)
where def (Empty :> _) = empty
def _ = text "default:" <$$> indent 2 (panic ("No match for case: " ++ show scrut))
ppAlt (value :> exp)
= case value of
Empty
-> text "default:" <$$> braces rest
Node tag _nt _missing
-> text "case" <+> int (uniqueId tag) <> colon <$$> braces rest
Lit (Lint i)
-> text "case" <+> int (fromIntegral i) <> colon <$$> braces rest
Lit (Lchar c)
-> text "case" <+> int (ord c) <> colon <$$> braces rest
where rest = indent 2 ({-cafName (head returnArguments) =: ppRenamed (cafName (head returnArguments)) <$$>-}
ppExpression binds exp <$$>
text "break;")
valueToDoc :: Value -> Doc
valueToDoc (Node tag nt missing) = int (uniqueId tag)
valueToDoc (Lit (Lint i)) = int (fromIntegral i)
valueToDoc (Lit (Lchar c)) = int (ord c)
valueToDoc (Lit (Lrational r)) = castToWord (double (fromRational r))
valueToDoc val = error $ "Grin.Stage2.Backend.C.valueToDoc: Can't translate: " ++ show val
{-
primOps = Map.fromList [ "==##" +> \ ~[bind] [a,b] ->
ifStatement (castToDouble a <+> text "==" <+> castToDouble b)
(bind =: int 1)
(bind =: int 0)
]
where (+>) = (,)
-}
panic :: String -> Doc
panic txt = text "panic" <> parens (escString txt) <> semi
alloc :: Doc -> Doc
--alloc size = text "GC_MALLOC" <> parens (size)
alloc size = text "alloc" <> parens (size)
writeArray :: Renamed -> Int -> Renamed -> Doc
writeArray arr nth val
= ppRenamed arr <> brackets (int nth) <+> equals <+> cunit <+> ppRenamed val <> semi
writeArray' :: Renamed -> Int -> Doc -> Doc
writeArray' arr nth val
= ppRenamed arr <> brackets (int nth) <+> equals <+> cunit <+> val <> semi
(=:) :: Renamed -> Doc -> Doc
variable =: value = ppRenamed variable <+> equals <+> cunitp <+> value <> semi
declareVar :: Renamed -> Doc
declareVar var
= unit <> char '*' <+> ppRenamed var <> semi
declareVars :: [Renamed] -> Doc
declareVars = vsep . map declareVar
escString :: String -> Doc
escString string = char '"' <> text (concatMap worker string) <> char '"'
where worker c | False = [c]
| otherwise = printf "\\x%02x" (ord c)
initList :: [Int] -> Doc
initList vals = braces $ hsep $ punctuate comma $ map int vals
switch ::Doc -> Doc -> Doc
switch scrut body
= text "switch" <> parens scrut <+> char '{' <$$>
indent 2 body <$$>
char '}'
ppRenamed :: Renamed -> Doc
ppRenamed (Anonymous i)
= text "anon_" <> int i
ppRenamed (Aliased i name)
= text "named_" <> sanitize name <> char '_' <> int i
ppRenamed (Builtin "undefined")
= text "0"
ppRenamed (Builtin builtin)
= error $ "Grin.Stage2.Backend.C.ppRenamed: Unknown primitive: " ++ show builtin
sanitize :: CompactString -> Doc
sanitize cs = text (map sanitizeChar $ show $ pretty cs)
sanitizeChar :: Char -> Char
sanitizeChar c | isAlphaNum c = c
| otherwise = '_'
ifStatement :: Doc -> Doc -> Doc -> Doc
ifStatement cond true false
= text "if" <> parens cond <$$>
indent 2 (braces true) <$$>
text "else" <$$>
indent 2 (braces false)
include :: FilePath -> Doc
include headerFile
= text "#include" <+> char '<' <> text headerFile <> char '>'
comment :: String -> Doc
comment str = text "/*" <+> text str <+> text "*/"
typedef, unsigned, signed, long, void, u64, u32, u16, u8, s64, s32, s16,s8 :: Doc
typedef = text "typedef"
unsigned = text "unsigned"
signed = text "signed"
long = text "long"
void = text "void"
unit = text "unit"
unitp = text "unit*"
sunit = text "sunit"
sunitp = text "sunit*"
u64 = text "u64"
u32 = text "u32"
u16 = text "u16"
u8 = text "u8"
s64 = text "s64"
s32 = text "s32"
s16 = text "s16"
s8 = text "s8"
cunit = parens unit
cunitp = parens unitp
csunit = parens sunit
csunitp = parens sunitp
cu64 = parens u64
cu64p = parens (u64<>char '*')
cu32 = parens u32
cu32p = parens (u32<>char '*')
cu16 = parens u16
cu16p = parens (u16<>char '*')
cu8 = parens u8
cu8p = parens (u8<>char '*')
cs64 = parens s64
cs64p = parens (s64<>char '*')
cs32 = parens s32
cs32p = parens (s32<>char '*')
cs16 = parens s16
cs16p = parens (s16<>char '*')
cs8 = parens s8
cs8p = parens (s8<>char '*')