idris-lang/Idris2
1
1
Fork 0
mirror of https://github.com/idris-lang/Idris2.git synced 2024-12-19 01:01:59 +03:00
Code Issues Projects Releases Wiki Activity

[RefC] merge with erase_trivial_constuctors

Browse Source
This commit is contained in:
HIROKI, Hattori 2024-01-28 02:15:03 +09:00
parent 9e538493dc
commit 3c21eb45d8
5 changed files with 39 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/Compiler/RefC/RefC.idr
View File

@ -470,9 +470,9 @@ cStatementsFromANF (ACon fc n coninfo tag args) lh _ =
if coninfo == UNIT || coninfo == NIL || coninfo == NOTHING || coninfo == ZERO
then emitAssign fc lh "((Value*)NULL /* ACon \{show n} \{show coninfo} */)"
else do
emitAssign fc lh "newConstructor(\{show $ length args}, \{maybe "0" show tag} /* ACon \{show n} \{show coninfo} */)"
emitAssign fc lh "newConstructor(\{show $ length args}, \{maybe "-1" show tag} /* ACon \{show n} \{show coninfo} */)"
let varname = "((Value_Constructor*)\{assignToName lh})"
when (coninfo == TYCON) $ emit emptyFC "\{varname}->tyconName = \{cStringQuoted $ show n};"
when (Nothing == tag) $ emit emptyFC "\{varname}->name = idris2_constr_\{cName n};"
fillConstructorArgs varname args 0
cStatementsFromANF (AOp fc _ op args) lh _ = emitAssign fc lh $ cOp op $ map varName args
@ -499,10 +499,9 @@ cStatementsFromANF (AConCase fc sc alts mDef) lh tailPosition = do
then emit emptyFC "\{els}if (NULL == \{sc'} /* \{show name} \{show coninfo} */) {"
else if coninfo == CONS || coninfo == JUST || coninfo == SUCC
then emit emptyFC "\{els}if (NULL != \{sc'} /* \{show name} \{show coninfo} */) {"
else if coninfo == TYCON
then emit emptyFC "\{els}if (! strcmp(((Value_Constructor*)\{sc'})->tyconName, \{cStringQuoted $ show name})) { "
else let Just tag' = tag | _ => throw $ InternalError "[refc] AConCase : MkConAlt has no tag. \{show name} \{show coninfo}"
in emit emptyFC "\{els}if (\{show tag'} == ((Value_Constructor*)\{sc'})->tag /* \{show name} \{show coninfo} */) {"
else case tag of -- FIXME: erase common string literal.
Nothing => emit emptyFC "\{els}if (! strcmp(((Value_Constructor *)\{sc'})->name, idris2_constr_\{cName name})) {"
Just tag' => emit emptyFC "\{els}if (((Value_Constructor *)\{sc'})->tag == \{show tag'}) {"
concaseBody (assignToName lh) sc' args bdy tailPosition
pure "} else " ) "" alts
@ -711,9 +710,14 @@ createCFunctions n (MkAFun args anf) = do
emit EmptyFC ""
pure ()
createCFunctions n (MkACon Nothing _ _) = do
let n' = cName n
update FunctionDefinitions $ \otherDefs => "char const idris2_constr_\{n'}[];" :: otherDefs
emit EmptyFC "char const idris2_constr_\{n'}[] = \{cStringQuoted $ show n};"
pure ()
createCFunctions n (MkACon tag arity nt) = do
emit EmptyFC $ ( "// Constructor tag " ++ show tag ++ " arity " ++ show arity) -- Nothing to compile here
emit EmptyFC $ ( "// \{show n} Constructor tag " ++ show tag ++ " arity " ++ show arity) -- Nothing to compile here
createCFunctions n (MkAForeign ccs fargs ret) = do

2
support/refc/_datatypes.h
View File

@ -111,7 +111,7 @@ typedef struct {
Value_header header;
int32_t total;
int32_t tag;
char const *tyconName;
char const *name;
Value *args[0];
} Value_Constructor;

4
support/refc/memoryManagement.c
View File

@ -15,8 +15,8 @@ Value *newConstructor(int total, int tag) {
retVal->header.tag = CONSTRUCTOR_TAG;
retVal->total = total;
retVal->tag = tag;
retVal->tyconName = NULL; // caller must initialize tyconName.
return (Value *)retVal; // caller must initialize args[]
retVal->name = NULL; // caller must initialize tyconName.
return (Value *)retVal; // caller must initialize args[]
}
Value *makeClosure(Value *(*f)(), uint8_t arity, uint8_t filled) {

12
support/refc/prim.c
View File

@ -231,3 +231,15 @@ Value *System_Concurrency_Raw_prim__conditionBroadcast(Value *_condition,
IDRIS2_REFC_VERIFY(!r, "pthread_cond_broadcast failed: %s", strerror(r));
return NULL;
}
char const idris2_constr_Int[] = "Int";
char const idris2_constr_Int8[] = "Int8";
char const idris2_constr_Int16[] = "Int16";
char const idris2_constr_Int32[] = "Int32";
char const idris2_constr_Int64[] = "Int64";
char const idris2_constr_Bits8[] = "Bits8";
char const idris2_constr_Bits16[] = "Bits16";
char const idris2_constr_Bits32[] = "Bits32";
char const idris2_constr_Bits64[] = "Bits64";
char const idris2_constr_Double[] = "Double";
char const idris2_constr_Integer[] = "Integer";

13
support/refc/prim.h
View File

@ -48,3 +48,16 @@ Value *System_Concurrency_Raw_prim__conditionWaitTimeout(Value *, Value *,
Value *System_Concurrency_Raw_prim__conditionSignal(Value *, Value *);
Value *System_Concurrency_Raw_prim__conditionBroadcast(Value *, Value *);
extern char const idris2_constr_Int[];
extern char const idris2_constr_Int8[];
extern char const idris2_constr_Int16[];
extern char const idris2_constr_Int32[];
extern char const idris2_constr_Int64[];
extern char const idris2_constr_Bits8[];
extern char const idris2_constr_Bits16[];
extern char const idris2_constr_Bits32[];
extern char const idris2_constr_Bits64[];
extern char const idris2_constr_Double[];
extern char const idris2_constr_Integer[];