hakaru-0.4.0: haskell/Language/Hakaru/CodeGen/Types.hs
{-# LANGUAGE DataKinds,
FlexibleContexts,
GADTs,
KindSignatures #-}
----------------------------------------------------------------
-- 2016.07.11
-- |
-- Module : Language.Hakaru.CodeGen.Types
-- Copyright : Copyright (c) 2016 the Hakaru team
-- License : BSD3
-- Maintainer : zsulliva@indiana.edu
-- Stability : experimental
-- Portability : GHC-only
--
-- Provides tools for building C Types from Hakaru types
--
----------------------------------------------------------------
module Language.Hakaru.CodeGen.Types
( buildDeclaration
, buildDeclaration'
, buildPtrDeclaration
-- tools for building C types
, typeDeclaration
, typePtrDeclaration
, typeName
-- arrays
, arrayDeclaration
, arrayStruct
, arraySize
, arrayData
, arrayPtrSize
, arrayPtrData
-- mdata
, mdataDeclaration
, mdataPtrDeclaration
, mdataStruct
, mdataStruct'
, mdataWeight
, mdataSample
, mdataPtrWeight
, mdataPtrSample
-- datum
, datumDeclaration
, datumStruct
, datumSum
, datumProd
, datumFst
, datumSnd
-- functions and closures
, functionDef
, closureDeclaration
, buildType
, castTo
, castToPtrOf
, callStruct
, buildStruct
, buildUnion
, binaryOp
) where
import Control.Monad.State
import Language.Hakaru.Syntax.AST
import Language.Hakaru.Types.DataKind
import Language.Hakaru.Types.HClasses
import Language.Hakaru.Types.Sing
import Language.Hakaru.CodeGen.AST
import Language.Hakaru.CodeGen.Libs
buildDeclaration :: CTypeSpec -> Ident -> CDecl
buildDeclaration ctyp ident =
CDecl [ CTypeSpec ctyp ]
[( CDeclr Nothing (CDDeclrIdent ident)
, Nothing)]
buildDeclaration' :: [CTypeSpec] -> Ident -> CDecl
buildDeclaration' specs ident =
CDecl (fmap CTypeSpec specs)
[( CDeclr Nothing (CDDeclrIdent ident)
, Nothing)]
buildPtrDeclaration :: CTypeSpec -> Ident -> CDecl
buildPtrDeclaration ctyp ident =
CDecl [ CTypeSpec ctyp ]
[( CDeclr (Just $ CPtrDeclr []) (CDDeclrIdent ident)
, Nothing)]
typeDeclaration :: Sing (a :: Hakaru) -> Ident -> CDecl
typeDeclaration typ ident =
CDecl (fmap CTypeSpec $ buildType typ)
[( CDeclr Nothing (CDDeclrIdent ident)
, Nothing)]
typePtrDeclaration :: Sing (a :: Hakaru) -> Ident -> CDecl
typePtrDeclaration typ ident =
CDecl (fmap CTypeSpec $ buildType typ)
[( CDeclr (Just $ CPtrDeclr [])
(CDDeclrIdent ident)
, Nothing)]
----------------
-- Type Names --
----------------
{-
Type names are used when constructing C structures. In most cases there is a
unique C structure name for a Hakaru type. This is not the case for functions
which are compiled into closures, which are unique to a certain context and
Hakaru type.
-}
typeName :: Sing (a :: Hakaru) -> String
typeName SInt = "int"
typeName SNat = "nat"
typeName SReal = "real"
typeName SProb = "prob"
typeName (SArray t) = "array_" ++ typeName t
typeName (SMeasure t) = "mdata_" ++ typeName t
typeName f@(SFun _ _) = error $ "typeName{SFun} doen't make sense: unknown context for {" ++ show f ++ "}"
typeName (SData _ t) = "dat_" ++ datumSumName t
where datumSumName :: Sing (a :: [[HakaruFun]]) -> String
datumSumName SVoid = "V"
datumSumName (SPlus p s) = datumProdName p ++ datumSumName s
datumProdName :: Sing (a :: [HakaruFun]) -> String
datumProdName SDone = "D"
datumProdName (SEt x p) = datumPrimName x ++ datumProdName p
datumPrimName :: Sing (a :: HakaruFun) -> String
datumPrimName SIdent = "I"
datumPrimName (SKonst s) = "K" ++ typeName s
--------------------------------------------------------------------------------
-- Arrays --
--------------------------------------------------------------------------------
{-
We represent arrays as structs with an 'unsigned int' for the size and a
pointer to a block of array elements.
Because arrays may point to undeclared types (such as arrays of datum), we
need to return a list of external declarations with our array type
-}
arrayStruct :: Sing (a :: Hakaru) -> CExtDecl
arrayStruct t = CDeclExt (CDecl [CTypeSpec $ arrayStruct' t] [])
arrayStruct' :: Sing (a :: Hakaru) -> CTypeSpec
arrayStruct' t = aStruct
where aSize = buildDeclaration' [CUnsigned,CInt] (Ident "size")
aData = typePtrDeclaration t (Ident "data")
aStruct = buildStruct (Just . Ident . typeName . SArray $ t) [aSize,aData]
arrayDeclaration
:: Sing (a :: Hakaru)
-> Ident
-> CDecl
arrayDeclaration = buildDeclaration . callStruct . typeName . SArray
arraySize :: CExpr -> CExpr
arraySize e = CMember e (Ident "size") True
arrayData :: CExpr -> CExpr
arrayData e = CMember e (Ident "data") True
arrayPtrSize :: CExpr -> CExpr
arrayPtrSize e = CMember e (Ident "size") False
arrayPtrData :: CExpr -> CExpr
arrayPtrData e = CMember e (Ident "data") False
--------------------------------------------------------------------------------
-- Measure Data --
--------------------------------------------------------------------------------
{-
Measure datum are structures that will be used for sampling. We represent it
as a structure with a 'double' in log-domain corresponding to the weight of
the sample and an item of the sample type.
-}
mdataStruct :: Sing (a :: Hakaru) -> CExtDecl
mdataStruct t = CDeclExt (CDecl [CTypeSpec $ mdataStruct' t] [])
mdataStruct' :: Sing (a :: Hakaru) -> CTypeSpec
mdataStruct' t = mdStruct
where weight = buildDeclaration CDouble (Ident "weight")
sample = typeDeclaration t (Ident "sample")
mdStruct = buildStruct (Just . Ident . typeName . SMeasure $ t) [weight,sample]
mdataDeclaration
:: Sing (a :: Hakaru)
-> Ident
-> CDecl
mdataDeclaration = buildDeclaration . callStruct . typeName . SMeasure
mdataPtrDeclaration
:: Sing (a :: Hakaru)
-> Ident
-> CDecl
mdataPtrDeclaration = buildPtrDeclaration . callStruct . typeName . SMeasure
mdataWeight :: CExpr -> CExpr
mdataWeight d = CMember d (Ident "weight") True
mdataSample :: CExpr -> CExpr
mdataSample d = CMember d (Ident "sample") True
mdataPtrWeight :: CExpr -> CExpr
mdataPtrWeight d = CMember d (Ident "weight") False
mdataPtrSample :: CExpr -> CExpr
mdataPtrSample d = CMember d (Ident "sample") False
--------------------------------------------------------------------------------
-- Datum --
--------------------------------------------------------------------------------
{-
In order to successfully represent Hakaru datum (Sums of Products of Hakaru
types), we must have:
> unique names for a given datum so if SVoid occurs twice in a program, C will
be using the same structure
> C structs
> A datum may be recursive, so we will need to generate structures for all
subtypes as well. These subtypes will need to be declared before the datum
for the code to compile
-}
datumStruct :: (Sing (HData' t)) -> CExtDecl
datumStruct dat@(SData _ typ)
= CDeclExt $ datumSum dat typ (Ident (typeName dat))
datumDeclaration
:: (Sing (HData' t))
-> Ident
-> CDecl
datumDeclaration = buildDeclaration . callStruct . typeName
datumSum
:: Sing (HData' t)
-> Sing (a :: [[HakaruFun]])
-> Ident
-> CDecl
datumSum dat funs ident =
let declrs = fst $ runState (datumSum' dat funs) cNameStream
union = buildDeclaration (buildUnion declrs) (Ident "sum")
index = buildDeclaration CInt (Ident "index")
struct = buildStruct (Just ident) $ case declrs of
[] -> [index]
_ -> [index,union]
in CDecl [ CTypeSpec struct ] []
datumSum'
:: Sing (HData' t)
-> Sing (a :: [[HakaruFun]])
-> State [String] [CDecl]
datumSum' _ SVoid = return []
datumSum' dat (SPlus prod rest) =
do (name:names) <- get
put names
let ident = Ident name
mdecl = datumProd dat prod ident
rest' <- datumSum' dat rest
case mdecl of
Nothing -> return rest'
Just d -> return $ [d] ++ rest'
datumProd
:: Sing (HData' t)
-> Sing (a :: [HakaruFun])
-> Ident
-> Maybe CDecl
datumProd _ SDone _ = Nothing
datumProd dat funs ident =
let declrs = fst $ runState (datumProd' dat funs) cNameStream
in Just $ buildDeclaration (buildStruct Nothing $ declrs) ident
-- datumProd uses a store of names, which needs to match up with the names used
-- when they are assigned as well as printed
datumProd'
:: Sing (HData' t)
-> Sing (a :: [HakaruFun])
-> State [String] [CDecl]
datumProd' _ SDone = return []
datumProd' dat (SEt x ps) =
do x' <- datumPrim dat x
ps' <- datumProd' dat ps
return $ x' ++ ps'
-- We need to pass HData in case it is some recursive type
datumPrim
:: Sing (HData' t)
-> Sing (a :: HakaruFun)
-> State [String] [CDecl]
datumPrim dat prim =
do (name:names) <- get
put names
let ident = Ident name
decl = case prim of
SIdent -> datumDeclaration dat ident
(SKonst k) -> typeDeclaration k ident
return [decl]
-- index into pair
datumFst :: CExpr -> CExpr
datumFst x = x ... "sum" ... "a" ... "a"
datumSnd :: CExpr -> CExpr
datumSnd x = x ... "sum" ... "a" ... "b"
--------------------------------------------------------------------------------
-- Functions --
--------------------------------------------------------------------------------
{-
This still needs some work. Currently, we use the CodeGenMonad to give us
a list of local declarations and statements to be used in a function. Then
build a function from that.
-}
functionDef
:: Sing (a :: Hakaru)
-> Ident
-> [CDecl]
-> [CDecl]
-> [CStat]
-> CFunDef
functionDef typ ident argDecls internalDecls stmts =
CFunDef (fmap CTypeSpec $ buildType typ)
(CDeclr Nothing (CDDeclrIdent ident))
argDecls
(CCompound ((fmap CBlockDecl internalDecls)
++ (fmap CBlockStat stmts)))
--------------
-- Closures --
--------------
closureDeclaration
:: (Sing (a :: Hakaru))
-> Ident
-> CDecl
closureDeclaration = buildDeclaration . callStruct . typeName
--------------------------------------------------------------------------------
-- | buildType function do the work of describing how the Hakaru
-- type will be stored in memory. Arrays needed their own
-- declaration function for their arity
buildType :: Sing (a :: Hakaru) -> [CTypeSpec]
buildType SInt = [CInt]
buildType SNat = [CUnsigned, CInt]
buildType SProb = [CDouble]
buildType SReal = [CDouble]
buildType (SMeasure x) = [callStruct . typeName . SMeasure $ x]
buildType (SArray t) = [callStruct . typeName . SArray $ t]
buildType (SFun _ x) = buildType $ x -- build type the function returns
buildType d@(SData _ _) = [callStruct . typeName $ d]
-- these mk...Decl functions are used in coersions
castTo :: [CTypeSpec] -> CExpr -> CExpr
castTo t = CCast (CTypeName t False)
castToPtrOf :: [CTypeSpec] -> CExpr -> CExpr
castToPtrOf t = CCast (CTypeName t True)
buildStruct :: Maybe Ident -> [CDecl] -> CTypeSpec
buildStruct mi decls =
CSUType (CSUSpec CStructTag mi decls)
-- | callStruct will give the type spec calling a struct we have already
-- declared externally
callStruct :: String -> CTypeSpec
callStruct name =
CSUType (CSUSpec CStructTag (Just (Ident name)) [])
buildUnion :: [CDecl] -> CTypeSpec
buildUnion decls =
CSUType (CSUSpec CUnionTag Nothing decls)
binaryOp :: NaryOp a -> CExpr -> CExpr -> CExpr
binaryOp (Sum HSemiring_Prob) a b = CBinary CAddOp (expE a) (expE b)
binaryOp (Prod HSemiring_Prob) a b = CBinary CAddOp a b
binaryOp (Sum _) a b = CBinary CAddOp a b
binaryOp (Prod _) a b = CBinary CMulOp a b
-- vvv Operations on bools, keeping in mind that in Hakaru-C: 0 is true and 1 is false
binaryOp And a b = CUnary CNegOp (CBinary CEqOp a b) -- still wrong
binaryOp Or a b = CBinary CAndOp a b -- still wrong
binaryOp Xor a b = CBinary CLorOp a b -- still wrong
binaryOp x _ _ = error $ "TODO: binaryOp " ++ show x