grin-compiler/grin
1
1
Fork 0
mirror of https://github.com/grin-compiler/grin.git synced 2024-09-11 15:37:54 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #25 from grin-tech/andorp/linker-2

Browse Source 
Ability to create executable.
This commit is contained in:
Csaba Hruska 2019-04-02 23:15:54 +02:00 committed by GitHub
commit 9bc5e51742
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
19 changed files with 882 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
grin/app/GrinCLI.hs
View File

@ -109,7 +109,9 @@ pipelineOpts =
<|> flg PureEval "eval" "Evaluate the grin program (pure)"
<|> flg JITLLVM "llvm" "JIT with LLVM"
<|> flg PrintAST "ast" "Print the Abstract Syntax Tree"
<|> (SaveLLVM True <$> (strOption (mconcat [long "save-llvm", help "Save the generated llvm"])))
<|> (SaveExecutable False . Abs <$> (strOption (mconcat [short 'o', long "save-elf", help "Save an executable ELF"])))
<|> (SaveExecutable True . Abs <$> (strOption (mconcat [short 'o', long "save-elf-dbg", help "Save an executable ELF with debug symbols"])))
<|> (SaveLLVM . Abs <$> (strOption (mconcat [long "save-llvm", help "Save the generated llvm"])))
<|> (SaveGrin . Abs <$> (strOption (mconcat [long "save-grin", help "Save the generated grin"])))
<|> (SaveBinary <$> (strOption (mconcat [long "save-binary", help "Save the generated grin in binary format"])))
<|> (T <$> transformOpts)
@ -171,7 +173,7 @@ main = do
postPipeline :: [PipelineStep]
postPipeline =
[ SaveLLVM True "high-level-opt-code"
[ SaveLLVM $ Rel "high-level-opt-code"
, JITLLVM -- TODO: Remove this.
, PrintTypeEnv
, PrintGrin ondullblack

2
grin/grin.cabal
View File

@ -215,6 +215,7 @@ test-suite grin-test
, mtl
, ansi-wl-pprint
, directory
, inline-c
other-modules:
Transformations.Simplifying.RegisterIntroductionSpec
@ -253,6 +254,7 @@ test-suite grin-test
TestSpec
PipelineSpec
ParserSpec
PrimOpsSpec
NametableSpec
AbstractInterpretation.HptSpec
AbstractInterpretation.LiveVariableSpec

243
grin/prim_ops.c Normal file
View File

@ -0,0 +1,243 @@
#include <stdio.h>
#include <stdlib.h>
#include <inttypes.h>
#include <stdbool.h>
#include <string.h>
#include <unistd.h>
#include "prim_ops.h"
#define BUFFER_SIZE 256
/*
NOTES:
* In error cases we just simple exit as this part is still under active development.
* _prim_ffi_file_eof is a placeholder implementation.
*/
struct string* create_string_len(int64_t l) {
struct string* r = (struct string*)malloc(sizeof(struct string));
r->data = (char*)calloc(sizeof(char), l * sizeof(char));
r->length = l;
#ifdef DEBUG
printf("create_string_len(%ld) = %d\n", l, (int)r);
#endif
return r;
}
struct string* create_string_copy(char* str) {
struct string* r = (struct string*)malloc(sizeof(struct string));
int64_t l = strlen(str);
r->data = (char*)malloc(l * sizeof(char));
strncpy(r->data, str, l);
r->length = l;
#ifdef DEBUG
printf("create_string_copy(\"%s\") = %d\n", str, (int)r);
#endif
return r;
}
void cstring(char* buffer, struct string* s){
memcpy(buffer, s->data, s->length);
buffer[s->length] = 0;
#ifdef DEBUG
printf("cstring(%s, %d) = %d\n", buffer, (int)s, (int)buffer);
#endif
}
void _prim_string_print(struct string* p1){
#ifdef DEBUG
printf("_prim_string_print(%d)\n", (int)p1);
#endif
for(int i = 0; i < p1->length; i++) {
putchar(p1->data[i]);
}
}
void _prim_int_print(int64_t p1) {
#ifdef DEBUG
printf("_prim_int_print(%d)\n", (int)p1);
#endif
printf("%ld", p1);
}
struct string* _prim_read_string() {
char *buffer = NULL;
size_t len = 0;
size_t read;
read = getline(&buffer, &len, stdin);
if (read == -1) {
return create_string_len(0);
} else {
struct string* r = create_string_copy(buffer);
free(buffer);
#ifdef DEBUG
printf("_prim_string_read() = %d\n", (int)r);
#endif
return r;
}
}
void _prim_usleep(int64_t p1) {
#ifdef DEBUG
printf("_prim_usleep(%ld)\n", p1);
#endif
usleep(p1); // p1 microseconds
}
void _prim_error(struct string* p1) {
#ifdef DEBUG
printf("_prim_error(%d)\n", (int)p1);
#endif
_prim_string_print(p1);
exit(-1);
}
int64_t _prim_ffi_file_eof(int64_t p1) {
// Currently this is a placeholder implementation for the idris frontend.
// In the idris examples only the stdin gets tested for feof so p1 is ignored by now.
// Appropiate file handling will be implemented later on.
#ifdef DEBUG
printf("_prim_ffi_file_eof(%ld)\n", p1);
#endif
return feof(stdin);
}
struct string* _prim_string_concat(struct string* p1, struct string* p2) {
struct string* r = create_string_len(p1->length + p2->length);
memcpy(r->data, p1->data, p1->length);
memcpy(r->data + p1->length, p2->data, p2-> length);
#ifdef DEBUG
printf("_prim_string_concat(%d,%d) = %d\n", (int)p1, (int)p2, (int)r);
#endif
return r;
}
struct string* _prim_string_reverse(struct string* src){
struct string* dst = create_string_len(src->length);
for(size_t i = 0; i < src->length; i++) {
dst->data[i] = src->data[src->length - i - 1];
}
#ifdef DEBUG
printf("_prim_string_reverse(%d)\n", (int)src);
#endif
return dst;
}
int64_t _prim_string_eq(struct string* p1, struct string* p2){
#ifdef DEBUG
printf("_prim_string_eq(%d,%d)\n", (int)p1, (int)p2);
#endif
if(p1->length != p2->length) {
return 0;
}
return memcmp(p1->data, p2->data, p1->length) == 0;
}
int64_t _prim_string_lt(struct string* p1, struct string* p2) {
#ifdef DEBUG
printf("_prim_string_lt(%d,%d)\n", (int)p1, (int)p2);
#endif
int len = (p1->length < p2->length)?(p1->length):(p2->length);
int cmp = memcmp(p1->data,p2->data, len);
if (p1->length < p2->length) {
return (int64_t)(cmp <= 0);
} else {
return (int64_t)(cmp < 0);
}
}
int64_t _prim_string_head(struct string* p1) {
#ifdef DEBUG
printf("_prim_string_head(%d)\n", (int)p1);
#endif
if (p1->length == 0) {
printf("_prim_string_head\n");
exit(-1);
}
return (int64_t)p1->data[0];
}
int64_t _prim_string_len(struct string* p1) {
#ifdef DEBUG
printf("_prim_string_len(%d) = %ld\n", (int)p1, p1 -> length);
#endif
return p1->length;
}
struct string* _prim_string_tail(struct string* p1){
if(p1->length == 0) {
printf("_prim_string_tail\n");
exit(-1);
}
struct string* r = create_string_len(p1->length - 1);
memcpy(r->data, p1->data + 1, r->length);
#ifdef DEBUG
printf("_prim_string_tail(%d) = %d\n", (int)p1, (int)r);
#endif
return r;
}
struct string* _prim_string_cons(int64_t p1, struct string* p2){
struct string* r = create_string_len(p2->length + 1);
r->data[0] = (char)p1;
memcpy(r->data+1,p2->data,p2->length);
#ifdef DEBUG
printf("_prim_string_cons(%ld, %d) = %d\n", p1, (int)p2, (int)r);
#endif
return r;
}
struct string* _prim_int_str(int64_t p1){
#ifdef DEBUG
printf("_prim_int_str(%ld)\n", p1);
#endif
char buffer[BUFFER_SIZE];
int len = snprintf(buffer, BUFFER_SIZE, "%ld", p1);
if (len >= 0 && len < BUFFER_SIZE) {
return create_string_copy(buffer);
} else {
printf("_prim_int_str\n");
exit(-1);
}
}
int64_t _prim_str_int(struct string* p1) {
#ifdef DEBUG
printf("_prim_str_int(%d)\n", (int)p1);
#endif
char buffer[p1->length+1];
cstring(buffer, p1);
int64_t r = strtoll(buffer, NULL, 10);
return r;
}
float _prim_int_float(int64_t p1) {
#ifdef DEBUG
printf("_prim_int_float(%ld)\n", p1);
#endif
return (float)p1;
}
struct string* _prim_float_string(float p1) {
#ifdef DEBUG
printf("_prim_float_string(%f)\n", p1);
#endif
char buffer[BUFFER_SIZE];
int len = snprintf(buffer, BUFFER_SIZE, "%.13g", p1);
if (len >= 0 && len < BUFFER_SIZE) {
return create_string_copy(buffer);
} else {
printf("_prim_float_string\n");
exit(-1);
}
}
int64_t _prim_char_int(char p1) {
#ifdef DEBUG
printf("_prim_char_int(%c)\n", p1);
#endif
return (int64_t)p1;
}

36
grin/prim_ops.h Normal file
View File

@ -0,0 +1,36 @@
#include <stdio.h>
#include <stdlib.h>
#include <inttypes.h>
#include <stdbool.h>
#include <string.h>
struct string {
char* data;
int64_t length;
};
struct string* create_string_len(int64_t l);
struct string* create_string_copy(char *str);
// ASSUMPTION: The buffer has enough memory allocated to store the string
void cstring(char* buffer, struct string* s);
void _prim_string_print(struct string* p1);
void _prim_int_print(int64_t p1);
struct string* _prim_read_string();
void _prim_usleep(int64_t p1);
void _prim_error(struct string* p1);
int64_t _prim_ffi_file_eof(int64_t p1);
struct string* _prim_string_concat(struct string* p1, struct string* p2);
struct string* _prim_string_reverse(struct string* p1);
int64_t _prim_string_eq(struct string* p1, struct string* p2);
int64_t _prim_string_head(struct string* p1);
int64_t _prim_string_len(struct string* p1);
struct string* _prim_string_tail(struct string* p1);
struct string* _prim_string_cons(int64_t p1, struct string* p2);
int64_t _prim_string_lt(struct string* p1, struct string* p2);
struct string* _prim_int_str(int64_t p1);
int64_t _prim_str_int(struct string* p1);
float _prim_int_float(int64_t p1);
struct string* _prim_float_string(float p1);
int64_t _prim_char_int(char p1);

2
grin/src/Grin/Nametable.hs
View File

@ -78,6 +78,7 @@ external (External{..}) =
<*> ty eRetType
<*> mapM ty eArgsType
<*> (pure eEffectful)
<*> (pure eKind)
-- | Convert Names in the expression to Int identifiers and create
-- an associated name table.
@ -149,6 +150,7 @@ restore (exp, nt) = cata build exp where
(rty eRetType)
(map rty eArgsType)
eEffectful
eKind
rty :: Ty -> Ty
rty = \case

9
grin/src/Grin/Parse/AST.hs
View File

@ -108,13 +108,13 @@ satisfyM pred parser = do
externalBlock = do
L.indentGuard sc EQ pos1
kw "primop"
ext <- const PrimOp <$> kw "primop" <|> const FFI <$> kw "ffi"
eff <- const False <$> kw "pure" <|> const True <$> kw "effectful"
i <- L.indentGuard sc GT pos1
some $ try (external eff i)
some $ try (external ext eff i)
external :: Bool -> Pos -> Parser External
external eff i = do
external :: ExternalKind -> Bool -> Pos -> Parser External
external ext eff i = do
L.indentGuard sc EQ i
name <- var
L.indentGuard sc GT i >> op "::"
@ -125,6 +125,7 @@ external eff i = do
, eRetType = retTy
, eArgsType = reverse argTyRev
, eEffectful = eff
, eKind = ext
}
tyP :: Parser Ty

2
grin/src/Grin/Pretty.hs
View File

@ -188,7 +188,7 @@ instance Pretty EffectMap where
prettyExternals :: [External] -> Doc
prettyExternals exts = vcat (map prettyExtGroup $ groupBy (\a b -> eEffectful a == eEffectful b) exts) where
prettyExtGroup [] = mempty
prettyExtGroup l@(a : _) = keyword "primop" <+> (if eEffectful a then keyword "effectful" else keyword "pure") <$$> indent 2
prettyExtGroup l@(a : _) = (keyword $ case eKind a of { PrimOp -> "primop"; FFI -> "ffi" }) <+> (if eEffectful a then keyword "effectful" else keyword "pure") <$$> indent 2
(vsep [prettyFunction (eName, (eRetType, V.fromList eArgsType)) | External{..} <- l] <> line)
instance Pretty Ty where

19
grin/src/Grin/PrimOpsPrelude.hs
View File

@ -13,27 +13,27 @@ import Grin.TH
primPrelude :: Program
primPrelude = [progConst|
primop effectful
_prim_int_print :: T_Int64 -> T_Unit
ffi effectful
_prim_int_print :: T_Int64 -> T_Unit
_prim_usleep :: T_Int64 -> T_Unit
_prim_string_print :: T_String -> T_Unit
_prim_read_string :: T_String
_prim_usleep :: T_Int64 -> T_Unit
_prim_error :: T_String -> T_Unit
-- FFI - TODO: Handle FFI appropiately
_prim_ffi_file_eof :: T_Int64 -> T_Int64
primop pure
-- Everything that handles Strings are FFI implemented now.
ffi pure
-- String
_prim_string_concat :: T_String -> T_String -> T_String
_prim_string_reverse :: T_String -> T_String
_prim_string_lt :: T_String -> T_String -> T_Bool
_prim_string_eq :: T_String -> T_String -> T_Bool
_prim_string_head :: T_String -> T_Int64
_prim_string_lt :: T_String -> T_String -> T_Int64
_prim_string_eq :: T_String -> T_String -> T_Int64
_prim_string_head :: T_String -> T_Int64 -- TODO: Change to Char
_prim_string_tail :: T_String -> T_String
_prim_string_cons :: T_Int64 -> T_String -> T_String
_prim_string_len :: T_String -> T_Int64
ffi pure
-- Conversion
_prim_int_str :: T_Int64 -> T_String
_prim_str_int :: T_String -> T_Int64
@ -41,6 +41,7 @@ primPrelude = [progConst|
_prim_float_string :: T_Float -> T_String
_prim_char_int :: T_Char -> T_Int64
primop pure
-- Int
_prim_int_shr :: T_Int64 -> T_Int64
_prim_int_add :: T_Int64 -> T_Int64 -> T_Int64

7
grin/src/Grin/Syntax.hs
View File

@ -32,12 +32,18 @@ data Ty
| TySimple SimpleType
deriving (Generic, Data, NFData, Eq, Ord, Show)
data ExternalKind
= PrimOp -- ^ Implemented in the internal code generator
| FFI -- ^ Implemented in C and linked during the linker phase
deriving (Generic, Data, NFData, Eq, Ord, Show)
data External
= External
{ eName :: Name
, eRetType :: Ty
, eArgsType :: [Ty]
, eEffectful :: Bool
, eKind :: ExternalKind
}
deriving (Generic, Data, NFData, Eq, Ord, Show)
@ -117,6 +123,7 @@ externals = \case
-- * Binary instances
deriving instance Binary Name
deriving instance Binary ExternalKind
deriving instance Binary External
deriving instance Binary Ty
deriving instance Binary SimpleType

7
grin/src/Grin/SyntaxDefs.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, DeriveAnyClass, StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, DeriveAnyClass, StandaloneDeriving, LambdaCase #-}
module Grin.SyntaxDefs where
import Data.Text (Text, unpack)
@ -31,6 +31,11 @@ instance IsString Name where
instance PrintfArg Name where
formatArg = formatString . unpack . unNM
nameString :: Name -> String
nameString = \case
NM n -> unpack n
_ -> error "Name index found." -- This could have left in the AST after a problematic deserialisation.
-- * GRIN Tag
data TagType = C | F | P Int {-missing parameter count-}

61
grin/src/Pipeline/Pipeline.hs
View File

@ -75,7 +75,7 @@ import qualified AbstractInterpretation.Sharing.CodeGen as Sharing
import qualified Reducer.LLVM.CodeGen as CGLLVM
import qualified Reducer.LLVM.JIT as JITLLVM
import System.Directory
import System.Process
import qualified System.Process
import Data.Bifunctor
import qualified Data.Bimap as Bimap
@ -188,7 +188,8 @@ data PipelineStep
| PureEval
| JITLLVM
| PrintAST
| SaveLLVM Bool FilePath
| SaveLLVM Path
| SaveExecutable Bool Path -- Debug, Outputfile
| SaveGrin Path
| SaveBinary String
| DebugTransformationH (Hidden (Exp -> Exp))
@ -425,7 +426,8 @@ pipelineStep p = do
PrintGrin d -> printGrinM d
PureEval -> pureEval
JITLLVM -> jitLLVM
SaveLLVM relPath path -> saveLLVM relPath path
SaveLLVM path -> saveLLVM path
SaveExecutable dbg path -> saveExecutable dbg path
SaveGrin path -> saveGrin path
SaveBinary name -> saveBinary name
PrintAST -> printAST
@ -653,23 +655,46 @@ saveBinary name = do
let fname = printf "%03d.%s.binary" n name
liftIO $ Binary.encodeFile (outputDir </> fname) ent
saveLLVM :: Bool -> FilePath -> PipelineM ()
saveLLVM relPath fname' = do
e <- use psExp
relPath :: Path -> PipelineM String
relPath path = do
n <- use psSaveIdx
Just typeEnv <- use psTypeEnv
o <- view poOutputDir
let fname = if relPath then o </> printf "%03d.%s" n fname' else fname'
code = CGLLVM.codeGen typeEnv e
llName = printf "%s.ll" fname
sName = printf "%s.s" fname
liftIO . void $ do
Text.putStrLn $ ppllvm code
putStrLn "* to LLVM *"
_ <- CGLLVM.toLLVM llName code
putStrLn "* LLVM X64 codegen *"
callCommand $ printf "opt-7 -O3 %s | llc-7 -o %s" llName sName
readFile sName >>= putStrLn
pure $ case path of
Abs fname -> fname
Rel fname -> o </> printf "%03d.%s" n fname
callCommand :: String -> PipelineM ()
callCommand cmd = do
pipelineLog $ "Call command:" ++ cmd
liftIO $ System.Process.callCommand cmd
saveLLVM :: Path -> PipelineM ()
saveLLVM path = do
e <- use psExp
Just typeEnv <- use psTypeEnv
fname <- relPath path
let code = CGLLVM.codeGen typeEnv e
let llName = printf "%s.ll" fname
let sName = printf "%s.s" fname
pipelineLog "* to LLVM *"
void $ liftIO $ CGLLVM.toLLVM llName code
pipelineLog"* LLVM X64 codegen *"
callCommand $ printf "opt-7 -O3 %s | llc-7 -o %s" llName (sName :: String)
saveExecutable :: Bool -> Path -> PipelineM ()
saveExecutable debugSymbols path = do
pipelineLog "* generate llvm x64 optcode *"
let grinOptCodePath = Rel "grin-opt-code"
pipelineStep $ SaveLLVM grinOptCodePath
grinOptCodeFile <- relPath grinOptCodePath
fname <- relPath path
pipelineLog "* generate executable *"
callCommand $ printf
("llc-7 -O3 -relocation-model=pic -filetype=obj %s.ll" ++ if debugSymbols then " -debugger-tune=gdb" else "")
grinOptCodeFile
callCommand $ printf
("clang-7 -O3 prim_ops.c runtime.c %s.o -s -o %s" ++ if debugSymbols then " -g" else "")
grinOptCodeFile fname
debugTransformation :: (Exp -> Exp) -> PipelineM ()
debugTransformation t = do

5
grin/src/Reducer/LLVM/Base.hs
View File

@ -11,6 +11,7 @@ import Lens.Micro.Platform
import Data.Word
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import Data.Vector (Vector)
import Grin.Grin as Grin
@ -55,6 +56,8 @@ data Env
, _envTempCounter :: Int
, _envTypeEnv :: TypeEnv.TypeEnv
, _envTagMap :: Map Tag Constant
, _envStringMap :: Map Text AST.Name -- Grin String Literal -> AST.Name
, _envStringCounter :: Int
}
emptyEnv = Env
@ -68,6 +71,8 @@ emptyEnv = Env
, _envTempCounter = 0
, _envTypeEnv = TypeEnv.emptyTypeEnv
, _envTagMap = mempty
, _envStringMap = mempty
, _envStringCounter = 0
}
concat <$> mapM makeLenses [''Env]

100
grin/src/Reducer/LLVM/CodeGen.hs
View File

@ -18,8 +18,14 @@ import qualified Data.Set as Set
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.ByteString.Short as ShortByteString
import Data.String (fromString)
import Text.Printf (printf)
import Lens.Micro.Mtl
import LLVM.AST hiding (callingConvention, functionAttributes)
import LLVM.AST.AddrSpace
import LLVM.AST.Type as LLVM
import qualified LLVM.AST.Typed as LLVM
import LLVM.AST.Constant as C hiding (Add, ICmp)
@ -36,6 +42,7 @@ import LLVM.Module
import Control.Monad.Except
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Short as BSShort
import Grin.Grin as Grin
import Grin.Pretty
@ -46,6 +53,8 @@ import Reducer.LLVM.PrimOps
import Reducer.LLVM.TypeGen
import Reducer.LLVM.InferType
debugMode :: Bool
debugMode = True
@ -55,12 +64,25 @@ toLLVM fname mod = withContext $ \ctx -> do
BS.writeFile fname llvm
pure llvm
codeGenLit :: Lit -> C.Constant
codeGenLit :: Lit -> CG C.Constant
codeGenLit = \case
LInt64 v -> Int {integerBits=64, integerValue=fromIntegral v}
LWord64 v -> Int {integerBits=64, integerValue=fromIntegral v}
LFloat v -> C.Float {floatValue=F.Single v}
LBool v -> Int {integerBits=1, integerValue=if v then 1 else 0}
LInt64 v -> pure $ Int {integerBits=64, integerValue=fromIntegral v}
LWord64 v -> pure $ Int {integerBits=64, integerValue=fromIntegral v}
LFloat v -> pure $ C.Float {floatValue=F.Single v}
LBool v -> pure $ Int {integerBits=1, integerValue=if v then 1 else 0}
LChar v -> pure $ Int {integerBits=8, integerValue=fromIntegral $ fromEnum v}
LString v -> C.GlobalReference stringType <$> strName v
strName :: Text.Text -> CG AST.Name
strName str = do
mName <- use $ envStringMap . at str
case mName of
Just n -> pure n
Nothing -> do
counter <- envStringCounter <<%= succ
let n = Name $ fromString $ "str." ++ show counter
envStringMap %= Map.insert str n
pure n
codeGenVal :: Val -> CG Operand
codeGenVal val = case val of
@ -95,7 +117,7 @@ codeGenVal val = case val of
ValTag tag -> ConstantOperand <$> getTagId tag
Unit -> pure unit
Lit lit -> pure . ConstantOperand . codeGenLit $ lit
Lit lit -> ConstantOperand <$> codeGenLit lit
Var name -> do
Map.lookup name <$> gets _constantMap >>= \case
-- QUESTION: what is this?
@ -111,7 +133,7 @@ codeGenVal val = case val of
getCPatConstant :: CPat -> CG Constant
getCPatConstant = \case
TagPat tag -> getTagId tag
LitPat lit -> pure $ codeGenLit lit
LitPat lit -> codeGenLit lit
NodePat tag args -> getTagId tag
DefaultPat -> pure C.TokenNone
@ -122,7 +144,10 @@ getCPatName = \case
LInt64 v -> "int_" <> showTS v
LWord64 v -> "word_" <> showTS v
LBool v -> "bool_" <> showTS v
LChar v -> "char_" <> showTS v
LString v -> error "pattern match on string is not supported"
LFloat v -> error "pattern match on float is not supported"
other -> error $ "pattern match not implemented: " ++ show other
NodePat tag _ -> tagName tag
DefaultPat -> "default"
where
@ -138,7 +163,7 @@ getCPatName = \case
toModule :: Env -> AST.Module
toModule Env{..} = defaultModule
{ moduleName = "basic"
, moduleDefinitions = heapPointerDef : reverse _envDefinitions
, moduleDefinitions = heapPointerDef : (stringDefinitions) ++ (reverse _envDefinitions)
}
where
heapPointerDef = GlobalDefinition globalVariableDefaults
@ -147,6 +172,30 @@ toModule Env{..} = defaultModule
, initializer = Just $ Int 64 0
}
stringDefinitions = concat
[ [ GlobalDefinition globalVariableDefaults
{ name = valAstName
, Global.type' = ArrayType (fromIntegral (length stringVal)) i8
, initializer = Just $ C.Array i8 $ [Int 8 $ fromIntegral $ fromEnum v0 | v0 <- stringVal]
}
, GlobalDefinition globalVariableDefaults
{ name = astName
, Global.type' = stringStructType
, initializer = Just $ C.Struct Nothing False -- TODO: Set struct name
[ C.GetElementPtr
{ inBounds = True
, address = GlobalReference (PointerType (ArrayType (fromIntegral (length stringVal)) i8) (AddrSpace 0)) valAstName
, indices = [Int {integerBits=64, integerValue=0}, Int {integerBits=64, integerValue=0}]
}
, Int 64 $ fromIntegral $ length stringVal
]
}
]
| (stringVal0, astName@(Name astNameBS)) <- Map.toList _envStringMap
, let stringVal = Text.unpack stringVal0
, let valAstName = Name $ BSShort.pack $ (BSShort.unpack astNameBS) ++ (BSShort.unpack ".val") -- Append ShortByteStrings
]
{-
type of:
ok - SApp Name [SimpleVal]
@ -194,12 +243,14 @@ codeGen typeEnv exp = toModule $ flip execState (emptyEnv {_envTypeEnv = typeEnv
SAppF name args -> do
(retType, argTypes) <- getFunctionType name
operands <- mapM codeGenVal args
operandsTypes <- mapM (\x -> toCGType <$> typeOfVal x) args
operandsTypes <- mapM (fmap toCGType . typeOfVal) args
-- convert values to function argument type
convertedArgs <- sequence $ zipWith3 codeGenValueConversion operandsTypes operands argTypes
if isExternalName (externals exp) name
then codeGenPrimOp name args convertedArgs
else do
let findExternalName :: TypeEnv.Name -> Maybe External
findExternalName n = List.find ((n ==) . eName) (externals exp)
case findExternalName name of
Just e -> codeExternal e convertedArgs
Nothing -> do
-- call to top level functions
let functionType = FunctionType
{ resultType = cgLLVMType retType
@ -282,7 +333,7 @@ codeGen typeEnv exp = toModule $ flip execState (emptyEnv {_envTypeEnv = typeEnv
ProgramF exts defs -> do
-- register prim fun lib
registerPrimFunLib
mapM registerPrimFunLib exts
sequence_ (map snd defs) >> pure (O unitCGType unit)
SFetchIF name Nothing -> do
@ -353,6 +404,15 @@ codeGenStoreNode val nodeLocation = do
pure $ (unitCGType, unit)
pure ()
convertStringOperand t o = case (cgType t,o) of
(T_SimpleType T_String, ConstantOperand stringRef@(GlobalReference{}))
-> ConstantOperand $ C.GetElementPtr
{ inBounds = False
, address = stringRef
, indices = [Int {integerBits=64, integerValue=0}, Int {integerBits=64, integerValue=0}]
}
_ -> o
codeGenCase :: Operand -> [(Alt, CG Result)] -> (CPat -> CG ()) -> CG Result
codeGenCase opVal alts bindingGen = do
curBlockName <- gets _currentBlockName
@ -435,6 +495,7 @@ codeGenTagSwitch tagVal nodeSet tagAltGen | Map.size nodeSet > 1 = do
activeBlock lastAltBlock
-- HINT: convert alt result to common type
convertedAltOp <- codeGenValueConversion altCGTy altOp resultCGType
closeBlock $ Br
{ dest = switchExit
, metadata' = []
@ -509,9 +570,16 @@ external retty label argtys = modify' (\env@Env{..} -> env {_envDefinitions = de
}
-- available primitive functions
registerPrimFunLib :: CG ()
registerPrimFunLib = do
external VoidType (mkName "_prim_int_print") [(i64, mkName "x")]
registerPrimFunLib :: External -> CG ()
registerPrimFunLib ext = do
external
(toLLVMType $ eRetType ext)
(mkName $ Text.unpack $ unNM $ eName ext)
[ (toLLVMType t, mkName ("x" ++ show n)) | (t,n) <- (eArgsType ext) `zip` [1..] ]
where
toLLVMType = \case
TySimple t -> typeGenSimpleType t
rest -> error $ "Unsupported type:" ++ show rest
errorBlock = do
activeBlock $ mkName "error_block"

115
grin/src/Reducer/LLVM/PrimOps.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-}
module Reducer.LLVM.PrimOps where
import Control.Monad (when)
import LLVM.AST
import qualified LLVM.AST.IntegerPredicate as I
import qualified LLVM.AST.FloatingPointPredicate as F
@ -13,66 +14,88 @@ import qualified Grin.Grin as Grin
import Grin.TypeEnv hiding (function)
import Reducer.LLVM.Base
import Reducer.LLVM.TypeGen
import Grin.PrimOpsPrelude
cgUnit = toCGType $ T_SimpleType T_Unit :: CGType
cgInt64 = toCGType $ T_SimpleType T_Int64 :: CGType
cgWord64 = toCGType $ T_SimpleType T_Word64 :: CGType
cgFloat = toCGType $ T_SimpleType T_Float :: CGType
cgBool = toCGType $ T_SimpleType T_Bool :: CGType
cgString = toCGType $ T_SimpleType T_String :: CGType
cgChar = toCGType $ T_SimpleType T_Char :: CGType
codeGenPrimOp :: Grin.Name -> [Grin.Val] -> [Operand] -> CG Result
codeGenPrimOp name _ [opA, opB] = case name of
codeExternal :: Grin.External -> [Operand] -> CG Result
codeExternal e ops = case Grin.eKind e of
Grin.PrimOp -> codeGenPrimOp (Grin.eName e) ops
Grin.FFI -> codeGenFFI e ops
codeGenPrimOp :: Grin.Name -> [Operand] -> CG Result
codeGenPrimOp name [opA, opB] = pure $ case name of
-- Int
"_prim_int_add" -> pure . I cgInt64 $ Add {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_sub" -> pure . I cgInt64 $ Sub {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_mul" -> pure . I cgInt64 $ Mul {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_div" -> pure . I cgInt64 $ SDiv {exact=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_eq" -> pure . I cgBool $ ICmp {iPredicate=I.EQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_ne" -> pure . I cgBool $ ICmp {iPredicate=I.NE, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_gt" -> pure . I cgBool $ ICmp {iPredicate=I.SGT, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_ge" -> pure . I cgBool $ ICmp {iPredicate=I.SGE, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_lt" -> pure . I cgBool $ ICmp {iPredicate=I.SLT, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_le" -> pure . I cgBool $ ICmp {iPredicate=I.SLE, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_add" -> I cgInt64 $ Add {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_sub" -> I cgInt64 $ Sub {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_mul" -> I cgInt64 $ Mul {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_div" -> I cgInt64 $ SDiv {exact=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_eq" -> I cgBool $ ICmp {iPredicate=I.EQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_ne" -> I cgBool $ ICmp {iPredicate=I.NE, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_gt" -> I cgBool $ ICmp {iPredicate=I.SGT, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_ge" -> I cgBool $ ICmp {iPredicate=I.SGE, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_lt" -> I cgBool $ ICmp {iPredicate=I.SLT, operand0=opA, operand1=opB, metadata=[]}
"_prim_int_le" -> I cgBool $ ICmp {iPredicate=I.SLE, operand0=opA, operand1=opB, metadata=[]}
-- Word
"_prim_word_add" -> pure . I cgWord64 $ Add {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_sub" -> pure . I cgWord64 $ Sub {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_mul" -> pure . I cgWord64 $ Mul {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_div" -> pure . I cgWord64 $ UDiv {exact=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_eq" -> pure . I cgBool $ ICmp {iPredicate=I.EQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_ne" -> pure . I cgBool $ ICmp {iPredicate=I.NE, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_gt" -> pure . I cgBool $ ICmp {iPredicate=I.UGT, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_ge" -> pure . I cgBool $ ICmp {iPredicate=I.UGE, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_lt" -> pure . I cgBool $ ICmp {iPredicate=I.ULT, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_le" -> pure . I cgBool $ ICmp {iPredicate=I.ULE, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_add" -> I cgWord64 $ Add {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_sub" -> I cgWord64 $ Sub {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_mul" -> I cgWord64 $ Mul {nsw=False, nuw=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_div" -> I cgWord64 $ UDiv {exact=False, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_eq" -> I cgBool $ ICmp {iPredicate=I.EQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_ne" -> I cgBool $ ICmp {iPredicate=I.NE, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_gt" -> I cgBool $ ICmp {iPredicate=I.UGT, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_ge" -> I cgBool $ ICmp {iPredicate=I.UGE, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_lt" -> I cgBool $ ICmp {iPredicate=I.ULT, operand0=opA, operand1=opB, metadata=[]}
"_prim_word_le" -> I cgBool $ ICmp {iPredicate=I.ULE, operand0=opA, operand1=opB, metadata=[]}
-- Float
"_prim_float_add" -> pure . I cgFloat $ FAdd {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_sub" -> pure . I cgFloat $ FSub {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_mul" -> pure . I cgFloat $ FMul {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_div" -> pure . I cgFloat $ FDiv {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_eq" -> pure . I cgBool $ FCmp {fpPredicate=F.OEQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_ne" -> pure . I cgBool $ FCmp {fpPredicate=F.ONE, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_gt" -> pure . I cgBool $ FCmp {fpPredicate=F.OGT, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_ge" -> pure . I cgBool $ FCmp {fpPredicate=F.OGE, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_lt" -> pure . I cgBool $ FCmp {fpPredicate=F.OLT, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_le" -> pure . I cgBool $ FCmp {fpPredicate=F.OLE, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_add" -> I cgFloat $ FAdd {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_sub" -> I cgFloat $ FSub {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_mul" -> I cgFloat $ FMul {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_div" -> I cgFloat $ FDiv {fastMathFlags=noFastMathFlags, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_eq" -> I cgBool $ FCmp {fpPredicate=F.OEQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_ne" -> I cgBool $ FCmp {fpPredicate=F.ONE, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_gt" -> I cgBool $ FCmp {fpPredicate=F.OGT, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_ge" -> I cgBool $ FCmp {fpPredicate=F.OGE, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_lt" -> I cgBool $ FCmp {fpPredicate=F.OLT, operand0=opA, operand1=opB, metadata=[]}
"_prim_float_le" -> I cgBool $ FCmp {fpPredicate=F.OLE, operand0=opA, operand1=opB, metadata=[]}
-- Bool
"_prim_bool_eq" -> pure . I cgBool $ ICmp {iPredicate=I.EQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_bool_ne" -> pure . I cgBool $ ICmp {iPredicate=I.NE, operand0=opA, operand1=opB, metadata=[]}
"_prim_bool_eq" -> I cgBool $ ICmp {iPredicate=I.EQ, operand0=opA, operand1=opB, metadata=[]}
"_prim_bool_ne" -> I cgBool $ ICmp {iPredicate=I.NE, operand0=opA, operand1=opB, metadata=[]}
codeGenPrimOp "_prim_int_print" _ [opA] = pure . I cgUnit $ Call
{ tailCallKind = Nothing
, callingConvention = CC.C
, returnAttributes = []
, function = Right $ ConstantOperand $ C.GlobalReference (fun void [i64]) (mkName "_prim_int_print")
, arguments = [(opA, [])]
, functionAttributes = []
, metadata = []
_ -> error $ "unknown primop: " ++ show name
codeGenFFI :: Grin.External -> [Operand] -> CG Result
codeGenFFI e ops = do
if (length ops /= length (Grin.eArgsType e))
then error $ "Non saturated function call: " ++ show (e, ops)
else mkFunction (Grin.nameString $ Grin.eName e) (ops `zip` (Grin.eArgsType e)) (Grin.eRetType e)
mkFunction name ops_params_ty ret_ty = pure . I (tyToCGType ret_ty) $ Call
{ tailCallKind = Nothing
, callingConvention = CC.C
, returnAttributes = []
, function = Right $ ConstantOperand $ C.GlobalReference (fun (tyToLLVMType ret_ty) (tyToLLVMType <$> params_ty)) (mkName name)
, arguments = ops `zip` repeat []
, functionAttributes = []
, metadata = []
}
where
ptr ty = PointerType { pointerReferent = ty, pointerAddrSpace = AddrSpace 0}
fun ret args = ptr FunctionType {resultType = ret, argumentTypes = args, isVarArg = False}
codeGenPrimOp name args _ = error $ "unknown primitive operation: " ++ Grin.unpackName name ++ " arguments: " ++ show args
(ops, params_ty) = unzip ops_params_ty
tyToLLVMType t = case t of
Grin.TySimple st -> typeGenSimpleType st
_ -> error $ "Non simple type in: " ++ show (name, t)
tyToCGType t = case t of
Grin.TySimple st -> toCGType (T_SimpleType st)
_ -> error $ "Non simple type in: " ++ show (name, t)
fptr ty = PointerType { pointerReferent = ty, pointerAddrSpace = AddrSpace 0}
fun ret args = fptr FunctionType {resultType = ret, argumentTypes = args, isVarArg = False}

16
grin/src/Reducer/LLVM/TypeGen.hs
View File

@ -7,6 +7,7 @@ import Text.Printf
import Data.Word
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Vector (Vector)
@ -27,16 +28,24 @@ import Grin.Grin as Grin
import Grin.TypeEnv
import Grin.Pretty
-- QUESTION: T_Dead case?
stringStructType :: LLVM.Type
stringStructType = LLVM.StructureType False [ptr i8, i64]
stringType :: LLVM.Type
stringType = ptr stringStructType
typeGenSimpleType :: SimpleType -> LLVM.Type
typeGenSimpleType = \case
T_Int64 -> i64
T_Word64 -> i64
T_Float -> float
T_Bool -> i1
T_String -> stringType
T_Char -> i8
T_Unit -> LLVM.void
T_Location _ -> locationLLVMType
T_UnspecifiedLocation -> locationLLVMType
T_Dead -> error $ "Dead/unused type was given."
locationCGType :: CGType
locationCGType = toCGType $ T_SimpleType $ T_Location []
@ -189,9 +198,8 @@ toCGType t = case t of
getVarType :: Grin.Name -> CG CGType
getVarType name = do
TypeEnv{..} <- gets _envTypeEnv
case Map.lookup name _variable of
Nothing -> error ("unknown variable " ++ unpackName name)
Just ty -> pure $ toCGType ty
pure $ maybe (error ("unknown variable " ++ unpackName name)) toCGType
$ Map.lookup name _variable
getFunctionType :: Grin.Name -> CG (CGType, [CGType])
getFunctionType name = do

7
grin/src/Reducer/PrimOps.hs
View File

@ -18,6 +18,7 @@ import Data.Char (chr, ord)
import Grin.Grin
import Data.Map.Strict as Map
import Data.String (fromString)
import Data.Functor.Infix ((<$$>))
import Data.Text as Text
import Control.Monad.IO.Class
@ -54,8 +55,8 @@ evalPrimOp name params args = case name of
"_prim_string_tail" -> string_un_op string Text.tail
"_prim_string_len" -> string_un_op int (fromIntegral . Text.length)
"_prim_string_concat" -> string_bin_op string (\t1 t2 -> Text.concat [t1, t2])
"_prim_string_lt" -> string_bin_op bool (<)
"_prim_string_eq" -> string_bin_op bool (==)
"_prim_string_lt" -> string_bin_op int (boolean 0 1 <$$> (<))
"_prim_string_eq" -> string_bin_op int (boolean 0 1 <$$> (==))
"_prim_string_cons" -> string_cons
-- Int
@ -178,3 +179,5 @@ evalPrimOp name params args = case name of
primError = case args of
[RT_Lit (LString msg)] -> liftIO (ioError $ userError $ Text.unpack msg) >> pure RT_Unit
_ -> error $ "invalid arguments:" ++ show params ++ " " ++ show args ++ " for " ++ unpackName name
boolean f t x = if x then t else f

9
grin/test/ParserSpec.hs
View File

@ -323,6 +323,8 @@ spec = do
primop pure
_prim_string_concat :: T_String -> T_String -> T_String
ffi pure
newArrayArray :: {Int} -> {State %s} -> {GHC.Prim.Unit {MutableArrayArray %s}}
grinMain = pure ()
@ -334,12 +336,14 @@ spec = do
, eRetType = TySimple T_Unit
, eArgsType = [ TySimple T_String ]
, eEffectful = True
, eKind = PrimOp
}
, External
{ eName = "_prim_read_string"
, eRetType = TySimple T_String
, eArgsType = []
, eEffectful = True
, eKind = PrimOp
}
, External
{ eName = "newArrayArray#"
@ -350,6 +354,7 @@ spec = do
, TyCon "State#" [ TyVar "s" ]
]
, eEffectful = True
, eKind = PrimOp
}
, External
{ eName = "_prim_string_concat"
@ -359,6 +364,7 @@ spec = do
, TySimple T_String
]
, eEffectful = False
, eKind = PrimOp
}
, External
{ eName = "newArrayArray"
@ -369,6 +375,7 @@ spec = do
, TyCon "State" [ TyVar "s" ]
]
, eEffectful = False
, eKind = FFI
}
]
[ Def "grinMain" [] ( SReturn Unit ) ]
@ -403,12 +410,14 @@ spec = do
, TySimple T_String
]
, eEffectful = False
, eKind = PrimOp
}
, External
{ eName = NM { unNM = "_primB" }
, eRetType = TySimple T_String
, eArgsType = [ TySimple T_String ]
, eEffectful = False
, eKind = PrimOp
}
] []

237
grin/test/PrimOpsSpec.hs Normal file
View File

@ -0,0 +1,237 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
module PrimOpsSpec where
import Test.Hspec
import qualified Language.C.Inline as C
import qualified Language.C.Inline.Unsafe as CU
import Foreign.C.String
import Foreign.Marshal.Alloc
import Test.QuickCheck.Arbitrary (arbitrary)
import Test.QuickCheck.Gen
import Test.QuickCheck.Monadic
C.include "<stdio.h>"
C.include "../prim_ops.c"
spec :: Spec
spec = do
let randomString = listOf $ elements ['a' .. 'z']
let randomNonEmptyString = listOf1 $ elements ['a' .. 'z']
describe "_prim_string_len" $ do
let primStringLen str = do
cstr <- newCString str
l <- [C.block|long {
struct string* s1 = create_string_copy($(char* cstr));
return _prim_string_len(s1);
}|]
l `shouldBe` (fromIntegral $ length str)
it "works for empty string" $ primStringLen ""
it "works for one element string" $ primStringLen "a"
it "works for a longer string" $ primStringLen "1234567890"
it "works for a random string" $ monadicIO $ do
str <- pick randomString
run $ primStringLen str
describe "_prim_string_concat" $ do
let primSringConcat str1 str2 = do
cstr1 <- newCString str1
cstr2 <- newCString str2
let n = length str1 + length str2 + 1
allocaBytes n $ \buffer -> do
[C.block|void{
struct string* s1 = create_string_copy($(char* cstr1));
struct string* s2 = create_string_copy($(char* cstr2));
struct string* s3 = _prim_string_concat(s1,s2);
cstring($(char* buffer), s3);
}|]
res <- peekCString buffer
res `shouldBe` (str1 ++ str2)
pure ()
it "works for empty strings" $ primSringConcat "" ""
it "works for empty string left" $ primSringConcat "" "a"
it "works for empty string right" $ primSringConcat "a" ""
it "works for one length strings" $ primSringConcat "a" "a"
it "works for longer strings" $ primSringConcat "abc" "def"
it "works for random strings" $ monadicIO $ do
str1 <- pick randomString
str2 <- pick randomString
run $ primSringConcat str1 str2
describe "_prim_string_reverse" $ do
let primStringReverse str = do
cstr <- newCString str
let n = length str + 1
allocaBytes n $ \buffer -> do
[C.block|void{
struct string* s1 = create_string_copy($(char* cstr));
struct string* s2 = _prim_string_reverse(s1);
cstring($(char* buffer), s2);
}|]
res <- peekCString buffer
res `shouldBe` (reverse str)
pure ()
it "works for empty string" $ primStringReverse ""
it "works for one length string" $ primStringReverse "a"
it "works for a longer string" $ primStringReverse "abcdefg"
it "works for a random string" $ monadicIO $ do
str <- pick randomString
run $ primStringReverse str
describe "_prim_string_eq" $ do
let primStringEq str1 str2 = do
cstr1 <- newCString str1
cstr2 <- newCString str2
r <- [C.block|long{
struct string* s1 = create_string_copy($(char* cstr1));
struct string* s2 = create_string_copy($(char* cstr2));
return _prim_string_eq(s1, s2);
}|]
r `shouldBe` (if str1 == str2 then 1 else 0)
it "works for empty strings" $ primStringEq "" ""
it "works for empty string left" $ primStringEq "" "a"
it "works for empty string right" $ primStringEq "a" ""
it "works for same one length strings" $ primStringEq "a" "a"
it "works for same strings" $ primStringEq "aa" "aa"
it "works for different strings" $ primStringEq "abcd" "abce"
it "works for random strings" $ monadicIO $ do
str1 <- pick randomString
str2 <- pick randomString
run $ primStringEq str1 str2
describe "_prim_string_head" $ do
let primStringHead str = do
cstr <- newCString str
r <- [C.block|long{
struct string* s1 = create_string_copy($(char* cstr));
return _prim_string_head(s1);
}|]
r `shouldBe` (fromIntegral $ fromEnum $ head str)
it "works for one length string" $ primStringHead "a"
it "works for a longer string" $ primStringHead "bfmdh"
it "works for random non-empty strings" $ monadicIO $ do
str1 <- pick randomNonEmptyString
run $ primStringHead str1
describe "_prim_string_tail" $ do
let primStringTail str = do
cstr <- newCString str
let n = length str
allocaBytes n $ \buffer -> do
[C.block|void{
struct string* s1 = create_string_copy($(char* cstr));
struct string* s2 = _prim_string_tail(s1);
cstring($(char* buffer), s2);
}|]
res <- peekCString buffer
res `shouldBe` (tail str)
pure ()
it "works for one element string" $ primStringTail "a"
it "works for a longer string" $ primStringTail "lksdjfoa"
it "works for a random non-empty strings" $ monadicIO $ do
str1 <- pick randomNonEmptyString
run $ primStringTail str1
describe "_prim_string_cons" $ do
let primStringCons c0 str = do
cstr <- newCString (str :: String)
let n = length str + 1
let c = C.CChar $ fromIntegral $ fromEnum c0
allocaBytes n $ \buffer -> do
[C.block|void{
struct string* s1 = create_string_copy($(char* cstr));
struct string* s2 = _prim_string_cons($(char c), s1);
cstring($(char* buffer), s2);
}|]
res <- peekCString buffer
res `shouldBe` (c0:str)
pure ()
it "works for empty string" $ primStringCons 'a' ""
it "works for a one length string" $ primStringCons 'a' "b"
it "works for a longer string" $ primStringCons 'a' "sdflkje"
it "works for random string" $ monadicIO $ do
c <- pick $ elements ['a' .. 'z']
str <- pick $ randomString
run $ primStringCons c str
describe "_prim_string_lt" $ do
let primStringLt str1 str2 = do
cstr1 <- newCString str1
cstr2 <- newCString str2
r <- [C.block|long{
struct string* s1 = create_string_copy($(char* cstr1));
struct string* s2 = create_string_copy($(char* cstr2));
return _prim_string_lt(s1, s2);
}|]
r `shouldBe` (if str1 < str2 then 1 else 0)
it "works for random strings" $ monadicIO $ do
str1 <- pick randomString
str2 <- pick randomString
run $ primStringLt str1 str2
describe "_prim_int_str" $ do
let primIntStr i0 = do
let i = C.CLong i0
allocaBytes 256 $ \buffer -> do
[C.block|void{
struct string* s1 = _prim_int_str($(long i));
cstring($(char* buffer), s1);
}|]
res <- peekCString buffer
res `shouldBe` (show i)
pure ()
it "works for random integers" $ monadicIO $ do
i <- pick arbitrary
run $ primIntStr i
describe "_prim_float_string" $ do
let primIntStr f0 = do
let f = C.CFloat f0
allocaBytes 256 $ \buffer -> do
[C.block|void{
struct string* s1 = _prim_float_string($(float f));
cstring($(char* buffer), s1);
}|]
res <- peekCString buffer
res `shouldBe` (show f0)
pure ()
xit "works for random float" $ monadicIO $ do
f <- pick arbitrary
run $ primIntStr f
describe "_prim_str_int" $ do
let primStrInt i = do
cstr <- newCString (show i)
r <- [C.block|long{
struct string* s1 = create_string_copy($(char* cstr));
return _prim_str_int(s1);
}|]
r `shouldBe` i
it "works for random integers" $ monadicIO $ do
i <- pick arbitrary
run $ primStrInt i
describe "_prim_int_float" $ do
let primIntFloat i0 = do
let i = C.CLong i0
r <- [C.block|float{
return _prim_int_float($(long i));
}|]
r `shouldBe` (fromIntegral i)
it "works for random integers" $ monadicIO $ do
i <- pick arbitrary
run $ primIntFloat i
describe "_prim_char_int" $ do
let primCharInt c0 = do
let c = C.CChar $ fromIntegral $ fromEnum c0
r <- [C.block|long{
return _prim_char_int($(char c));
}|]
r `shouldBe` (fromIntegral $ fromEnum c0)
it "works for random chars" $ monadicIO $ do
c <- pick $ elements ['a' .. 'z']
run $ primCharInt c

102
grin/test_prim_ops.c Normal file
View File

@ -0,0 +1,102 @@
#include <stdio.h>
#include <stdlib.h>
#include "prim_ops.h"
// Compile with
// clang-7 prim_ops.c test_prim_ops.c -o test_prim_ops
// This is a simple test file, the expected results are printed after the computed value.
int main() {
struct string* r = create_string_len(0);
struct string* s1;
struct string* s2;
struct string* s3;
struct string* s4;
s1 = create_string_copy("Hello.");
s2 = create_string_copy("World");
s3 = create_string_len(0);
s4 = create_string_copy("");
_prim_string_print(_prim_string_concat(s1,s2));
printf(" == Hello.World\n");
_prim_string_print(_prim_string_concat(s1,s3));
printf(" == Hello.\n");
_prim_string_print(_prim_string_concat(s3,s2));
printf(" == World\n");
_prim_string_print(_prim_string_concat(s1,s4));
printf(" == Hello.\n");
_prim_string_print(_prim_string_concat(s4,s2));
printf(" == World\n");
_prim_string_print(_prim_string_concat(s3,s4));
printf(" == \n");
_prim_string_print(_prim_string_concat(s3,s4));
printf(" == \n");
_prim_string_print(_prim_string_reverse(create_string_copy("")));
printf(" == \n");
_prim_string_print(_prim_string_reverse(create_string_copy("a")));
printf(" == a\n");
_prim_string_print(_prim_string_reverse(create_string_copy("ab")));
printf(" == ba \n");
_prim_string_print(_prim_string_reverse(create_string_copy("abc")));
printf(" == cba\n");
printf("%ld == 1\n", _prim_string_eq(s1,s1));
printf("%ld == 1\n", _prim_string_eq(s2,s2));
printf("%ld == 1\n", _prim_string_eq(s3,s3));
printf("%ld == 1\n", _prim_string_eq(s4,s4));
printf("%ld == 1\n", _prim_string_eq(s3,s4));
printf("%ld == 0\n", _prim_string_eq(s1,s2));
printf("%ld == 0\n", _prim_string_eq(s3,s1));
printf("%c == H\n", (char)_prim_string_head(s1));
_prim_string_print(_prim_string_tail(create_string_copy("a")));
printf(" == \n");
_prim_string_print(_prim_string_tail(create_string_copy("ab")));
printf(" == b\n");
_prim_string_print(_prim_string_tail(create_string_copy("abc")));
printf(" == bc\n");
_prim_string_print(_prim_string_cons(65, s3));
printf(" == A\n");
_prim_string_print(_prim_string_cons(65, create_string_copy("b")));
printf(" == Ab\n");
_prim_string_print(_prim_string_cons(65, create_string_copy("bc")));
printf(" == Abc\n");
printf("%ld == 0\n", _prim_string_lt(create_string_copy(""), create_string_copy("")));
printf("%ld == 1\n", _prim_string_lt(create_string_copy(""), create_string_copy("a")));
printf("%ld == 0\n", _prim_string_lt(create_string_copy("a"), create_string_copy("a")));
printf("%ld == 1\n", _prim_string_lt(create_string_copy("a"), create_string_copy("aa")));
printf("%ld == 1\n", _prim_string_lt(create_string_copy("aa"), create_string_copy("ab")));
printf("%ld == 1\n", _prim_string_lt(create_string_copy("aa"), create_string_copy("ab")));
printf("%ld == 1\n", _prim_string_lt(create_string_copy("aaa"), create_string_copy("ab")));
printf("%ld == 0\n", _prim_string_lt(create_string_copy("aaa"), create_string_copy("")));
printf("%ld == 0\n", _prim_string_lt(create_string_copy("bbb"), create_string_copy("aaa")));
_prim_string_print(_prim_int_str(0));
printf(" == 0\n");
_prim_string_print(_prim_int_str(10));
printf(" == 10\n");
_prim_string_print(_prim_int_str(-10));
printf(" == -10\n");
printf("%ld == 0\n", _prim_str_int(create_string_copy("0")));
printf("%ld == 10\n", _prim_str_int(create_string_copy("10")));
printf("%ld == +10\n", _prim_str_int(create_string_copy("+10")));
printf("%ld == -10\n", _prim_str_int(create_string_copy("-10")));
_prim_string_print(_prim_float_string(0.0));
printf(" == 0.0\n");
_prim_string_print(_prim_float_string(10.123));
printf(" == 10.123\n");
_prim_string_print(_prim_float_string(-10.34));
printf(" = -10.34\n");
printf("%d == 0\n", feof(stdin));
return 0;
}